src/packfile.c

   1 /*
   2 Copyright (C) 2001-2006, The Perl Foundation.
   3 This program is free software. It is subject to the same license as
   4 Parrot itself.
   5 $Id$
   6
   7 =head1 NAME
   8
   9 src/packfile.c - Parrot PackFile API
  10
  11 =head1 DESCRIPTION
  12
  13 =head2 PackFile Manipulation Functions
  14
  15 This file contains all the functions required for the processing of the
  16 structure of a PackFile. It is not intended to understand the byte code
  17 stream itself, but merely to dissect and reconstruct data from the
  18 various segments. See F<docs/parrotbyte.pod> for information about the
  19 structure of the frozen bytecode.
  20
  21 =over 4
  22
  23 =cut
  24
  25 */
  26
  27 #include "parrot/parrot.h"
  28 #include "parrot/embed.h"
  29 #include "parrot/packfile.h"
  30
  31 #include <assert.h>
  32
  33 #define TRACE_PACKFILE 0
  34 #define TRACE_PACKFILE_PMC 0
  35
  36 /*
  37 ** Static functions
  38 */
  39 static void segment_init (Interp*, struct PackFile_Segment *self,
  40                           struct PackFile *pf,
  41                           const char* name);
  42
  43 static void default_destroy (Interp*, struct PackFile_Segment *self);
  44 static size_t default_packed_size (Interp*,
  45                                    const struct PackFile_Segment *self);
  46 static opcode_t * default_pack (Interp*, const struct PackFile_Segment *self,
  47                                 opcode_t *dest);
  48 static opcode_t * default_unpack (Interp *,
  49                                   struct PackFile_Segment *self,
  50                                   opcode_t *dest);
  51 static void default_dump (Interp *,
  52                           struct PackFile_Segment *self);
  53
  54 static struct PackFile_Segment *directory_new (Interp*, struct PackFile *,
  55                                                const char *, int);
  56 static void directory_destroy (Interp*, struct PackFile_Segment *self);
  57 static size_t directory_packed_size (Interp*, struct PackFile_Segment *self);
  58 static opcode_t * directory_pack (Interp*, struct PackFile_Segment *,
  59                                   opcode_t *dest);
  60 static opcode_t * directory_unpack (Interp *,
  61                                     struct PackFile_Segment *,
  62                                     opcode_t *cursor);
  63 static void directory_dump (Interp *, struct PackFile_Segment *);
  64
  65 static struct PackFile_Segment *fixup_new (Interp*, struct PackFile *,
  66         const char *, int);
  67 static size_t fixup_packed_size (Interp*, struct PackFile_Segment *self);
  68 static opcode_t * fixup_pack (Interp*, struct PackFile_Segment * self,
  69         opcode_t *dest);
  70 static opcode_t * fixup_unpack (Interp *,
  71         struct PackFile_Segment*, opcode_t *cursor);
  72 static void fixup_destroy (Interp*, struct PackFile_Segment *self);
  73
  74 static struct PackFile_Segment *const_new (Interp*, struct PackFile *,
  75         const char *, int);
  76 static void const_destroy (Interp*, struct PackFile_Segment *self);
  77
  78 static struct PackFile_Segment *byte_code_new (Interp*, struct PackFile *pf,
  79         const char *, int);
  80 static void byte_code_destroy (Interp*, struct PackFile_Segment *self);
  81 static INTVAL pf_register_standard_funcs(Interp*, struct PackFile *pf);
  82
  83 static struct PackFile_Segment * pf_debug_new (Interp*, struct PackFile *,
  84         const char *, int);
  85 static size_t pf_debug_packed_size (Interp*, struct PackFile_Segment *self);
  86 static opcode_t * pf_debug_pack (Interp*, struct PackFile_Segment *self,
  87         opcode_t *);
  88 static void pf_debug_dump (Interp *, struct PackFile_Segment *);
  89 static opcode_t * pf_debug_unpack (Interp *,
  90         struct PackFile_Segment *self, opcode_t *);
  91 static void pf_debug_destroy (Interp*, struct PackFile_Segment *self);
  92
  93 static struct PackFile_Constant **find_constants(Interp*,
  94                                                  struct PackFile_ConstTable *);
  95
  96 #define ROUND_16(val) ( ((val) & 0xf) ? 16 - ((val) & 0xf) : 0 )
  97 #define ALIGN_16(st, cursor) \
  98     do { \
  99         (cursor) = (opcode_t *) \
 100            ((char *)(cursor) \
 101             + ROUND_16((char *)(cursor) - (char *)(st))); \
 102     } while (0)
 103
 104 /*
 105
 106 =item C<void
 107 PackFile_destroy(struct PackFile *pf)>
 108
 109 Delete a C<PackFile>.
 110
 111 =cut
 112
 113 */
 114
 115 void
 116 PackFile_destroy(Interp *interpreter, struct PackFile *pf)
 117 {
 118     if (!pf) {
 119         PIO_eprintf(NULL, "PackFile_destroy: pf == NULL!\n");
 120         return;
 121     }
 122 #ifdef PARROT_HAS_HEADER_SYSMMAN
 123     if (pf->is_mmap_ped)
 124         munmap((void*)pf->src, pf->size);
 125 #endif
 126     mem_sys_free(pf->header);
 127     pf->header = NULL;
 128     mem_sys_free(pf->dirp);
 129     pf->dirp = NULL;
 130     PackFile_Segment_destroy(interpreter, &pf->directory.base);
 131     return;
 132 }
 133
 134 /*
 135
 136 =item C<static INTVAL
 137 PackFile_check_segment_size(opcode_t segment_size, const char *debug)>
 138
 139 Internal function to check C<segment_size % sizeof(opcode_t)>.
 140
 141 =cut
 142
 143 */
 144
 145 static INTVAL
 146 PackFile_check_segment_size(opcode_t segment_size, const char *debug)
 147 {
 148 #if TRACE_PACKFILE
 149     PIO_eprintf(NULL,"PackFile_unpack(): Unpacking %ld bytes for %s table...\n",
 150            (long)segment_size, debug);
 151 #endif
 152
 153     if (segment_size % sizeof(opcode_t)) {
 154         PIO_eprintf(NULL,
 155                     "PackFile_unpack: Illegal %s table segment size "
 156                     "%ld (must be multiple of %ld)!\n",
 157                     debug, (long)segment_size, (long)sizeof(opcode_t));
 158         return 0;
 159     }
 160     return 1;
 161 }
 162
 163 /*
 164
 165 =item C<static void
 166 make_code_pointers(struct PackFile_Segment *seg)>
 167
 168 Make compat/shorthand pointers.
 169
 170 The first segments read are the default segments.
 171
 172 =cut
 173
 174 */
 175
 176 static void
 177 make_code_pointers(struct PackFile_Segment *seg)
 178 {
 179     struct PackFile * const pf = seg->pf;
 180
 181     switch (seg->type) {
 182         case PF_BYTEC_SEG:
 183             if (!pf->cur_cs) {
 184                 pf->cur_cs = (struct PackFile_ByteCode*)seg;
 185             }
 186             break;
 187         case PF_FIXUP_SEG:
 188             if (!pf->cur_cs->fixups) {
 189                 pf->cur_cs->fixups = (struct PackFile_FixupTable *)seg;
 190                 pf->cur_cs->fixups->code = pf->cur_cs;
 191             }
 192             break;
 193         case PF_CONST_SEG:
 194             if (!pf->cur_cs->const_table) {
 195                 pf->cur_cs->const_table = (struct PackFile_ConstTable*)seg;
 196                 pf->cur_cs->const_table->code = pf->cur_cs;
 197             }
 198         case PF_UNKNOWN_SEG:
 199             if (memcmp(seg->name, "PIC_idx", 7) == 0)
 200                 pf->cur_cs->pic_index = seg;
 201             break;
 202         case PF_DEBUG_SEG:
 203             pf->cur_cs->debugs = (struct PackFile_Debug*)seg;
 204             pf->cur_cs->debugs->code = pf->cur_cs;
 205             break;
 206         default:
 207             break;
 208     }
 209 }
 210
 211
 212 /*
 213
 214 =item C<static int
 215 sub_pragma(Parrot_Interp interpreter,
 216         int action, PMC *sub_pmc)>
 217
 218 Handle :load, :main ... pragmas for B<sub_pmc>
 219
 220 =cut
 221
 222 */
 223
 224 static int
 225 sub_pragma(Parrot_Interp interpreter, int action, PMC *sub_pmc)
 226 {
 227     int pragmas = PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_MASK;
 228     int todo = 0;
 229
 230     pragmas &= ~SUB_FLAG_IS_OUTER;
 231     if (!pragmas)
 232         return 0;
 233     switch (action) {
 234         case PBC_PBC:
 235         case PBC_MAIN:
 236             if (interpreter->resume_flag & RESUME_INITIAL) {
 237                 /*
 238                  * denote MAIN entry in first loaded PASM
 239                  */
 240                 todo = 1;
 241             }
 242             break;
 243         case PBC_LOADED:
 244             if (pragmas & SUB_FLAG_PF_LOAD) /* symreg.h:P_LOAD */
 245                 todo = 1;
 246             break;
 247     }
 248     if (pragmas & (SUB_FLAG_PF_IMMEDIATE | SUB_FLAG_PF_POSTCOMP))
 249         todo = 1;
 250     return todo;
 251 }
 252
 253 /*
 254
 255 =item C<static PMC* run_sub(Parrot_Interp interpreter, PMC* sub_pmc)>
 256
 257 Run the B<sub_pmc> due its B<:load>, B<:immediate>, ... pragma
 258
 259 =cut
 260
 261 */
 262
 263 static PMC*
 264 run_sub(Parrot_Interp interpreter, PMC* sub_pmc)
 265 {
 266     const Parrot_Run_core_t old = interpreter->run_core;
 267     PMC *retval;
 268
 269     /*
 270      * turn off JIT and prederef - both would act on the whole
 271      * PackFile which isn't worth the effort - probably
 272      */
 273     if (interpreter->run_core != PARROT_CGOTO_CORE  &&
 274             interpreter->run_core != PARROT_SLOW_CORE  &&
 275             interpreter->run_core != PARROT_FAST_CORE)
 276         interpreter->run_core = PARROT_FAST_CORE;
 277     CONTEXT(interpreter->ctx)->constants =
 278         interpreter->code->const_table->constants;
 279     retval = Parrot_runops_fromc_args(interpreter, sub_pmc, "P");
 280     interpreter->run_core = old;
 281     return retval;
 282 }
 283
 284 /*
 285
 286 =item <static PMC*
 287 do_1_sub_pragma(Parrot_Interp interpreter, struct PackFile *self, int action)>
 288
 289 Run autoloaded or immediate bytecode, mark MAIN subroutine entry
 290
 291 =cut
 292
 293 */
 294
 295 static PMC*
 296 do_1_sub_pragma(Parrot_Interp interpreter, PMC* sub_pmc, int action)
 297 {
 298
 299     size_t start_offs;
 300     struct Parrot_sub * const sub = PMC_sub(sub_pmc);
 301     PMC *result;
 302     void *lo_var_ptr;
 303
 304     switch (action) {
 305         case PBC_IMMEDIATE:
 306             /*
 307              * run IMMEDIATE sub
 308              */
 309             if (PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_IMMEDIATE) {
 310                 PObj_get_FLAGS(sub_pmc) &= ~SUB_FLAG_PF_IMMEDIATE;
 311                 lo_var_ptr = interpreter->lo_var_ptr;
 312                 result = run_sub(interpreter, sub_pmc);
 313                 /*
 314                  * reset initial flag so MAIN detection works
 315                  * and reset lo_var_ptr to prev
 316                  */
 317                 interpreter->resume_flag = RESUME_INITIAL;
 318                 interpreter->lo_var_ptr = lo_var_ptr;
 319                 return result;
 320             }
 321             break;
 322         case PBC_POSTCOMP:
 323             /*
 324              * run POSTCOMP sub
 325              */
 326             if (PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_POSTCOMP) {
 327                 PObj_get_FLAGS(sub_pmc) &= ~SUB_FLAG_PF_POSTCOMP;
 328                 run_sub(interpreter, sub_pmc);
 329                 /*
 330                  * reset initial flag so MAIN detection works
 331                  */
 332                 interpreter->resume_flag = RESUME_INITIAL;
 333                 return NULL;
 334             }
 335             break;
 336
 337         case PBC_LOADED:
 338             if (PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_LOAD) {
 339                 PObj_get_FLAGS(sub_pmc) &= ~SUB_FLAG_PF_LOAD;
 340                 run_sub(interpreter, sub_pmc);
 341             }
 342             break;
 343         default:
 344             if (PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_MAIN) {
 345                 if ((interpreter->resume_flag & RESUME_INITIAL) &&
 346                         interpreter->resume_offset == 0) {
 347                     ptrdiff_t code = (ptrdiff_t) sub->seg->base.data;
 348
 349                     start_offs =
 350                         ((ptrdiff_t) VTABLE_get_pointer(interpreter, sub_pmc)
 351                          - code) / sizeof(opcode_t*);
 352                     interpreter->resume_offset = start_offs;
 353                     PObj_get_FLAGS(sub_pmc) &= ~SUB_FLAG_PF_MAIN;
 354                     CONTEXT(interpreter->ctx)->current_sub = sub_pmc;
 355                 }
 356                 else {
 357                     /* XXX which warn_class */
 358                     Parrot_warn(interpreter, PARROT_WARNINGS_ALL_FLAG,
 359                                 ":main sub not allowed\n");
 360                 }
 361             }
 362     }
 363     return NULL;
 364 }
 365
 366 /*
 367  * while the PMCs should be constant, there possible contents like
 368  * a property isn't constructed const so we have to mark them
 369  */
 370 static void
 371 mark_1_seg(Parrot_Interp interpreter, struct PackFile_ConstTable *ct)
 372 {
 373     opcode_t i;
 374     struct PackFile_Constant **constants;
 375
 376     constants = find_constants(interpreter, ct);
 377     for (i = 0; i < ct->const_count; i++) {
 378         switch (constants[i]->type) {
 379             case PFC_PMC:
 380                 {
 381                 PMC * const pmc = constants[i]->u.key;
 382                 if (pmc)
 383                     pobject_lives(interpreter, (PObj *)pmc);
 384                 }
 385         }
 386     }
 387 }
 388
 389 static INTVAL
 390 find_const_iter(Interp* interpreter,
 391         struct PackFile_Segment *seg, void *user_data)
 392 {
 393     if (seg->type == PF_DIR_SEG) {
 394         PackFile_map_segments(interpreter, (struct PackFile_Directory*)seg,
 395                 find_const_iter, user_data);
 396     }
 397     else if (seg->type == PF_CONST_SEG) {
 398         mark_1_seg(interpreter, (struct PackFile_ConstTable *)seg);
 399     }
 400     return 0;
 401 }
 402
 403 void
 404 mark_const_subs(Parrot_Interp interpreter)
 405 {
 406     struct PackFile_Directory *dir;
 407
 408     struct PackFile * const self = interpreter->initial_pf;
 409     if (!self)
 410         return;
 411     /*
 412      * locate top level dir
 413      */
 414     dir = &self->directory;
 415     /*
 416      * iterate over all dir/segs
 417      */
 418     PackFile_map_segments(interpreter, dir, find_const_iter, NULL);
 419 }
 420
 421 /*
 422
 423 =item C<static void
 424 do_sub_pragmas(Interp *interpreter, struct PackFile_Bytecode *self,
 425    int action, PMC *eval_pmc)>
 426
 427 B<action> is one of
 428 B<PBC_PBC>, B<PBC_LOADED>, or B<PBC_MAIN>. Also store the C<eval_pmc>
 429 in the sub structure, so that the eval PMC is kept alive be living subs.
 430
 431 =cut
 432
 433 */
 434
 435 void
 436 do_sub_pragmas(Interp *interpreter, struct PackFile_ByteCode *self,
 437         int action, PMC *eval_pmc)
 438 {
 439     opcode_t i;
 440     PMC *sub_pmc, *result;
 441     struct PackFile_FixupTable *ft = self->fixups;
 442     struct PackFile_ConstTable *ct = self->const_table;
 443
 444 #if TRACE_PACKFILE
 445     PIO_eprintf(NULL, "PackFile: do_sub_pragmas (action=%d)\n", action);
 446 #endif
 447
 448     for (i = 0; i < ft->fixup_count; i++) {
 449         switch (ft->fixups[i]->type) {
 450             case enum_fixup_sub:
 451                 {
 452                 /*
 453                  * offset is an index into the const_table holding
 454                  * the Sub PMC
 455                  */
 456                 const opcode_t ci = ft->fixups[i]->offset;
 457                 if (ci < 0 || ci >= ct->const_count)
 458                     internal_exception(1,
 459                             "Illegal fixup offset (%d) in enum_fixup_sub");
 460                 sub_pmc = ct->constants[ci]->u.key;
 461                 PMC_sub(sub_pmc)->eval_pmc = eval_pmc;
 462                 if ((PObj_get_FLAGS(sub_pmc) & SUB_FLAG_PF_MASK) &&
 463                         sub_pragma(interpreter, action, sub_pmc)) {
 464                     result = do_1_sub_pragma(interpreter,
 465                             sub_pmc, action);
 466                     /*
 467                      * replace the Sub PMC with the result of the
 468                      * computation
 469                      */
 470                     if (action == PBC_IMMEDIATE &&
 471                             !PMC_IS_NULL(result)) {
 472                         ft->fixups[i]->type = enum_fixup_none;
 473                         ct->constants[ci]->u.key = result;
 474                     }
 475                 }
 476                 }
 477                 break;
 478             case enum_fixup_label:
 479                 /* fill in current bytecode seg */
 480                 ft->fixups[i]->seg = self;
 481                 break;
 482         }
 483     }
 484 }
 485
 486 /*
 487
 488 =item C<opcode_t
 489 PackFile_unpack(Interp *interpreter, struct PackFile *self,
 490                 opcode_t *packed, size_t packed_size)>
 491
 492 Unpack a C<PackFile> from a block of memory. The format is:
 493
 494   byte     wordsize
 495   byte     byteorder
 496   byte     major
 497   byte     minor
 498   byte     intvalsize
 499   byte     floattype
 500   byte     pad[10] = fingerprint
 501
 502   opcode_t magic
 503   opcode_t language type
 504
 505   opcode_t dir_format
 506   opcode_t padding
 507
 508   directory segment
 509     * segment
 510     ...
 511
 512 All segments have this common header:
 513
 514   - op_count    ... total segment size incl. this count
 515   - itype       ... internal type of data
 516   - id          ... id of data e.g. byte code nr.
 517   - size        ... size of data oparray
 518   - data[size]  ... data array e.g. bytecode
 519   segment specific data follows here ...
 520
 521 Checks to see if the magic matches the Parrot magic number for
 522 Parrot C<PackFiles>.
 523
 524 Returns size of unpacked if everything is OK, else zero (0).
 525
 526 =cut
 527
 528 */
 529
 530 opcode_t
 531 PackFile_unpack(Interp *interpreter, struct PackFile *self,
 532                 opcode_t *packed, size_t packed_size)
 533 {
 534     struct PackFile_Header *header = self->header;
 535     opcode_t *cursor;
 536
 537     if (!self) {
 538         PIO_eprintf(NULL, "PackFile_unpack: self == NULL!\n");
 539         return 0;
 540     }
 541     self->src = packed;
 542     self->size = packed_size;
 543
 544     /*
 545      * Map the header on top of the buffer later when we are sure
 546      * we have alignment done right.
 547      */
 548     cursor = (opcode_t*)((char*)packed + PACKFILE_HEADER_BYTES);
 549     memcpy(header, packed, PACKFILE_HEADER_BYTES);
 550
 551     if (header->wordsize != 4 && header->wordsize != 8) {
 552         PIO_eprintf(NULL, "PackFile_unpack: Invalid wordsize %d\n",
 553                     header->wordsize);
 554         return 0;
 555     }
 556     if (header->floattype != 0 && header->floattype != 1) {
 557         PIO_eprintf(NULL, "PackFile_unpack: Invalid floattype %d\n",
 558                     header->floattype);
 559         return 0;
 560     }
 561
 562     PackFile_assign_transforms(self);
 563
 564 #if TRACE_PACKFILE
 565     PIO_eprintf(NULL, "PackFile_unpack: Wordsize %d.\n", header->wordsize);
 566     PIO_eprintf(NULL, "PackFile_unpack: Floattype %d (%s).\n",
 567                 header->floattype,
 568                 header->floattype ?
 569                   "x86 little endian 12 byte long double" :
 570                   "IEEE-754 8 byte double");
 571     PIO_eprintf(NULL, "PackFile_unpack: Byteorder %d (%sendian).\n",
 572                 header->byteorder, header->byteorder ? "big " : "little-");
 573 #endif
 574
 575     if (header->major != PARROT_MAJOR_VERSION ||
 576             header->minor != PARROT_MINOR_VERSION) {
 577         PIO_eprintf(NULL, "PackFile_unpack: Bytecode not valid for this "
 578                 "interpreter: version mismatch\n");
 579         return 0;
 580     }
 581
 582     /* check the fingerprint */
 583     if (!PackFile_check_fingerprint (header->pad)) {
 584         PIO_eprintf(NULL, "PackFile_unpack: Bytecode not valid for this "
 585                     "interpreter: fingerprint mismatch\n");
 586         return 0;
 587     }
 588     /*
 589      * Unpack and verify the magic which is stored byteorder of the file:
 590      */
 591     header->magic = PF_fetch_opcode(self, &cursor);
 592
 593     /*
 594      * The magic and opcodetype fields are in native byteorder.
 595      */
 596     if (header->magic != PARROT_MAGIC) {
 597         PIO_eprintf(NULL, "PackFile_unpack: Not a Parrot PackFile!\n");
 598         PIO_eprintf(NULL, "Magic number was 0x%08x not 0x%08x\n",
 599                     header->magic, PARROT_MAGIC);
 600         return 0;
 601     }
 602
 603 #if TRACE_PACKFILE
 604     PIO_eprintf(NULL, "PackFile_unpack: Magic 0x%08x.\n",
 605                 header->magic);
 606 #endif
 607
 608     header->opcodetype = PF_fetch_opcode(self, &cursor);
 609
 610 #if TRACE_PACKFILE
 611     PIO_eprintf(NULL, "PackFile_unpack: Opcodetype 0x%x.\n",
 612                 header->opcodetype);
 613 #endif
 614
 615     /*
 616      * Unpack the dir_format
 617      */
 618
 619 #if TRACE_PACKFILE
 620     PIO_eprintf(NULL, "PackFile_unpack: Directory, offset %d.\n",
 621                 (INTVAL)cursor - (INTVAL)packed);
 622 #endif
 623     header->dir_format = PF_fetch_opcode(self, &cursor);
 624
 625     /* dir_format 1 use directory */
 626     if (header->dir_format != PF_DIR_FORMAT) {
 627         PIO_eprintf(NULL,
 628                 "PackFile_unpack: Dir format was %d not %d\n",
 629                     header->dir_format, PF_DIR_FORMAT);
 630         return 0;
 631     }
 632 #if TRACE_PACKFILE
 633     PIO_eprintf(NULL, "PackFile_unpack: Dirformat %d.\n", header->dir_format);
 634 #endif
 635
 636     (void)PF_fetch_opcode(self, &cursor); /* padding */
 637 #if TRACE_PACKFILE
 638     PIO_eprintf(NULL, "PackFile_unpack: Directory read, offset %d.\n",
 639                 (INTVAL)cursor - (INTVAL)packed);
 640 #endif
 641
 642     self->directory.base.file_offset = (INTVAL)cursor - (INTVAL)self->src;
 643     /*
 644      * now unpack dir, which unpacks its contents ...
 645      */
 646     Parrot_block_DOD(interpreter);
 647     cursor = PackFile_Segment_unpack(interpreter,
 648                                      &self->directory.base, cursor);
 649     Parrot_unblock_DOD(interpreter);
 650
 651 #ifdef PARROT_HAS_HEADER_SYSMMAN
 652     if (self->is_mmap_ped && (
 653                 self->need_endianize || self->need_wordsize)) {
 654         munmap((void *)self->src, self->size);
 655         self->is_mmap_ped = 0;
 656     }
 657 #endif
 658
 659 #if TRACE_PACKFILE
 660     PIO_eprintf(NULL, "PackFile_unpack: Unpack done.\n");
 661 #endif
 662
 663     return cursor - packed;
 664 }
 665
 666 /*
 667
 668 =item C<INTVAL
 669 PackFile_map_segments (Interp*, struct PackFile_Directory *dir,
 670                        PackFile_map_segments_func_t callback,
 671                        void *user_data)>
 672
 673 For each segment in the directory C<dir> the callback function
 674 C<callback> is called. The pointer C<user_data> is append to each call.
 675
 676 If a callback returns non-zero the processing of segments is stopped,
 677 and this value is returned.
 678
 679 =cut
 680
 681 */
 682
 683 INTVAL
 684 PackFile_map_segments (Interp* interpreter, struct PackFile_Directory *dir,
 685                        PackFile_map_segments_func_t callback,
 686                        void *user_data)
 687 {
 688     size_t i;
 689
 690     for (i = 0; i < dir->num_segments; i++) {
 691         const INTVAL ret = callback (interpreter, dir->segments[i], user_data);
 692         if (ret)
 693             return ret;
 694     }
 695
 696     return 0;
 697 }
 698
 699 /*
 700
 701 =item C<INTVAL
 702 PackFile_add_segment (struct PackFile_Directory *dir,
 703         struct PackFile_Segment *seg)>
 704
 705 Adds the Segment C<seg> to the directory C<dir> The PackFile becomes the
 706 owner of the segment; that means its getting destroyed, when the
 707 packfile gets destroyed.
 708
 709 =cut
 710
 711 */
 712
 713 INTVAL
 714 PackFile_add_segment (Interp* interpreter, struct PackFile_Directory *dir,
 715         struct PackFile_Segment *seg)
 716 {
 717
 718     if (dir->segments) {
 719         dir->segments =
 720             mem_sys_realloc(dir->segments,
 721                     sizeof (struct PackFile_Segment *) *
 722                     (dir->num_segments+1));
 723     }
 724     else {
 725         dir->segments = mem_sys_allocate(sizeof (struct PackFile_Segment *) *
 726                 (dir->num_segments+1));
 727     }
 728     dir->segments[dir->num_segments] = seg;
 729     dir->num_segments++;
 730     seg->dir = dir;
 731
 732     return 0;
 733 }
 734
 735 /*
 736
 737 =item C<struct PackFile_Segment *
 738 PackFile_find_segment (Interp *, struct PackFile_Directory *dir,
 739                        const char *name, int sub_dir)>
 740
 741 Finds the segment with the name C<name> in the C<PackFile_Directory> if
 742 C<sub_dir> is true, directories are searched recursively The segment is
 743 returned, but its still owned by the C<PackFile>.
 744
 745 =cut
 746
 747 */
 748
 749 struct PackFile_Segment *
 750 PackFile_find_segment (Interp *interpreter,
 751         struct PackFile_Directory *dir, const char *name, int sub_dir)
 752 {
 753     size_t i;
 754
 755     if (!dir)
 756         return NULL;
 757     for (i=0; i < dir->num_segments; i++) {
 758         struct PackFile_Segment *seg = dir->segments[i];
 759         if (seg && strcmp (seg->name, name) == 0) {
 760             return seg;
 761         }
 762         if (sub_dir && seg->type == PF_DIR_SEG) {
 763             seg = PackFile_find_segment(interpreter,
 764                     (struct PackFile_Directory *)seg, name, sub_dir);
 765             if (seg)
 766                 return seg;
 767         }
 768     }
 769
 770     return NULL;
 771 }
 772
 773 /*
 774
 775 =item C<struct PackFile_Segment *
 776 PackFile_remove_segment_by_name (Interp *, struct PackFile_Directory *dir,
 777                                  const char *name)>
 778
 779 Finds and removes the segment with name C<name> in the
 780 C<PackFile_Directory>. The segment is returned and must be destroyed by
 781 the user.
 782
 783 =cut
 784
 785 */
 786
 787 struct PackFile_Segment *
 788 PackFile_remove_segment_by_name (Interp* interpreter,
 789         struct PackFile_Directory *dir, const char *name)
 790 {
 791     size_t i;
 792
 793     for (i=0; i < dir->num_segments; i++) {
 794         struct PackFile_Segment * const seg = dir->segments[i];
 795         if (strcmp (seg->name, name) == 0) {
 796             dir->num_segments--;
 797             if (i != dir->num_segments) {
 798                 /* We're not the last segment, so we need to move things */
 799                 memmove(&dir->segments[i], &dir->segments[i+1],
 800                        (dir->num_segments - i) *
 801                        sizeof (struct PackFile_Segment *));
 802             }
 803             return seg;
 804         }
 805     }
 806
 807     return NULL;
 808 }
 809
 810 /*
 811
 812 =back
 813
 814 =head2 PackFile Structure Functions
 815
 816 =over 4
 817
 818 =item C<static void
 819 PackFile_set_header(struct PackFile *self)>
 820
 821 Fill a C<PackFile> header with system specific data.
 822
 823 =cut
 824
 825 */
 826
 827 static void
 828 PackFile_set_header(struct PackFile *self)
 829 {
 830     self->header->wordsize = sizeof(opcode_t);
 831     self->header->byteorder = PARROT_BIGENDIAN;
 832     self->header->major = PARROT_MAJOR_VERSION;
 833     self->header->minor = PARROT_MINOR_VERSION;
 834     self->header->intvalsize = sizeof(INTVAL);
 835     if (NUMVAL_SIZE == 8)
 836         self->header->floattype = 0;
 837     else /* if XXX */
 838         self->header->floattype = 1;
 839     /* write the fingerprint */
 840     PackFile_write_fingerprint(self->header->pad);
 841 }
 842
 843 /*
 844
 845 =item C<struct PackFile *
 846 PackFile_new(Interp*, INTVAL is_mapped)>
 847
 848 Allocate a new empty C<PackFile> and setup the directory.
 849
 850 Directory segment:
 851
 852   +----------+----------+----------+----------+
 853   |    Segment Header                         |
 854   |    ..............                         |
 855   +----------+----------+----------+----------+
 856
 857   +----------+----------+----------+----------+
 858   |    number of directory items              |
 859   +----------+----------+----------+----------+
 860
 861 followed by a sequence of items
 862
 863   +----------+----------+----------+----------+
 864   |    Segment type                           |
 865   +----------+----------+----------+----------+
 866   |    "name"                                 |
 867   |    ...     '\0'       padding bytes       |
 868   +----------+----------+----------+----------+
 869   |    Offset in the file                     |
 870   +----------+----------+----------+----------+
 871   |    Size of the segment                    |
 872   +----------+----------+----------+----------+
 873
 874 "name" is a NUL-terminated c-string encoded in plain ASCII.
 875
 876 Segment types are defined in F<include/parrot/packfile.h>.
 877
 878 Offset and size are in C<opcode_t>.
 879
 880 A Segment Header has these entries:
 881
 882  - op_count     total ops of segment incl. this count
 883  - itype        internal type of segment
 884  - id           internal id e.g code seg nr
 885  - size         size of following op array, 0 if none
 886  * data         possibly empty data, or e.g. byte code
 887
 888 =cut
 889
 890 */
 891
 892 struct PackFile *
 893 PackFile_new(Interp* interpreter, INTVAL is_mapped)
 894 {
 895     struct PackFile * const pf =
 896         mem_sys_allocate_zeroed(sizeof(struct PackFile));
 897
 898     if (!pf) {
 899         PIO_eprintf(NULL, "PackFile_new: Unable to allocate!\n");
 900         return NULL;
 901     }
 902     pf->is_mmap_ped = is_mapped;
 903
 904     pf->header =
 905         mem_sys_allocate_zeroed(sizeof(struct PackFile_Header));
 906     if(!pf->header) {
 907         PIO_eprintf(NULL, "PackFile_new: Unable to allocate header!\n");
 908         PackFile_destroy(interpreter, pf);
 909         return NULL;
 910     }
 911     /*
 912      * fill header with system specific data
 913      */
 914     PackFile_set_header(pf);
 915
 916     /* Other fields empty for now */
 917     pf->cur_cs = NULL;
 918     pf_register_standard_funcs(interpreter, pf);
 919     /* create the master directory, all subirs go there */
 920     pf->directory.base.pf = pf;
 921     pf->dirp = (struct PackFile_Directory *)
 922         PackFile_Segment_new_seg(interpreter, &pf->directory,
 923             PF_DIR_SEG, DIRECTORY_SEGMENT_NAME, 0);
 924     pf->directory = *pf->dirp;
 925     pf->fetch_op = (opcode_t (*)(unsigned char*)) NULLfunc;
 926     pf->fetch_iv = (INTVAL (*)(unsigned char*)) NULLfunc;
 927     pf->fetch_nv = (void (*)(unsigned char *, unsigned char *)) NULLfunc;
 928     return pf;
 929 }
 930
 931 /*
 932
 933 =item C<struct PackFile * PackFile_new_dummy(Interp*, const char *name)>
 934
 935 Create a new (initial) dummy PackFile. This is needed, if the interpreter
 936 doesn't load any bytecode, but is using Parrot_compile_string.
 937
 938 =cut
 939
 940 */
 941
 942 struct PackFile *
 943 PackFile_new_dummy(Interp* interpreter, const char *name)
 944 {
 945     struct PackFile *pf;
 946
 947     pf = PackFile_new(interpreter, 0);
 948     interpreter->initial_pf = pf;
 949     interpreter->code =
 950         pf->cur_cs = PF_create_default_segs(interpreter, name, 1);
 951     return pf;
 952 }
 953
 954 /*
 955
 956 =item C<INTVAL PackFile_funcs_register(Interp*, struct PackFile *pf,
 957                                        UINTVAL type,
 958                                        struct PackFile_funcs funcs)>
 959
 960 Register the C<pack>/C<unpack>/... functions for a packfile type.
 961
 962 =cut
 963
 964 */
 965
 966 INTVAL
 967 PackFile_funcs_register(Interp* interpreter,
 968         struct PackFile *pf, UINTVAL type, struct PackFile_funcs funcs)
 969 {
 970     /* TODO dynamic registering */
 971     pf->PackFuncs[type] = funcs;
 972     return 1;
 973 }
 974
 975 /*
 976
 977 =item C<static opcode_t * default_unpack (Interp *interpreter,
 978         struct PackFile_Segment *self, opcode_t *cursor)>
 979
 980 The default unpack function.
 981
 982 =cut
 983
 984 */
 985
 986 static opcode_t *
 987 default_unpack (Interp *interpreter,
 988         struct PackFile_Segment *self, opcode_t *cursor)
 989 {
 990     if (self->pf->header->dir_format) {
 991         self->op_count = PF_fetch_opcode(self->pf, &cursor);
 992         self->itype = PF_fetch_opcode(self->pf, &cursor);
 993         self->id = PF_fetch_opcode(self->pf, &cursor);
 994         self->size = PF_fetch_opcode(self->pf, &cursor);
 995     }
 996     if (self->size == 0)
 997         return cursor;
 998     /* if the packfile is mmap()ed just point to it if we don't
 999      * need any fetch transforms
1000      */
1001     if (self->pf->is_mmap_ped &&
1002             !self->pf->need_endianize && !self->pf->need_wordsize) {
1003         self->data = cursor;
1004         cursor += self->size;
1005         return cursor;
1006     }
1007     /* else allocate mem */
1008     self->data = mem_sys_allocate(self->size * sizeof(opcode_t));
1009
1010     if (!self->data) {
1011         PIO_eprintf(NULL,
1012                 "PackFile_unpack: Unable to allocate data memory!\n");
1013         self->size = 0;
1014         return 0;
1015     }
1016
1017     if(!self->pf->need_endianize && !self->pf->need_wordsize) {
1018         mem_sys_memcopy(self->data, cursor, self->size * sizeof(opcode_t));
1019         cursor += self->size;
1020     }
1021     else {
1022         int i;
1023         for(i = 0; i < (int)self->size ; i++) {
1024             self->data[i] = PF_fetch_opcode(self->pf, &cursor);
1025 #if TRACE_PACKFILE
1026             PIO_eprintf(NULL, "op[#%d] %u\n", i, self->data[i]);
1027 #endif
1028         }
1029     }
1030
1031     return cursor;
1032 }
1033
1034 /*
1035
1036 =item C<void
1037 default_dump_header (Parrot_Interp interpreter, struct PackFile_Segment *self)>
1038
1039 The default dump header function.
1040
1041 =cut
1042
1043 */
1044
1045 void
1046 default_dump_header (Parrot_Interp interpreter, struct PackFile_Segment *self)
1047 {
1048     PIO_printf(interpreter, "%s => [ # offs 0x%x(%d)",
1049             self->name, (int)self->file_offset, (int)self->file_offset);
1050     PIO_printf(interpreter, " = op_count %d, itype %d, id %d, size %d, ...",
1051             (int)self->op_count, (int)self->itype,
1052             (int)self->id, (int)self->size);
1053 }
1054
1055 /*
1056
1057 =item C<static void
1058 default_dump (Parrot_Interp interpreter, struct PackFile_Segment *self)>
1059
1060 The default dump function.
1061
1062 =cut
1063
1064 */
1065
1066 static void
1067 default_dump (Parrot_Interp interpreter, struct PackFile_Segment *self)
1068 {
1069     size_t i;
1070
1071     default_dump_header(interpreter, self);
1072     i = self->data ? 0: self->file_offset + 4;
1073     if (i % 8)
1074         PIO_printf(interpreter, "\n %04x:  ", (int) i);
1075
1076     for ( ; i < (self->data ? self->size :
1077             self->file_offset + self->op_count); i++) {
1078         if (i % 8 == 0) {
1079             PIO_printf(interpreter, "\n %04x:  ", (int) i);
1080         }
1081         PIO_printf(interpreter, "%08lx ", (unsigned long)
1082                 self->data ? self->data[i] : self->pf->src[i]);
1083     }
1084     PIO_printf(interpreter, "\n]\n");
1085 }
1086
1087 /*
1088
1089 =item C<static INTVAL
1090 pf_register_standard_funcs(Interp*, struct PackFile *pf)>
1091
1092 Called from within C<PackFile_new()> register the standard functions.
1093
1094 =cut
1095
1096 */
1097
1098 static INTVAL
1099 pf_register_standard_funcs(Interp* interpreter, struct PackFile *pf)
1100 {
1101     struct PackFile_funcs dirf = {
1102         directory_new,
1103         directory_destroy,
1104         directory_packed_size,
1105         directory_pack,
1106         directory_unpack,
1107         directory_dump
1108     };
1109     struct PackFile_funcs defaultf = {
1110         PackFile_Segment_new,
1111         (PackFile_Segment_destroy_func_t) NULLfunc,
1112         (PackFile_Segment_packed_size_func_t) NULLfunc,
1113         (PackFile_Segment_pack_func_t) NULLfunc,
1114         (PackFile_Segment_unpack_func_t) NULLfunc,
1115         default_dump
1116     };
1117     struct PackFile_funcs fixupf = {
1118         fixup_new,
1119         fixup_destroy,
1120         fixup_packed_size,
1121         fixup_pack,
1122         fixup_unpack,
1123         default_dump
1124     };
1125     struct PackFile_funcs constf = {
1126         const_new,
1127         const_destroy,
1128         PackFile_ConstTable_pack_size,
1129         PackFile_ConstTable_pack,
1130         PackFile_ConstTable_unpack,
1131         default_dump
1132     };
1133     struct PackFile_funcs bytef = {
1134         byte_code_new,
1135         byte_code_destroy,
1136         (PackFile_Segment_packed_size_func_t) NULLfunc,
1137         (PackFile_Segment_pack_func_t) NULLfunc,
1138         (PackFile_Segment_unpack_func_t) NULLfunc,
1139         default_dump
1140     };
1141     struct PackFile_funcs debugf = {
1142         pf_debug_new,
1143         pf_debug_destroy,
1144         pf_debug_packed_size,
1145         pf_debug_pack,
1146         pf_debug_unpack,
1147         pf_debug_dump
1148     };
1149     PackFile_funcs_register(interpreter, pf, PF_DIR_SEG, dirf);
1150     PackFile_funcs_register(interpreter, pf, PF_UNKNOWN_SEG, defaultf);
1151     PackFile_funcs_register(interpreter, pf, PF_FIXUP_SEG, fixupf);
1152     PackFile_funcs_register(interpreter, pf, PF_CONST_SEG, constf);
1153     PackFile_funcs_register(interpreter, pf, PF_BYTEC_SEG, bytef);
1154     PackFile_funcs_register(interpreter, pf, PF_DEBUG_SEG, debugf);
1155     return 1;
1156 }
1157
1158 /*
1159
1160 =item C<struct PackFile_Segment *
1161 PackFile_Segment_new_seg(Interp*, struct PackFile_Directory *dir, UINTVAL type,
1162         const char *name, int add)>
1163
1164 Create a new segment.
1165
1166 =cut
1167
1168 */
1169
1170 struct PackFile_Segment *
1171 PackFile_Segment_new_seg(Interp* interpreter,
1172         struct PackFile_Directory *dir, UINTVAL type,
1173         const char *name, int add)
1174 {
1175     struct PackFile * const pf = dir->base.pf;
1176     PackFile_Segment_new_func_t f = pf->PackFuncs[type].new_seg;
1177     struct PackFile_Segment * const seg = (f)(interpreter, pf, name, add);
1178     segment_init (interpreter, seg, pf, name);
1179     seg->type = type;
1180     if (add)
1181         PackFile_add_segment(interpreter, dir, seg);
1182     return seg;
1183 }
1184
1185 static struct PackFile_Segment *
1186 create_seg(Interp *interpreter, struct PackFile_Directory *dir,
1187         pack_file_types t, const char *name, const char *file_name, int add)
1188 {
1189     struct PackFile_Segment *seg;
1190
1191     const size_t len = strlen(name) + strlen(file_name) + 2;
1192     char * const buf = malloc(len);
1193
1194     sprintf(buf, "%s_%s", name, file_name);
1195     seg = PackFile_Segment_new_seg(interpreter, dir, t, buf, add);
1196     free(buf);
1197     return seg;
1198 }
1199
1200 /*
1201
1202 =item C<struct PackFile_ByteCode *
1203 PF_create_default_segs(Interp*, const char *file_name, int add)>
1204
1205 Create bytecode, constant, and fixup segment for C<file_nam>. If C<add>
1206 is true, the current packfile becomes the owner of these segments by
1207 adding the segments to the directory.
1208
1209 =cut
1210
1211 */
1212
1213 struct PackFile_ByteCode *
1214 PF_create_default_segs(Interp* interpreter, const char *file_name, int add)
1215 {
1216     struct PackFile * const pf = interpreter->initial_pf;
1217     struct PackFile_Segment *seg =
1218         create_seg(interpreter, &pf->directory,
1219             PF_BYTEC_SEG, BYTE_CODE_SEGMENT_NAME, file_name, add);
1220     struct PackFile_ByteCode * const cur_cs = (struct PackFile_ByteCode*)seg;
1221
1222     seg = create_seg(interpreter, &pf->directory,
1223             PF_FIXUP_SEG, FIXUP_TABLE_SEGMENT_NAME, file_name, add);
1224     cur_cs->fixups = (struct PackFile_FixupTable *)seg;
1225     cur_cs->fixups->code = cur_cs;
1226
1227     seg = create_seg(interpreter, &pf->directory,
1228             PF_CONST_SEG, CONSTANT_SEGMENT_NAME, file_name, add);
1229     cur_cs->const_table = (struct PackFile_ConstTable*) seg;
1230     cur_cs->const_table->code = cur_cs;
1231
1232     seg = create_seg(interpreter, &pf->directory,
1233             PF_UNKNOWN_SEG, "PIC_idx", file_name, add);
1234     cur_cs->pic_index = seg;
1235
1236     return cur_cs;
1237 }
1238 /*
1239
1240 =item C<void
1241 PackFile_Segment_destroy(Interp *, struct PackFile_Segment * self)>
1242
1243 =cut
1244
1245 */
1246
1247 void
1248 PackFile_Segment_destroy(Interp *interpreter, struct PackFile_Segment * self)
1249 {
1250     PackFile_Segment_destroy_func_t f =
1251         self->pf->PackFuncs[self->type].destroy;
1252     if (f)
1253         (f)(interpreter, self);
1254     default_destroy(interpreter, self);    /* destroy self after specific */
1255 }
1256
1257 /*
1258
1259 =item C<size_t
1260 PackFile_Segment_packed_size(Interp*, struct PackFile_Segment * self)>
1261
1262 =cut
1263
1264 */
1265
1266 size_t
1267 PackFile_Segment_packed_size(Interp* interpreter,
1268         struct PackFile_Segment * self)
1269 {
1270     size_t size = default_packed_size(interpreter, self);
1271     PackFile_Segment_packed_size_func_t f =
1272         self->pf->PackFuncs[self->type].packed_size;
1273     const size_t align = 16/sizeof(opcode_t);
1274     if (f)
1275         size += (f)(interpreter, self);
1276     if (align && size % align)
1277         size += (align - size % align);   /* pad/align it */
1278     return size;
1279 }
1280
1281 /*
1282
1283 =item C<opcode_t *
1284 PackFile_Segment_pack(Interp*, struct PackFile_Segment * self,
1285                       opcode_t *cursor)>
1286
1287 =cut
1288
1289 */
1290
1291 opcode_t *
1292 PackFile_Segment_pack(Interp* interpreter,
1293         struct PackFile_Segment * self, opcode_t *cursor)
1294 {
1295     PackFile_Segment_pack_func_t f =
1296         self->pf->PackFuncs[self->type].pack;
1297     const size_t align = 16/sizeof(opcode_t);
1298
1299     cursor = default_pack(interpreter, self, cursor);
1300     if (!cursor)
1301         return 0;
1302     if (f)
1303         cursor = (f)(interpreter, self, cursor);
1304     if (align && (cursor - self->pf->src) % align)
1305         cursor += align - (cursor - self->pf->src) % align;
1306     return cursor;
1307 }
1308
1309 /*
1310
1311 =item C<opcode_t *
1312 PackFile_Segment_unpack(Interp *interpreter,
1313         struct PackFile_Segment * self, opcode_t *cursor)>
1314
1315 All all these functions call the related C<default_*> function.
1316
1317 If a special is defined this gets called after.
1318
1319 =cut
1320
1321 */
1322
1323 opcode_t *
1324 PackFile_Segment_unpack(Interp *interpreter,
1325         struct PackFile_Segment * self, opcode_t *cursor)
1326 {
1327     PackFile_Segment_unpack_func_t f =
1328         self->pf->PackFuncs[self->type].unpack;
1329
1330     cursor = default_unpack(interpreter, self, cursor);
1331     if (!cursor)
1332         return 0;
1333     if (f) {
1334         cursor = (f)(interpreter, self, cursor);
1335         if (!cursor)
1336             return 0;
1337     }
1338     ALIGN_16(self->pf->src, cursor);
1339     return cursor;
1340 }
1341
1342 /*
1343
1344 =item C<void
1345 PackFile_Segment_dump(Interp *interpreter,
1346         struct PackFile_Segment *self)>
1347
1348 Dumps the segment C<self>.
1349
1350 =cut
1351
1352 */
1353
1354 void
1355 PackFile_Segment_dump(Interp *interpreter,
1356         struct PackFile_Segment *self)
1357 {
1358     self->pf->PackFuncs[self->type].dump(interpreter, self);
1359 }
1360
1361 /*
1362
1363 =back
1364
1365 =head2 Standard Directory Functions
1366
1367 =over 4
1368
1369 =item C<static struct PackFile_Segment *
1370 directory_new(Interp*, struct PackFile *pf, const char *name, int add)>
1371
1372 Returns a new C<PackFile_Directory> cast as a C<PackFile_Segment>.
1373
1374 =cut
1375
1376 */
1377
1378 static struct PackFile_Segment *
1379 directory_new (Interp* interpreter, struct PackFile *pf,
1380         const char *name, int add)
1381 {
1382     struct PackFile_Directory * const dir =
1383         mem_sys_allocate(sizeof(struct PackFile_Directory));
1384
1385     dir->num_segments = 0;
1386     dir->segments = NULL;
1387
1388     return (struct PackFile_Segment *)dir;
1389 }
1390
1391 /*
1392
1393 =item C<static void
1394 directory_dump(Interp *interpreter,
1395                 struct PackFile_Segment *self)>
1396
1397 Dumps the directory C<self>.
1398
1399 =cut
1400
1401 */
1402
1403 static void
1404 directory_dump (Interp *interpreter, struct PackFile_Segment *self)
1405 {
1406     struct PackFile_Directory * const dir = (struct PackFile_Directory *) self;
1407     size_t i;
1408
1409     default_dump_header(interpreter, self);
1410     PIO_printf(interpreter, "\n\t# %d segments\n", dir->num_segments);
1411     for (i=0; i < dir->num_segments; i++) {
1412         struct PackFile_Segment *seg = dir->segments[i];
1413         PIO_printf(interpreter,
1414                 "\ttype %d\t%s\t", (int)seg->type, seg->name);
1415         PIO_printf(interpreter,
1416                 " offs 0x%x(0x%x)\top_count %d\n",
1417                 (int)seg->file_offset,
1418                 (int)seg->file_offset * sizeof(opcode_t),
1419                 (int)seg->op_count);
1420     }
1421     PIO_printf(interpreter, "]\n");
1422     for (i=0; i < dir->num_segments; i++) {
1423         struct PackFile_Segment * const seg = dir->segments[i];
1424         PackFile_Segment_dump(interpreter, seg);
1425     }
1426 }
1427
1428 /*
1429
1430 =item C<static opcode_t *
1431 directory_unpack(Interp *interpreter,
1432         struct PackFile_Segment *segp, opcode_t * cursor)>
1433
1434 Unpacks the directory.
1435
1436 =cut
1437
1438 */
1439
1440 static opcode_t *
1441 directory_unpack (Interp *interpreter,
1442         struct PackFile_Segment *segp, opcode_t * cursor)
1443 {
1444     size_t i;
1445     struct PackFile_Directory * const dir = (struct PackFile_Directory *) segp;
1446     struct PackFile * const pf = dir->base.pf;
1447     opcode_t *pos;
1448
1449     dir->num_segments = PF_fetch_opcode (pf, &cursor);
1450     if (dir->segments) {
1451         dir->segments =
1452             mem_sys_realloc (dir->segments,
1453                              sizeof(struct PackFile_Segment *) *
1454                              dir->num_segments);
1455     }
1456     else {
1457         dir->segments =
1458             mem_sys_allocate(sizeof(struct PackFile_Segment *) *
1459                              dir->num_segments);
1460     }
1461
1462     for (i=0; i < dir->num_segments; i++) {
1463         struct PackFile_Segment *seg;
1464         size_t tmp;
1465         UINTVAL type;
1466         char *name;
1467
1468         /* get type */
1469         type = PF_fetch_opcode (pf, &cursor);
1470         if (type >= PF_MAX_SEG)
1471             type = PF_UNKNOWN_SEG;
1472 #if TRACE_PACKFILE
1473         PIO_eprintf(NULL, "Segment type %d.\n", type);
1474 #endif
1475         /* get name */
1476         name = PF_fetch_cstring(pf, &cursor);
1477 #if TRACE_PACKFILE
1478         PIO_eprintf(NULL, "Segment name \"%s\".\n", name);
1479 #endif
1480
1481         /* create it */
1482         seg = PackFile_Segment_new_seg(interpreter, dir, type, name, 0);
1483         mem_sys_free(name);
1484
1485         seg->file_offset = PF_fetch_opcode(pf, &cursor);
1486         seg->op_count = PF_fetch_opcode(pf, &cursor);
1487
1488         if (pf->need_wordsize) {
1489 #if OPCODE_T_SIZE == 8
1490             if (pf->header->wordsize == 4)
1491                 pos = pf->src + seg->file_offset / 2;
1492 #else
1493             if (pf->header->wordsize == 8)
1494                 pos = pf->src + seg->file_offset * 2;
1495 #endif
1496         } else
1497             pos = pf->src + seg->file_offset;
1498         tmp = PF_fetch_opcode (pf, &pos);
1499         if (seg->op_count != tmp) {
1500             fprintf (stderr,
1501                      "%s: Size in directory %d doesn't match size %d "
1502                      "at offset 0x%x\n", seg->name, (int)seg->op_count,
1503                      (int)tmp, (int)seg->file_offset);
1504         }
1505         if (i) {
1506             struct PackFile_Segment *last = dir->segments[i-1];
1507             if (last->file_offset + last->op_count != seg->file_offset) {
1508                 fprintf (stderr, "%s: sections are not back to back\n",
1509                         "section");
1510             }
1511         }
1512         make_code_pointers(seg);
1513
1514         /* store the segment */
1515         dir->segments[i] = seg;
1516         seg->dir = dir;
1517     }
1518
1519     ALIGN_16(pf->src, cursor);
1520     /* and now unpack contents of dir */
1521     for (i = 0; cursor && i < dir->num_segments; i++) {
1522         opcode_t *csave = cursor;
1523         size_t tmp = PF_fetch_opcode(pf, &cursor); /* check len again */
1524         size_t delta = 0;       /* keep gcc -O silent */
1525
1526         cursor = csave;
1527         pos = PackFile_Segment_unpack (interpreter, dir->segments[i],
1528                                        cursor);
1529         if (!pos) {
1530             fprintf (stderr, "PackFile_unpack segment '%s' failed\n",
1531                     dir->segments[i]->name);
1532             return 0;
1533         }
1534         if (pf->need_wordsize) {
1535 #if OPCODE_T_SIZE == 8
1536             if (pf->header->wordsize == 4)
1537                 delta = (pos - cursor) * 2;
1538 #else
1539             if (pf->header->wordsize == 8)
1540                 delta = (pos - cursor) / 2;
1541 #endif
1542         } else
1543             delta = pos - cursor;
1544         if ((size_t)delta != tmp || dir->segments[i]->op_count != tmp)
1545             fprintf(stderr, "PackFile_unpack segment '%s' directory length %d "
1546                     "length in file %d needed %d for unpack\n",
1547                     dir->segments[i]->name,
1548                     (int)dir->segments[i]->op_count, (int)tmp,
1549                     (int)delta);
1550         cursor = pos;
1551     }
1552     return cursor;
1553 }
1554
1555 /*
1556
1557 =item C<static void
1558 directory_destroy(Interp*, struct PackFile_Segment *self)>
1559
1560 Destroys the directory.
1561
1562 =cut
1563
1564 */
1565
1566 static void
1567 directory_destroy (Interp* interpreter, struct PackFile_Segment *self)
1568 {
1569     struct PackFile_Directory *dir = (struct PackFile_Directory *)self;
1570     size_t i;
1571
1572     for (i = 0; i < dir->num_segments; i++) {
1573         PackFile_Segment_destroy (interpreter, dir->segments[i]);
1574     }
1575     if (dir->segments) {
1576         mem_sys_free (dir->segments);
1577         dir->segments = NULL;
1578     }
1579 }
1580
1581 /*
1582
1583 =item C<static void
1584 sort_segs(Interp*, struct PackFile_Directory *dir)>
1585
1586 Sorts the segments in C<dir>.
1587
1588 =cut
1589
1590 */
1591
1592 static void
1593 sort_segs(Interp* interpreter, struct PackFile_Directory *dir)
1594 {
1595     const size_t num_segs = dir->num_segments;
1596
1597     struct PackFile_Segment *seg = dir->segments[0];
1598     if (seg->type != PF_BYTEC_SEG) {
1599         size_t i;
1600         for (i = 1; i < num_segs; i++) {
1601             struct PackFile_Segment * const s2 = dir->segments[i];
1602             if (s2->type == PF_BYTEC_SEG) {
1603                 dir->segments[0] = s2;
1604                 dir->segments[i] = seg;
1605                 break;
1606             }
1607         }
1608     }
1609     seg = dir->segments[1];
1610     if (seg->type != PF_FIXUP_SEG) {
1611         size_t i;
1612         for (i = 2; i < num_segs; i++) {
1613             struct PackFile_Segment * const s2 = dir->segments[i];
1614             if (s2->type == PF_FIXUP_SEG) {
1615                 dir->segments[1] = s2;
1616                 dir->segments[i] = seg;
1617                 break;
1618             }
1619         }
1620     }
1621 }
1622
1623 /*
1624
1625 =item C<static size_t
1626 directory_packed_size(Interp*, struct PackFile_Segment *self)>
1627
1628 Returns the size of the directory minus the value returned by
1629 C<default_packed_size()>.
1630
1631 =cut
1632
1633 */
1634
1635 static size_t
1636 directory_packed_size(Interp* interpreter, struct PackFile_Segment *self)
1637 {
1638     struct PackFile_Directory * const dir = (struct PackFile_Directory *)self;
1639     const size_t align = 16/sizeof(opcode_t);
1640     size_t size, i, seg_size;
1641
1642     /* need bytecode, fixup, other segs ... */
1643     sort_segs(interpreter, dir);
1644     /* number of segments + default, we need it for the offsets */
1645     size = 1 + default_packed_size(interpreter, self);
1646     for (i = 0; i < dir->num_segments; i++) {
1647         size += 3;        /* type, offset, size */
1648         size += PF_size_cstring(dir->segments[i]->name);
1649     }
1650     if (align && size % align)
1651         size += (align - size % align);   /* pad/align it */
1652     for (i=0; i < dir->num_segments; i++) {
1653         dir->segments[i]->file_offset = size + self->file_offset;
1654         seg_size = PackFile_Segment_packed_size (interpreter, dir->segments[i]);
1655         dir->segments[i]->op_count = seg_size;
1656         size += seg_size;
1657     }
1658     self->op_count = size;
1659     /* subtract default, it is added in PackFile_Segment_packed_size */
1660     return size - default_packed_size(interpreter, self);
1661 }
1662
1663 /*
1664
1665 =item C<static opcode_t *
1666 directory_pack(Interp*, struct PackFile_Segment *self, opcode_t *cursor)>
1667
1668 Packs the directory C<self>.
1669
1670 =cut
1671
1672 */
1673
1674 static opcode_t *
1675 directory_pack (Interp* interpreter, struct PackFile_Segment *self,
1676         opcode_t *cursor)
1677 {
1678     struct PackFile_Directory *dir = (struct PackFile_Directory *)self;
1679     size_t i;
1680     size_t align;
1681     const size_t num_segs = dir->num_segments;
1682
1683     *cursor++ = num_segs;
1684
1685     for (i = 0; i < num_segs; i++) {
1686         const struct PackFile_Segment * const seg = dir->segments[i];
1687         *cursor++ = seg->type;
1688         cursor = PF_store_cstring(cursor, seg->name);
1689         *cursor++ = seg->file_offset;
1690         *cursor++ = seg->op_count;
1691     }
1692     align = 16/sizeof(opcode_t);
1693     if (align && (cursor - self->pf->src) % align)
1694         cursor += align - (cursor - self->pf->src) % align;
1695     /* now pack all segments into new format */
1696     for (i = 0; i < dir->num_segments; i++) {
1697         struct PackFile_Segment * const seg = dir->segments[i];
1698         const size_t size = seg->op_count;
1699         opcode_t * const ret = PackFile_Segment_pack(interpreter, seg, cursor);
1700
1701         if ((size_t)(ret - cursor) != size) {
1702             internal_exception(1, "directory_pack segment '%s' used size %d "
1703                 "but reported %d\n", seg->name, (int)(ret-cursor), (int)size);
1704         }
1705         cursor = ret;
1706     }
1707
1708     return cursor;
1709 }
1710
1711 /*
1712
1713 =back
1714
1715 =head2 C<PackFile_Segment> Functions
1716
1717 =over 4
1718
1719 =item C<static void
1720 segment_init(Interp*, struct PackFile_Segment *self,
1721               struct PackFile *pf,
1722               const char *name)>
1723
1724 Initializes the segment C<self>.
1725
1726 =cut
1727
1728 */
1729
1730 static void
1731 segment_init (Interp* interpreter, struct PackFile_Segment *self,
1732               struct PackFile *pf,
1733               const char *name)
1734 {
1735     self->pf = pf;
1736     self->type = PF_UNKNOWN_SEG;
1737     self->file_offset = 0;
1738     self->op_count = 0;
1739     self->itype = 0;
1740     self->size = 0;
1741     self->data = NULL;
1742     self->id = 0;
1743     self->name = mem_sys_allocate (strlen (name) + 1);
1744     strcpy (self->name, name);
1745 }
1746
1747 /*
1748
1749 =item C<struct PackFile_Segment *
1750 PackFile_Segment_new(Interp*, struct PackFile *pf, const char *name, int add)>
1751
1752 Create a new default section.
1753
1754 =cut
1755
1756 */
1757
1758 struct PackFile_Segment *
1759 PackFile_Segment_new (Interp* interpreter,
1760         struct PackFile *pf, const char *name, int add)
1761 {
1762     struct PackFile_Segment * const seg =
1763         mem_sys_allocate(sizeof(struct PackFile_Segment));
1764
1765     return seg;
1766 }
1767
1768 /*
1769
1770 =back
1771
1772 =head2 Default Function Implementations
1773
1774 The default functions are called before the segment specific functions
1775 and can read a block of C<opcode_t> data.
1776
1777 =over 4
1778
1779 =item C<static void
1780 default_destroy(Interp*, struct PackFile_Segment *self)>
1781
1782 The default destroy function.
1783
1784 =cut
1785
1786 */
1787
1788 static void
1789 default_destroy (Interp* interpreter, struct PackFile_Segment *self)
1790 {
1791     if (!self->pf->is_mmap_ped && self->data) {
1792         mem_sys_free(self->data);
1793         self->data = NULL;
1794     }
1795     if (self->name) {
1796         mem_sys_free (self->name);
1797         self->name = NULL;
1798     }
1799     mem_sys_free (self);
1800 }
1801
1802 /*
1803
1804 =item C<static size_t
1805 default_packed_size(Interp*, struct PackFile_Segment *self)>
1806
1807 Returns the default size of the segment C<self>.
1808
1809 =cut
1810
1811 */
1812
1813 static size_t
1814 default_packed_size (Interp* interpreter, const struct PackFile_Segment *self)
1815 {
1816     /* op_count, itype, id, size */
1817     /* XXX There should be a constant defining this 4, and why */
1818     /* This is the 2nd place in the file that has this */
1819     return 4 + self->size;
1820 }
1821
1822 /*
1823
1824 =item C<static opcode_t *
1825 default_pack(Interp*, struct PackFile_Segment *self,
1826               opcode_t *dest)>
1827
1828 Performs the default pack.
1829
1830 =cut
1831
1832 */
1833
1834 static opcode_t *
1835 default_pack(Interp* interpreter, const struct PackFile_Segment *self,
1836               opcode_t *dest)
1837 {
1838     *dest++ = self->op_count;
1839     *dest++ = self->itype;
1840     *dest++ = self->id;
1841     *dest++ = self->size;
1842     if (self->size)
1843         memcpy (dest, self->data, self->size * sizeof(opcode_t));
1844     return dest + self->size;
1845 }
1846
1847 /* XXX Should be declared elsewhere */
1848 extern void Parrot_destroy_jit(void *ptr);
1849
1850 /*
1851
1852 =back
1853
1854 =head2 ByteCode
1855
1856 =over 4
1857
1858 =item C<static void
1859 byte_code_destroy(Interp*, struct PackFile_Segment *self)>
1860
1861 Destroys the C<PackFile_ByteCode> segment C<self>.
1862
1863 =cut
1864
1865 */
1866
1867 static void
1868 byte_code_destroy (Interp* interpreter, struct PackFile_Segment *self)
1869 {
1870     struct PackFile_ByteCode * const byte_code =
1871         (struct PackFile_ByteCode *)self;
1872
1873 #ifdef HAS_JIT
1874     Parrot_destroy_jit(byte_code->jit_info);
1875 #endif
1876     parrot_PIC_destroy(interpreter, byte_code);
1877     if (byte_code->prederef.code) {
1878         Parrot_free_memalign(byte_code->prederef.code);
1879         byte_code->prederef.code = NULL;
1880         if (byte_code->prederef.branches) {
1881             mem_sys_free(byte_code->prederef.branches);
1882             byte_code->prederef.branches = NULL;
1883         }
1884     }
1885     byte_code->fixups = NULL;
1886     byte_code->debugs = NULL;
1887     byte_code->const_table = NULL;
1888     byte_code->pic_index = NULL;
1889 }
1890
1891 /*
1892
1893 =item C<static struct PackFile_Segment *
1894 byte_code_new(Interp*, struct PackFile *pf, const char * name, int add)>
1895
1896 New C<PackFile_ByteCode> segment.
1897
1898 C<pf> and C<add> are ignored.
1899
1900 =cut
1901
1902 */
1903
1904 static struct PackFile_Segment *
1905 byte_code_new (Interp* interpreter, struct PackFile *pf,
1906         const char * name, int add)
1907 {
1908     struct PackFile_ByteCode *byte_code =
1909         mem_sys_allocate(sizeof(struct PackFile_ByteCode));
1910
1911     byte_code->base.dir = NULL;
1912
1913     byte_code->prederef.code = NULL;
1914     byte_code->prederef.branches = NULL;
1915     byte_code->prederef.n_allocated = 0;
1916     byte_code->jit_info = NULL;
1917     byte_code->prev = NULL;
1918     byte_code->debugs = NULL;
1919     byte_code->const_table = NULL;
1920     byte_code->fixups = NULL;
1921     byte_code->pic_index = NULL;
1922     byte_code->pic_store = NULL;
1923     return (struct PackFile_Segment *) byte_code;
1924 }
1925
1926 /*
1927
1928 =back
1929
1930 =head2 Debug Info
1931
1932 =over 4
1933
1934 =item C<static void
1935 pf_debug_destroy (Interp*, struct PackFile_Segment *self)>
1936
1937 Destroys the C<PackFile_Debug> segment C<self>.
1938
1939 =cut
1940
1941 */
1942
1943 static void
1944 pf_debug_destroy (Interp* interpreter, struct PackFile_Segment *self)
1945 {
1946     struct PackFile_Debug * const debug = (struct PackFile_Debug *) self;
1947     int i;
1948
1949     /* Free each mapping. */
1950     for (i = 0; i < debug->num_mappings; i++)
1951         mem_sys_free(debug->mappings[i]);
1952
1953     /* Free mappings pointer array. */
1954     mem_sys_free(debug->mappings);
1955     debug->mappings = NULL;
1956     debug->num_mappings = 0;
1957 }
1958
1959 /*
1960
1961 =item C<static struct PackFile_Segment *
1962 pf_debug_new (Interp*, struct PackFile *pf, const char * name, int add)>
1963
1964 Returns a new C<PackFile_Debug> segment.
1965
1966 C<pf> and C<add> ignored.
1967
1968 =cut
1969
1970 */
1971
1972 static struct PackFile_Segment *
1973 pf_debug_new (Interp* interpreter, struct PackFile *pf,
1974         const char * name, int add)
1975 {
1976     struct PackFile_Debug * const debug =
1977         mem_sys_allocate(sizeof(struct PackFile_Debug));
1978
1979     debug->code  = NULL;
1980     debug->mappings = mem_sys_allocate(sizeof(Parrot_Pointer));
1981     debug->mappings[0] = NULL;
1982     debug->num_mappings = 0;
1983
1984     return (struct PackFile_Segment *)debug;
1985 }
1986
1987 /*
1988
1989 =item C<static size_t
1990 pf_debug_packed_size (Interp*, struct PackFile_Segment *self)>
1991
1992 Returns the size of the C<PackFile_Debug> segment's filename in
1993 C<opcode_t> units.
1994
1995 =cut
1996
1997 */
1998
1999 static size_t
2000 pf_debug_packed_size (Interp* interpreter, struct PackFile_Segment *self)
2001 {
2002     struct PackFile_Debug * const debug = (struct PackFile_Debug *) self;
2003     int size = 0;
2004     int i;
2005
2006     /* Size of mappings count. */
2007     size += 1;
2008
2009     /* Size of entries in mappings list. */
2010     for (i = 0; i < debug->num_mappings; i++) {
2011         /* Bytecode offset and mapping type */
2012         size += 2;
2013
2014         /* Mapping specific stuff. */
2015         switch (debug->mappings[i]->mapping_type) {
2016             case PF_DEBUGMAPPINGTYPE_NONE:
2017                 break;
2018             case PF_DEBUGMAPPINGTYPE_FILENAME:
2019             case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2020                 size += 1;
2021                 break;
2022         }
2023     }
2024
2025     return size;
2026 }
2027
2028 /*
2029
2030 =item C<static opcode_t *
2031 pf_debug_pack(Interp*, struct PackFile_Segment *self, opcode_t *cursor)>
2032
2033 Pack the debug segment.
2034
2035 =cut
2036
2037 */
2038
2039 static opcode_t *
2040 pf_debug_pack (Interp* interpreter, struct PackFile_Segment *self,
2041         opcode_t *cursor)
2042 {
2043     struct PackFile_Debug * const debug = (struct PackFile_Debug *) self;
2044     int i;
2045
2046     /* Store number of mappings. */
2047     *cursor++ = debug->num_mappings;
2048
2049     /* Now store each mapping. */
2050     for (i = 0; i < debug->num_mappings; i++) {
2051         /* Bytecode offset and mapping type */
2052         *cursor++ = debug->mappings[i]->offset;
2053         *cursor++ = debug->mappings[i]->mapping_type;
2054
2055         /* Mapping specific stuff. */
2056         switch (debug->mappings[i]->mapping_type) {
2057             case PF_DEBUGMAPPINGTYPE_NONE:
2058                 break;
2059             case PF_DEBUGMAPPINGTYPE_FILENAME:
2060                 *cursor++ = debug->mappings[i]->u.filename;
2061                 break;
2062             case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2063                 *cursor++ = debug->mappings[i]->u.source_seg;
2064                 break;
2065         }
2066     }
2067
2068     return cursor;
2069 }
2070
2071 /*
2072
2073 =item C<static opcode_t *
2074 pf_debug_unpack(Interp *interpreter,
2075         struct PackFile_Segment *self, opcode_t *cursor)>
2076
2077 Unpack a debug segment into a PackFile_Debug structure.
2078
2079 =cut
2080
2081 */
2082
2083 static opcode_t *
2084 pf_debug_unpack (Interp *interpreter,
2085         struct PackFile_Segment *self, opcode_t *cursor)
2086 {
2087     struct PackFile_Debug * const debug = (struct PackFile_Debug *) self;
2088     struct PackFile_ByteCode *code;
2089     int i;
2090
2091     /* For some reason, we store the source file name in the segment
2092        name. So we can't find the bytecode seg without knowing the filename.
2093        But with the new scheme we can have many file names. For now, just
2094        base this on the name of the debug segment. */
2095     char *code_name = NULL;
2096     size_t str_len;
2097
2098     /* Number of mappings. */
2099     debug->num_mappings = PF_fetch_opcode(self->pf, &cursor);
2100
2101     /* Allocate space for mappings vector. */
2102     debug->mappings = mem_sys_allocate(sizeof(Parrot_Pointer) *
2103                                        (debug->num_mappings + 1));
2104
2105     /* Read in each mapping. */
2106     for (i = 0; i < debug->num_mappings; i++) {
2107         /* Allocate struct and get offset and mapping type. */
2108         debug->mappings[i] =
2109             mem_sys_allocate(sizeof(struct PackFile_DebugMapping));
2110         debug->mappings[i]->offset = PF_fetch_opcode(self->pf, &cursor);
2111         debug->mappings[i]->mapping_type = PF_fetch_opcode(self->pf, &cursor);
2112
2113         /* Read mapping specific stuff. */
2114         switch (debug->mappings[i]->mapping_type) {
2115             case PF_DEBUGMAPPINGTYPE_NONE:
2116                 break;
2117             case PF_DEBUGMAPPINGTYPE_FILENAME:
2118                 debug->mappings[i]->u.filename =
2119                     PF_fetch_opcode(self->pf, &cursor);
2120                 break;
2121             case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2122                 debug->mappings[i]->u.source_seg =
2123                     PF_fetch_opcode(self->pf, &cursor);
2124                 break;
2125         }
2126     }
2127
2128     /*
2129      * find seg e.g. CODE_DB => CODE
2130      * and attach it
2131      */
2132     code_name = strdup(debug->base.name);
2133     str_len = strlen(code_name);
2134     code_name[str_len - 3] = 0;
2135     code = (struct PackFile_ByteCode *)PackFile_find_segment(interpreter,
2136             self->dir, code_name, 0);
2137     if (!code || code->base.type != PF_BYTEC_SEG)
2138         internal_exception(1, "Code '%s' not found for debug segment '%s'\n",
2139                 code_name, self->name);
2140     code->debugs = debug;
2141     debug->code = code;
2142     free(code_name);
2143     return cursor;
2144 }
2145
2146
2147 /*
2148
2149 =item C<static void
2150 pf_debug_dump (Interp *interpreter, struct PackFile_Segment *self)>
2151
2152 Dumps a debug segment to a human readable form.
2153
2154 =cut
2155
2156 */
2157
2158 static void
2159 pf_debug_dump (Parrot_Interp interpreter, struct PackFile_Segment *self)
2160 {
2161     opcode_t i;
2162     size_t j;
2163     struct PackFile_Debug * const debug = (struct PackFile_Debug *) self;
2164     char *filename;
2165
2166     default_dump_header(interpreter, self);
2167
2168     PIO_printf(interpreter, "mappings => [\n");
2169     for (i = 0; i < debug->num_mappings; i++) {
2170         PIO_printf(interpreter, "    #%d\n    [\n", i);
2171         PIO_printf(interpreter, "        OFFSET => %d,\n",
2172                    debug->mappings[i]->offset);
2173         switch (debug->mappings[i]->mapping_type) {
2174             case PF_DEBUGMAPPINGTYPE_NONE:
2175                 PIO_printf(interpreter, "        MAPPINGTYPE => NONE\n");
2176                 break;
2177             case PF_DEBUGMAPPINGTYPE_FILENAME:
2178                 PIO_printf(interpreter, "        MAPPINGTYPE => FILENAME,\n");
2179                 filename = string_to_cstring(interpreter, PF_CONST(debug->code,
2180                            debug->mappings[i]->u.filename)->u.string);
2181                 PIO_printf(interpreter, "        FILENAME => %s\n", filename);
2182                 free(filename);
2183                 break;
2184             case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2185                 PIO_printf(interpreter, "        MAPPINGTYPE => SOURCESEG,\n");
2186                 PIO_printf(interpreter, "        SOURCESEG => %d\n",
2187                            debug->mappings[i]->u.source_seg);
2188                 break;
2189         }
2190         PIO_printf(interpreter, "    ],\n");
2191     }
2192     PIO_printf(interpreter, "]\n");
2193
2194     j = self->data ? 0: self->file_offset + 4;
2195     if (j % 8)
2196         PIO_printf(interpreter, "\n %04x:  ", (int) j);
2197
2198     for ( ; j < (self->data ? self->size :
2199             self->file_offset + self->op_count); j++) {
2200         if (j % 8 == 0) {
2201             PIO_printf(interpreter, "\n %04x:  ", (int) j);
2202         }
2203         PIO_printf(interpreter, "%08lx ", (unsigned long)
2204                 self->data ? self->data[j] : self->pf->src[j]);
2205     }
2206     PIO_printf(interpreter, "\n]\n");
2207 }
2208
2209 /*
2210
2211 =item C<struct PackFile_Debug *
2212 Parrot_new_debug_seg(Interp *interpreter,
2213         struct PackFile_ByteCode *cs, size_t size)>
2214
2215 Create and append (or resize) a new debug seg for a code segment.
2216
2217 =cut
2218
2219 */
2220
2221 struct PackFile_Debug *
2222 Parrot_new_debug_seg(Interp *interpreter,
2223         struct PackFile_ByteCode *cs, size_t size)
2224 {
2225     struct PackFile_Debug *debug;
2226
2227     if (cs->debugs) {    /* it exists already, resize it */
2228         debug = cs->debugs;
2229         debug->base.data = mem_sys_realloc(debug->base.data, size *
2230                 sizeof(opcode_t));
2231     }
2232     else {              /* create one */
2233         const size_t len = strlen(cs->base.name) + 4;
2234         char * const name = mem_sys_allocate(len);
2235
2236         sprintf(name, "%s_DB", cs->base.name);
2237         if (interpreter->code && interpreter->code->base.dir) {
2238             debug = (struct PackFile_Debug *)
2239                 PackFile_Segment_new_seg(interpreter,
2240                 interpreter->code->base.dir, PF_DEBUG_SEG, name, 1);
2241         }
2242         else {
2243             /* used by eval - don't register the segment */
2244             debug = (struct PackFile_Debug *)
2245                 PackFile_Segment_new_seg(interpreter,
2246                 cs->base.dir ?  cs->base.dir :
2247                     &interpreter->initial_pf->directory,
2248                 PF_DEBUG_SEG, name, 0);
2249         }
2250         mem_sys_free(name);
2251
2252         debug->base.data = mem_sys_allocate(size * sizeof(opcode_t));
2253         debug->num_mappings = 0;
2254         debug->mappings = mem_sys_allocate(1);
2255
2256         debug->code = cs;
2257         cs->debugs = debug;
2258     }
2259     debug->base.size = size;
2260     return debug;
2261 }
2262
2263 /*
2264
2265 =item c<void
2266 Parrot_debug_add_mapping(Interp *interpreter,
2267                          struct PackFile_Debug *debug,
2268                          opcode_t offset, int mapping_type,
2269                          const char *filename, int source_seg)>
2270
2271 Add a bytecode offset to filename/source segment mapping. mapping_type may be
2272 one of PF_DEBUGMAPPINGTYPE_NONE (in which case the last two parameters are
2273 ignored), PF_DEBUGMAPPINGTYPE_FILENAME (in which case filename must be given)
2274 or PF_DEBUGMAPPINGTYPE_SOURCESEG (in which case source_seg should contains the
2275 number of the source segment in question).
2276
2277 =cut
2278
2279 */
2280 void
2281 Parrot_debug_add_mapping(Interp *interpreter,
2282                          struct PackFile_Debug *debug,
2283                          opcode_t offset, int mapping_type,
2284                          const char *filename, int source_seg)
2285 {
2286     struct PackFile_DebugMapping *mapping;
2287     struct PackFile_ConstTable * const ct = debug->code->const_table;
2288     struct PackFile_Constant *fnconst;
2289     int insert_pos = 0;
2290
2291     /* Allocate space for the extra entry. */
2292     debug->mappings = mem_sys_realloc(debug->mappings,
2293         sizeof(Parrot_Pointer) * (debug->num_mappings + 1));
2294
2295     /* Can it just go on the end? */
2296     if (debug->num_mappings == 0 ||
2297         offset >= debug->mappings[debug->num_mappings - 1]->offset)
2298     {
2299         insert_pos = debug->num_mappings;
2300     }
2301     else {
2302         /* Find the right place and shift stuff that's after it. */
2303         int i;
2304         for (i = 0; i < debug->num_mappings; i++) {
2305             if (debug->mappings[i]->offset > offset) {
2306                 insert_pos = i;
2307                 memmove(debug->mappings + i + 1, debug->mappings + i,
2308                     debug->num_mappings - i);
2309                 break;
2310             }
2311         }
2312     }
2313
2314     /* Set up new entry and insert it. */
2315     mapping = mem_sys_allocate(sizeof(struct PackFile_DebugMapping));
2316     mapping->offset = offset;
2317     mapping->mapping_type = mapping_type;
2318     switch (mapping_type) {
2319         case PF_DEBUGMAPPINGTYPE_NONE:
2320             break;
2321         case PF_DEBUGMAPPINGTYPE_FILENAME:
2322             /* Need to put filename in constants table. */
2323             ct->const_count = ct->const_count + 1;
2324             if (ct->constants)
2325                 ct->constants = mem_sys_realloc(ct->constants,
2326                     ct->const_count * sizeof(Parrot_Pointer));
2327             else
2328                 ct->constants = mem_sys_allocate(
2329                     ct->const_count * sizeof(Parrot_Pointer));
2330             fnconst = PackFile_Constant_new(interpreter);
2331             fnconst->type = PFC_STRING;
2332             fnconst->u.string = string_make_direct(interpreter, filename,
2333                 strlen(filename), PARROT_DEFAULT_ENCODING,
2334                 PARROT_DEFAULT_CHARSET, PObj_constant_FLAG);
2335             ct->constants[ct->const_count - 1] = fnconst;
2336             mapping->u.filename = ct->const_count - 1;
2337             break;
2338         case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2339             mapping->u.source_seg = source_seg;
2340             break;
2341     }
2342     debug->mappings[insert_pos] = mapping;
2343     debug->num_mappings = debug->num_mappings + 1;
2344 }
2345
2346 /*
2347 =item C<STRING*
2348 Parrot_debug_pc_to_filename(Interp *interpreter,
2349         struct PackFile_Debug *debug, opcode_t pc)>
2350
2351 Take a position in the bytecode and return the filename of the source for
2352 that position.
2353
2354 =cut
2355
2356 */
2357
2358 STRING *
2359 Parrot_debug_pc_to_filename(Interp *interpreter,
2360         struct PackFile_Debug *debug, opcode_t pc)
2361 {
2362     /* Look through mappings until we find one that maps the passed
2363        bytecode offset. */
2364     int i;
2365     for (i = 0; i < debug->num_mappings; i++) {
2366         /* If this is the last mapping or the current position is
2367            between this mapping and the next one, return a filename. */
2368         if (i + 1 == debug->num_mappings ||
2369             (debug->mappings[i]->offset <= pc &&
2370              debug->mappings[i+1]->offset > pc))
2371         {
2372             switch (debug->mappings[i]->mapping_type) {
2373                 case PF_DEBUGMAPPINGTYPE_NONE:
2374                     return string_from_const_cstring(interpreter,
2375                         "(unknown file)", 0);
2376                 case PF_DEBUGMAPPINGTYPE_FILENAME:
2377                     return PF_CONST(debug->code,
2378                         debug->mappings[i]->u.filename)->u.string;
2379                 case PF_DEBUGMAPPINGTYPE_SOURCESEG:
2380                     return string_from_const_cstring(interpreter,
2381                         "(unknown file)", 0);
2382             }
2383         }
2384     }
2385
2386     /* Otherwise, no mappings = no filename. */
2387     return string_from_const_cstring(interpreter, "(unknown file)", 0);
2388 }
2389
2390 /*
2391
2392 =item C<void
2393 Parrot_switch_to_cs_by_nr(Interp *interpreter, opcode_t seg)>
2394
2395 Switch to byte code segment number C<seg>.
2396
2397 =cut
2398
2399 */
2400
2401 void
2402 Parrot_switch_to_cs_by_nr(Interp *interpreter, opcode_t seg)
2403 {
2404     struct PackFile_Directory * const dir = interpreter->code->base.dir;
2405     const size_t num_segs = dir->num_segments;
2406     size_t i;
2407     opcode_t n;
2408
2409     /* TODO make an index of code segments for faster look up */
2410     for (i = n = 0; i < num_segs; i++) {
2411         if (dir->segments[i]->type == PF_BYTEC_SEG) {
2412             if (n == seg) {
2413                 Parrot_switch_to_cs(interpreter, (struct PackFile_ByteCode *)
2414                         dir->segments[i], 1);
2415                 return;
2416             }
2417             n++;
2418         }
2419     }
2420     internal_exception(1, "Segment number %d not found\n", (int) seg);
2421 }
2422
2423 /*
2424
2425 =item C<struct PackFile_ByteCode *
2426 Parrot_switch_to_cs(Interp *interpreter,
2427     struct PackFile_ByteCode *new_cs, int really)>
2428
2429 Switch to a byte code segment C<new_cs>, returning the old segment.
2430
2431 =cut
2432
2433 */
2434
2435 struct PackFile_ByteCode *
2436 Parrot_switch_to_cs(Interp *interpreter,
2437     struct PackFile_ByteCode *new_cs, int really)
2438 {
2439     struct PackFile_ByteCode * const cur_cs = interpreter->code;
2440
2441     if (!new_cs) {
2442         internal_exception(NO_PREV_CS, "No code segment to switch to\n");
2443     }
2444     /* compiling source code uses this function too,
2445      * which gives misleading trace messages
2446      */
2447     if (really && Interp_trace_TEST(interpreter, PARROT_TRACE_SUB_CALL_FLAG)) {
2448         Interp *tracer = interpreter->debugger ?
2449             interpreter->debugger : interpreter;
2450         PIO_eprintf(tracer, "*** switching to %s\n",
2451                 new_cs->base.name);
2452     }
2453     interpreter->code = new_cs;
2454     CONTEXT(interpreter->ctx)->constants =
2455         really ? find_constants(interpreter, new_cs->const_table) :
2456         new_cs->const_table->constants;
2457             /* new_cs->const_table->constants; */
2458     CONTEXT(interpreter->ctx)->pred_offset =
2459         new_cs->base.data - (opcode_t*) new_cs->prederef.code;
2460     new_cs->prev = cur_cs;
2461     if (really)
2462         prepare_for_run(interpreter);
2463     return cur_cs;
2464 }
2465
2466 /*
2467
2468 =item C<void
2469 Parrot_pop_cs(Interp *interpreter)>
2470
2471 Remove current byte code segment from directory and switch to previous.
2472
2473 =cut
2474
2475 */
2476
2477 void
2478 Parrot_pop_cs(Interp *interpreter)
2479 {
2480     struct PackFile_ByteCode * const cur_cs = interpreter->code;
2481
2482     interpreter->code = cur_cs->prev;
2483     PackFile_remove_segment_by_name (interpreter,
2484             cur_cs->base.dir, cur_cs->base.name);
2485     /* FIXME delete returned segment */
2486 }
2487
2488 /*
2489
2490 =item C<static PackFile_Constant **
2491 find_constants(Interp *interpreter, struct PackFile_ConstTable *ct)>
2492
2493 Find the constant table associated with a thread. For now, we need to copy
2494 constant tables because some entries aren't really constant; e.g.
2495 subroutines need to reference namespace pointers.
2496
2497 =cut
2498
2499 */
2500
2501 static struct PackFile_Constant *
2502 clone_constant(Interp *interpreter, struct PackFile_Constant *old_const) {
2503     STRING * const _sub = interpreter->vtables[enum_class_Sub]->whoami;
2504
2505     if (old_const->type == PFC_PMC
2506             && VTABLE_isa(interpreter, old_const->u.key, _sub)) {
2507         struct PackFile_Constant *ret;
2508         PMC *old_sub;
2509         PMC *new_sub;
2510         ret = mem_sys_allocate(sizeof(struct PackFile_Constant));
2511
2512         ret->type = old_const->type;
2513
2514         old_sub = old_const->u.key;
2515         new_sub = Parrot_thaw_constants(interpreter,
2516             Parrot_freeze(interpreter, old_sub));
2517
2518         PMC_sub(new_sub)->seg = PMC_sub(old_sub)->seg;
2519         Parrot_store_sub_in_namespace(interpreter, new_sub);
2520
2521         ret->u.key = new_sub;
2522
2523         return ret;
2524     }
2525     else {
2526         return old_const;
2527     }
2528 }
2529
2530 static struct PackFile_Constant **
2531 find_constants(Interp *interpreter, struct PackFile_ConstTable *ct) {
2532     if (!n_interpreters || !interpreter->thread_data ||
2533             interpreter->thread_data->tid == 0) {
2534         return ct->constants;
2535     }
2536     else {
2537         Hash *tables;
2538         struct PackFile_Constant **new_consts;
2539
2540         assert(interpreter->thread_data);
2541
2542         if (!interpreter->thread_data->const_tables) {
2543             interpreter->thread_data->const_tables =
2544                 mem_sys_allocate(sizeof(Hash));
2545             parrot_new_pointer_hash(interpreter,
2546                                     &interpreter->thread_data->const_tables);
2547         }
2548
2549         tables = interpreter->thread_data->const_tables;
2550
2551         new_consts = parrot_hash_get(interpreter, tables, ct);
2552
2553         if (!new_consts) {
2554             /* need to construct it */
2555             struct PackFile_Constant **old_consts;
2556             INTVAL i;
2557             INTVAL const num_consts = ct->const_count;
2558
2559             old_consts = ct->constants;
2560             new_consts =
2561                 mem_sys_allocate(sizeof(struct PackFile_Constant*)*num_consts);
2562
2563             for (i = 0; i < num_consts; ++i) {
2564                 new_consts[i] = clone_constant(interpreter, old_consts[i]);
2565             }
2566
2567             parrot_hash_put(interpreter, tables, ct, new_consts);
2568         }
2569
2570         return new_consts;
2571     }
2572 }
2573
2574 void
2575 Parrot_destroy_constants(Interp *interpreter) {
2576     UINTVAL i;
2577     Hash *hash;
2578     if (!interpreter->thread_data) {
2579         return;
2580     }
2581
2582     hash = interpreter->thread_data->const_tables;
2583
2584     if (!hash) {
2585         return;
2586     }
2587
2588     for (i = 0; i <= hash->mask; ++i) {
2589         HashBucket *bucket = hash->bi[i];
2590         while (bucket) {
2591             struct PackFile_ConstTable *const table = bucket->key;
2592             struct PackFile_Constant **const orig_consts = table->constants;
2593             struct PackFile_Constant **const consts = bucket->value;
2594             INTVAL const const_count = table->const_count;
2595             INTVAL i;
2596             for (i = 0; i < const_count; ++i) {
2597                 if (consts[i] != orig_consts[i]) {
2598                     mem_sys_free(consts[i]);
2599                 }
2600             }
2601             mem_sys_free(consts);
2602             bucket = bucket->next;
2603         }
2604     }
2605
2606     parrot_hash_destroy(interpreter, hash);
2607 }
2608
2609 /*
2610
2611 =back
2612
2613 =head2 PackFile FixupTable Structure Functions
2614
2615 =over 4
2616
2617 =item C<void
2618 PackFile_FixupTable_clear(Interp *, struct PackFile_FixupTable *self)>
2619
2620 Clear a PackFile FixupTable.
2621
2622 =cut
2623
2624 */
2625
2626 void
2627 PackFile_FixupTable_clear(Interp *interpreter, struct PackFile_FixupTable *self)
2628 {
2629     opcode_t i;
2630     if (!self) {
2631         PIO_eprintf(NULL, "PackFile_FixupTable_clear: self == NULL!\n");
2632         return;
2633     }
2634
2635     for (i = 0; i < self->fixup_count; i++) {
2636         switch (self->fixups[i]->type) {
2637             case enum_fixup_label:
2638                 mem_sys_free(self->fixups[i]->name);
2639                 self->fixups[i]->name = NULL;
2640                 break;
2641         }
2642         mem_sys_free(self->fixups[i]);
2643         self->fixups[i] = NULL;
2644     }
2645
2646     if (self->fixup_count) {
2647         mem_sys_free(self->fixups);
2648         self->fixups = NULL;
2649     }
2650
2651     self->fixups = NULL;
2652     self->fixup_count = 0;
2653
2654     return;
2655 }
2656
2657 /*
2658
2659 =item C<static void
2660 fixup_destroy (Interp*, struct PackFile_Segment *self)>
2661
2662 Just calls C<PackFile_FixupTable_clear()> with C<self>.
2663
2664 =cut
2665
2666 */
2667
2668 static void
2669 fixup_destroy (Interp* interpreter, struct PackFile_Segment *self)
2670 {
2671     struct PackFile_FixupTable * const ft = (struct PackFile_FixupTable *) self;
2672     PackFile_FixupTable_clear(interpreter, ft);
2673 }
2674
2675 /*
2676
2677 =item C<static size_t
2678 fixup_packed_size(Interp*, struct PackFile_Segment *self)>
2679
2680 I<What does this do?>
2681
2682 =cut
2683
2684 */
2685
2686 static size_t
2687 fixup_packed_size (Interp* interpreter, struct PackFile_Segment *self)
2688 {
2689     struct PackFile_FixupTable * const ft = (struct PackFile_FixupTable *) self;
2690     size_t size;
2691     opcode_t i;
2692
2693     size = 1;    /* fixup_count */
2694     for (i = 0; i < ft->fixup_count; i++) {
2695         size++;  /* fixup_entry type */
2696         switch (ft->fixups[i]->type) {
2697             case enum_fixup_label:
2698             case enum_fixup_sub:
2699                 size += PF_size_cstring(ft->fixups[i]->name);
2700                 size ++; /* offset */
2701                 break;
2702             case enum_fixup_none:
2703                 break;
2704             default:
2705                 internal_exception(1, "Unknown fixup type\n");
2706                 return 0;
2707         }
2708     }
2709     return size;
2710 }
2711
2712 /*
2713
2714 =item C<static opcode_t *
2715 fixup_pack (Interp*, struct PackFile_Segment *self, opcode_t *cursor)>
2716
2717 I<What does this do?>
2718
2719 =cut
2720
2721 */
2722
2723 static opcode_t *
2724 fixup_pack(Interp* interpreter, struct PackFile_Segment *self, opcode_t *cursor)
2725 {
2726     struct PackFile_FixupTable * const ft = (struct PackFile_FixupTable *) self;
2727     opcode_t i;
2728
2729     *cursor++ = ft->fixup_count;
2730     for (i = 0; i < ft->fixup_count; i++) {
2731         *cursor++ = (opcode_t) ft->fixups[i]->type;
2732         switch (ft->fixups[i]->type) {
2733             case enum_fixup_label:
2734             case enum_fixup_sub:
2735                 cursor = PF_store_cstring(cursor, ft->fixups[i]->name);
2736                 *cursor++ = ft->fixups[i]->offset;
2737                 break;
2738             case enum_fixup_none:
2739                 break;
2740             default:
2741                 internal_exception(1, "Unknown fixup type\n");
2742                 return 0;
2743         }
2744     }
2745     return cursor;
2746 }
2747
2748 /*
2749
2750 =item C<static struct PackFile_Segment *
2751 fixup_new(Interp*, struct PackFile *pf, const char *name, int add)>
2752
2753 Returns a new C<PackFile_FixupTable> segment.
2754
2755 =cut
2756
2757 */
2758
2759 static struct PackFile_Segment *
2760 fixup_new (Interp* interpreter, struct PackFile *pf, const char *name, int add)
2761 {
2762     struct PackFile_FixupTable * const fixup =
2763         mem_sys_allocate(sizeof(struct PackFile_FixupTable));
2764
2765     fixup->fixup_count = 0;
2766     fixup->fixups = NULL;
2767     return (struct PackFile_Segment*) fixup;
2768 }
2769
2770 /*
2771
2772 =item C<static opcode_t *
2773 fixup_unpack(Interp *interpreter,
2774         struct PackFile_Segment *seg, opcode_t *cursor)>
2775
2776 Unpack a PackFile FixupTable from a block of memory.
2777
2778 Returns one (1) if everything is OK, else zero (0).
2779
2780 =cut
2781
2782 */
2783
2784 static opcode_t *
2785 fixup_unpack(Interp *interpreter,
2786         struct PackFile_Segment *seg, opcode_t *cursor)
2787 {
2788     opcode_t i;
2789     struct PackFile * pf;
2790     struct PackFile_FixupTable * const self = (struct PackFile_FixupTable *)seg;
2791
2792     if (!self) {
2793         PIO_eprintf(interpreter, "PackFile_FixupTable_unpack: self == NULL!\n");
2794         return 0;
2795     }
2796
2797     PackFile_FixupTable_clear(interpreter, self);
2798
2799     pf = self->base.pf;
2800     self->fixup_count = PF_fetch_opcode(pf, &cursor);
2801
2802     if (self->fixup_count) {
2803         self->fixups = mem_sys_allocate_zeroed(self->fixup_count *
2804                 sizeof(struct PackFile_FixupEntry *));
2805
2806         if (!self->fixups) {
2807             PIO_eprintf(interpreter,
2808                     "PackFile_FixupTable_unpack: Could not allocate "
2809                     "memory for array!\n");
2810             self->fixup_count = 0;
2811             return 0;
2812         }
2813     }
2814
2815     for (i = 0; i < self->fixup_count; i++) {
2816         struct PackFile_FixupEntry * const entry =
2817             self->fixups[i] =
2818             mem_sys_allocate(sizeof(struct PackFile_FixupEntry));
2819         self->fixups[i]->type = PF_fetch_opcode(pf, &cursor);
2820         switch (self->fixups[i]->type) {
2821             case enum_fixup_label:
2822             case enum_fixup_sub:
2823                 self->fixups[i]->name = PF_fetch_cstring(pf, &cursor);
2824                 self->fixups[i]->offset = PF_fetch_opcode(pf, &cursor);
2825                 break;
2826             case enum_fixup_none:
2827                 break;
2828             default:
2829                 PIO_eprintf(interpreter,
2830                         "PackFile_FixupTable_unpack: Unknown fixup type %d!\n",
2831                         self->fixups[i]->type);
2832                 return 0;
2833         }
2834     }
2835
2836     return cursor;
2837 }
2838
2839 /*
2840
2841 =item C<void PackFile_FixupTable_new_entry(Interp *interpreter,
2842         char *label, enum_fixup_t type, opcode_t offs)>
2843
2844 I<What does this do?>
2845
2846 =cut
2847
2848 */
2849
2850 void
2851 PackFile_FixupTable_new_entry(Interp *interpreter,
2852         char *label, enum_fixup_t type, opcode_t offs)
2853 {
2854     struct PackFile_FixupTable *self = interpreter->code->fixups;
2855     opcode_t i;
2856
2857     if (!self) {
2858         self = (struct PackFile_FixupTable  *) PackFile_Segment_new_seg(
2859                 interpreter,
2860                 interpreter->code->base.dir, PF_FIXUP_SEG,
2861                 FIXUP_TABLE_SEGMENT_NAME, 1);
2862         interpreter->code->fixups = self;
2863         self->code = interpreter->code;
2864     }
2865     i = self->fixup_count;
2866     self->fixup_count++;
2867     if (self->fixups) {
2868         self->fixups =
2869             mem_sys_realloc(self->fixups, self->fixup_count *
2870                             sizeof(struct PackFile_FixupEntry *));
2871     }
2872     else {
2873         self->fixups =
2874             mem_sys_allocate(sizeof(struct PackFile_FixupEntry *));
2875     }
2876     self->fixups[i] = mem_sys_allocate(sizeof(struct PackFile_FixupEntry));
2877     self->fixups[i]->type = type;
2878     self->fixups[i]->name = mem_sys_allocate(strlen(label) + 1);
2879     strcpy(self->fixups[i]->name, label);
2880     self->fixups[i]->offset = offs;
2881     self->fixups[i]->seg = self->code;
2882 }
2883
2884 /*
2885
2886 =item C<static struct PackFile_FixupEntry *
2887 find_fixup(struct PackFile_FixupTable *ft, enum_fixup_t type,
2888         const char *name)>
2889
2890 Finds the fix-up entry for C<name> and returns it.
2891
2892 =cut
2893
2894 */
2895
2896 static struct PackFile_FixupEntry *
2897 find_fixup(struct PackFile_FixupTable *ft, enum_fixup_t type,
2898         const char * name)
2899 {
2900     opcode_t i;
2901     for (i = 0; i < ft->fixup_count; i++) {
2902         if ((enum_fixup_t)ft->fixups[i]->type == type &&
2903                 !strcmp(ft->fixups[i]->name, name)) {
2904             ft->fixups[i]->seg = ft->code;
2905             return ft->fixups[i];
2906         }
2907     }
2908     return NULL;
2909 }
2910
2911 /*
2912
2913 =item C<static INTVAL
2914 find_fixup_iter(Interp*, struct PackFile_Segment *seg, void *user_data)>
2915
2916 I<What does this do?>
2917
2918 =cut
2919
2920 */
2921
2922 static INTVAL
2923 find_fixup_iter(Interp* interpreter, struct PackFile_Segment *seg,
2924         void *user_data)
2925 {
2926     if (seg->type == PF_DIR_SEG) {
2927         if (PackFile_map_segments(interpreter, (struct PackFile_Directory*)seg,
2928                 find_fixup_iter, user_data))
2929             return 1;
2930     }
2931     else if (seg->type == PF_FIXUP_SEG) {
2932         struct PackFile_FixupEntry ** const e = user_data;
2933         struct PackFile_FixupEntry * const fe = find_fixup(
2934                 (struct PackFile_FixupTable *) seg, (*e)->type, (*e)->name);
2935         if (fe) {
2936             *e = fe;
2937             return 1;
2938         }
2939     }
2940     return 0;
2941 }
2942
2943 /*
2944
2945 =item C<struct PackFile_FixupEntry *
2946 PackFile_find_fixup_entry(Interp *interpreter, enum_fixup_t type,
2947         char * name)>
2948
2949 I<What does this do?>
2950
2951 =cut
2952
2953 */
2954
2955 struct PackFile_FixupEntry *
2956 PackFile_find_fixup_entry(Interp *interpreter, enum_fixup_t type,
2957         char * name)
2958 {
2959     /* TODO make a hash of all fixups */
2960     struct PackFile_Directory *dir = interpreter->code->base.dir;
2961     struct PackFile_FixupEntry *ep, e;
2962     int found;
2963
2964     /*
2965      * XXX when in eval, the dir is in cur_cs->prev
2966      */
2967     if (interpreter->code->prev)
2968         dir = interpreter->code->prev->base.dir;
2969
2970     e.type = type;
2971     e.name = name;
2972     ep = &e;
2973     found = PackFile_map_segments(interpreter, dir, find_fixup_iter,
2974             (void *) &ep);
2975     return found ? ep : NULL;
2976 }
2977
2978 /*
2979
2980 =back
2981
2982 =head2 PackFile ConstTable Structure Functions
2983
2984 =over 4
2985
2986 =item C<void
2987 PackFile_ConstTable_clear(Interp*, struct PackFile_ConstTable *self)>
2988
2989 Clear the C<PackFile_ConstTable> C<self>.
2990
2991 =cut
2992
2993 */
2994
2995 void
2996 PackFile_ConstTable_clear(Interp* interpreter, struct PackFile_ConstTable *self)
2997 {
2998     opcode_t i;
2999
3000     for (i = 0; i < self->const_count; i++) {
3001         PackFile_Constant_destroy(interpreter, self->constants[i]);
3002         self->constants[i] = NULL;
3003     }
3004
3005     if (self->const_count) {
3006         mem_sys_free(self->constants);
3007     }
3008
3009     self->constants = NULL;
3010     self->const_count = 0;
3011
3012     return;
3013 }
3014
3015 #if EXEC_CAPABLE
3016 struct PackFile_Constant *exec_const_table;
3017 #endif
3018
3019 /*
3020
3021 =item C<opcode_t *
3022 PackFile_ConstTable_unpack(Interp *interpreter,
3023         struct PackFile_Segment *seg,
3024         opcode_t *cursor)>
3025
3026 Unpack a PackFile ConstTable from a block of memory. The format is:
3027
3028   opcode_t const_count
3029   *  constants
3030
3031 Returns cursor if everything is OK, else zero (0).
3032
3033 =cut
3034
3035 */
3036
3037 opcode_t *
3038 PackFile_ConstTable_unpack(Interp *interpreter,
3039         struct PackFile_Segment *seg,
3040         opcode_t *cursor)
3041 {
3042     opcode_t i;
3043     struct PackFile_ConstTable * const self = (struct PackFile_ConstTable *)seg;
3044     struct PackFile * const pf = seg->pf;
3045 #if EXEC_CAPABLE
3046     extern int Parrot_exec_run;
3047 #endif
3048
3049     PackFile_ConstTable_clear(interpreter, self);
3050
3051     self->const_count = PF_fetch_opcode(pf, &cursor);
3052
3053 #if TRACE_PACKFILE
3054     PIO_eprintf(interpreter,
3055             "PackFile_ConstTable_unpack: Unpacking %ld constants\n",
3056             self->const_count);
3057 #endif
3058
3059     if (self->const_count == 0) {
3060         return cursor;
3061     }
3062
3063     self->constants = mem_sys_allocate_zeroed(self->const_count *
3064             sizeof(struct PackFile_Constant *));
3065
3066     if (!self->constants) {
3067         PIO_eprintf(interpreter,
3068                 "PackFile_ConstTable_unpack: Could not allocate "
3069                 "memory for array!\n");
3070         self->const_count = 0;
3071         return 0;
3072     }
3073
3074     for (i = 0; i < self->const_count; i++) {
3075 #if TRACE_PACKFILE
3076         PIO_eprintf(interpreter,
3077                 "PackFile_ConstTable_unpack(): Unpacking constant %ld\n", i);
3078 #endif
3079
3080 #if EXEC_CAPABLE
3081         if (Parrot_exec_run)
3082             self->constants[i] = &exec_const_table[i];
3083         else
3084 #endif
3085             self->constants[i] = PackFile_Constant_new(interpreter);
3086
3087         cursor = PackFile_Constant_unpack(interpreter, self, self->constants[i],
3088                     cursor);
3089     }
3090     return cursor;
3091 }
3092
3093 /*
3094
3095 =item C<static struct PackFile_Segment *
3096 const_new(Interp*, struct PackFile *pf, const char *name, int add)>
3097
3098 Returns a new C<PackFile_ConstTable> segment.
3099
3100 =cut
3101
3102 */
3103
3104 static struct PackFile_Segment *
3105 const_new (Interp* interpreter, struct PackFile *pf, const char *name, int add)
3106 {
3107     struct PackFile_ConstTable *const_table;
3108
3109     const_table = mem_sys_allocate(sizeof(struct PackFile_ConstTable));
3110
3111     const_table->const_count = 0;
3112     const_table->constants = NULL;
3113
3114     return (struct PackFile_Segment *)const_table;
3115 }
3116
3117 /*
3118
3119 =item C<static void
3120 const_destroy(Interp*, struct PackFile_Segment *self)>
3121
3122 Destroys the C<PackFile_ConstTable> C<self>.
3123
3124 =cut
3125
3126 */
3127
3128 static void
3129 const_destroy (Interp* interpreter, struct PackFile_Segment *self)
3130 {
3131     struct PackFile_ConstTable * const ct = (struct PackFile_ConstTable *)self;
3132
3133     PackFile_ConstTable_clear (interpreter, ct);
3134 }
3135
3136 /*
3137
3138 =back
3139
3140 =head2 PackFile Constant Structure Functions
3141
3142 =over 4
3143
3144 =item C<struct PackFile_Constant *
3145 PackFile_Constant_new(Interp*)>
3146
3147 Allocate a new empty PackFile Constant.
3148
3149 This is only here so we can make a new one and then do an unpack.
3150
3151 =cut
3152
3153 */
3154
3155 struct PackFile_Constant *
3156 PackFile_Constant_new(Interp* interpreter)
3157 {
3158     struct PackFile_Constant * const self =
3159         mem_sys_allocate_zeroed(sizeof(struct PackFile_Constant));
3160
3161     self->type = PFC_NONE;
3162
3163     return self;
3164 }
3165
3166 /*
3167
3168 =item C<void
3169 PackFile_Constant_destroy(Interp*, struct PackFile_Constant *self)>
3170
3171 Delete the C<PackFile_Constant> C<self>.
3172
3173 Don't delete C<PMC>s or C<STRING>s, they are destroyed via DOD/GC.
3174
3175 =cut
3176
3177 */
3178
3179 void
3180 PackFile_Constant_destroy(Interp* interpreter, struct PackFile_Constant *self)
3181 {
3182     mem_sys_free(self);
3183 }
3184
3185 /*
3186
3187 =item C<size_t
3188 PackFile_Constant_pack_size(Interp*, struct PackFile_Constant *self)>
3189
3190 Determine the size of the buffer needed in order to pack the PackFile
3191 Constant into a contiguous region of memory.
3192
3193 =cut
3194
3195 */
3196
3197 size_t
3198 PackFile_Constant_pack_size(Interp* interpreter, struct PackFile_Constant *self)
3199 {
3200     size_t packed_size;
3201     PMC *component;
3202     STRING *image;
3203
3204     switch (self->type) {
3205
3206         case PFC_NUMBER:
3207             packed_size = PF_size_number();
3208             break;
3209
3210         case PFC_STRING:
3211             packed_size = PF_size_string(self->u.string);
3212             break;
3213
3214         case PFC_KEY:
3215             packed_size = 1;
3216
3217             for (component = self->u.key; component;
3218                     component = PMC_data(component))
3219                 packed_size += 2;
3220             break;
3221
3222         case PFC_PMC:
3223             component = self->u.key; /* the pmc (Sub, ...) */
3224
3225             /*
3226              * TODO create either
3227              * a) a frozen_size freeze entry or
3228              * b) change packout.c so that component size isn't needed
3229              */
3230             image = Parrot_freeze(interpreter, component);
3231             packed_size = PF_size_string(image);
3232             break;
3233
3234         default:
3235             PIO_eprintf(NULL,
3236                     "Constant_packed_size: Unrecognized type '%c'!\n",
3237                     (char)self->type);
3238             return 0;
3239     }
3240
3241     /* Tack on space for the initial type field */
3242     return packed_size + 1;
3243 }
3244
3245 /*
3246
3247 =item C<opcode_t *
3248 PackFile_Constant_unpack(Interp *interpreter,
3249                          struct PackFile_ConstTable *constt,
3250                          struct PackFile_Constant *self, opcode_t *cursor)>
3251
3252 Unpack a PackFile Constant from a block of memory. The format is:
3253
3254   opcode_t type
3255   *  data
3256
3257 Returns cursor if everything is OK, else zero (0).
3258
3259 =cut
3260
3261 */
3262
3263 opcode_t *
3264 PackFile_Constant_unpack(Interp *interpreter,
3265                          struct PackFile_ConstTable *constt,
3266                          struct PackFile_Constant *self, opcode_t *cursor)
3267 {
3268     struct PackFile * const pf = constt->base.pf;
3269     const opcode_t type = PF_fetch_opcode(pf, &cursor);
3270
3271 /* #define TRACE_PACKFILE 1 */
3272 #if TRACE_PACKFILE
3273     PIO_eprintf(NULL, "PackFile_Constant_unpack(): Type is %ld ('%c')...\n",
3274             type, (char)type);
3275 #endif
3276
3277     switch (type) {
3278     case PFC_NUMBER:
3279         self->u.number = PF_fetch_number(pf, &cursor);
3280         self->type = PFC_NUMBER;
3281         break;
3282
3283     case PFC_STRING:
3284         self->u.string = PF_fetch_string(interpreter, pf, &cursor);
3285         self->type = PFC_STRING;
3286         break;
3287
3288     case PFC_KEY:
3289         cursor = PackFile_Constant_unpack_key(interpreter, constt,
3290                 self, cursor);
3291         break;
3292
3293     case PFC_PMC:
3294         cursor = PackFile_Constant_unpack_pmc(interpreter, constt,
3295                 self, cursor);
3296         break;
3297     default:
3298         PIO_eprintf(NULL,
3299                 "Constant_unpack: Unrecognized type '%c' during unpack!\n",
3300                 (char)type);
3301         return 0;
3302     }
3303     return cursor;
3304 }
3305
3306 /*
3307
3308 =item C<opcode_t *
3309 PackFile_Constant_unpack_pmc(Interp *interpreter,
3310                          struct PackFile_ConstTable *constt,
3311                          struct PackFile_Constant *self,
3312                          opcode_t *cursor)>
3313
3314 Unpack a constant PMC.
3315
3316 =cut
3317
3318 */
3319
3320 opcode_t *
3321 PackFile_Constant_unpack_pmc(Interp *interpreter,
3322                          struct PackFile_ConstTable *constt,
3323                          struct PackFile_Constant *self,
3324                          opcode_t *cursor)
3325 {
3326     struct PackFile * const pf = constt->base.pf;
3327     STRING *image, *_sub;
3328     PMC *pmc;
3329
3330     /*
3331      * thawing the PMC needs the real packfile in place
3332      */
3333     struct PackFile_ByteCode * const cs_save = interpreter->code;
3334     interpreter->code = pf->cur_cs;
3335
3336     image = PF_fetch_string(interpreter, pf, &cursor);
3337     /*
3338      * TODO use thaw_constants
3339      * current issue: a constant Sub with attached properties
3340      *                doesn't DOD mark the properties
3341      * for a constant PMC *all* contents have to be in the constant pools
3342      */
3343     pmc = Parrot_thaw(interpreter, image);
3344     /*
3345      * place item in const_table
3346      */
3347     self->type = PFC_PMC;
3348     self->u.key = pmc;
3349
3350     _sub = const_string(interpreter, "Sub");    /* CONST_STRING */
3351     if (VTABLE_isa(interpreter, pmc, _sub)) {
3352         /*
3353          * finally place the sub into some namespace stash
3354          * XXX place this code in Sub.thaw ?
3355          */
3356         Parrot_store_sub_in_namespace(interpreter, pmc);
3357     }
3358     /*
3359      * restore code
3360      */
3361     interpreter->code = cs_save;
3362     return cursor;
3363 }
3364
3365 /*
3366
3367 =item C<opcode_t *
3368 PackFile_Constant_unpack_key(Interp *interpreter,
3369                              struct PackFile_ConstTable *constt,
3370                              struct PackFile_Constant *self,
3371                              opcode_t *cursor)>
3372
3373 Unpack a PackFile Constant from a block of memory. The format consists
3374 of a sequence of key atoms, each with the following format:
3375
3376   opcode_t type
3377   opcode_t value
3378
3379 Returns cursor if everything is OK, else zero (0).
3380
3381 =cut
3382
3383 */
3384
3385 opcode_t *
3386 PackFile_Constant_unpack_key(Interp *interpreter,
3387                              struct PackFile_ConstTable *constt,
3388                              struct PackFile_Constant *self,
3389                              opcode_t *cursor)
3390 {
3391     PMC *head;
3392     PMC *tail;
3393     opcode_t type, op, slice_bits;
3394     struct PackFile * const pf = constt->base.pf;
3395     int pmc_enum = enum_class_Key;
3396
3397     INTVAL components = (INTVAL)PF_fetch_opcode(pf, &cursor);
3398     head = tail = NULL;
3399
3400     while (components-- > 0) {
3401         type = PF_fetch_opcode(pf, &cursor);
3402         slice_bits = type & PF_VT_SLICE_BITS;
3403         type &= ~PF_VT_SLICE_BITS;
3404         if (!head && slice_bits) {
3405             pmc_enum = enum_class_Slice;
3406         }
3407         if (tail) {
3408             PMC_data(tail)
3409                 = constant_pmc_new_noinit(interpreter, pmc_enum);
3410             tail = PMC_data(tail);
3411         }
3412         else {
3413             head = tail = constant_pmc_new_noinit(interpreter, pmc_enum);
3414         }
3415
3416         VTABLE_init(interpreter, tail);
3417
3418         op = PF_fetch_opcode(pf, &cursor);
3419         switch (type) {
3420         case PARROT_ARG_IC:
3421             key_set_integer(interpreter, tail, op);
3422             break;
3423         case PARROT_ARG_NC:
3424             key_set_number(interpreter, tail, constt->constants[op]->u.number);
3425             break;
3426         case PARROT_ARG_SC:
3427             key_set_string(interpreter, tail, constt->constants[op]->u.string);
3428             break;
3429         case PARROT_ARG_I:
3430             key_set_register(interpreter, tail, op, KEY_integer_FLAG);
3431             break;
3432         case PARROT_ARG_N:
3433             key_set_register(interpreter, tail, op, KEY_number_FLAG);
3434             break;
3435         case PARROT_ARG_S:
3436             key_set_register(interpreter, tail, op, KEY_string_FLAG);
3437             break;
3438         case PARROT_ARG_P:
3439             key_set_register(interpreter, tail, op, KEY_pmc_FLAG);
3440             break;
3441         default:
3442             return 0;
3443         }
3444         if (slice_bits) {
3445             if (slice_bits & PF_VT_START_SLICE)
3446                 PObj_get_FLAGS(tail) |= KEY_start_slice_FLAG;
3447             if (slice_bits & PF_VT_END_SLICE)
3448                 PObj_get_FLAGS(tail) |= KEY_end_slice_FLAG;
3449             if (slice_bits & (PF_VT_START_ZERO | PF_VT_END_INF))
3450                 PObj_get_FLAGS(tail) |= KEY_inf_slice_FLAG;
3451         }
3452     }
3453
3454     self->type = PFC_KEY;
3455     self->u.key = head;
3456
3457     return cursor;
3458 }
3459
3460 /*
3461
3462 =item C<static struct PackFile *
3463 PackFile_append_pbc(Interp *interpreter, const char *filename)>
3464
3465 Read a PBC and append it to the current directory
3466 Fixup sub addresses in newly loaded bytecode and run :load subs.
3467
3468 =cut
3469
3470 */
3471
3472 static struct PackFile *
3473 PackFile_append_pbc(Interp *interpreter, const char *filename)
3474 {
3475     struct PackFile * const pf = Parrot_readbc(interpreter, filename);
3476     if (!pf)
3477         return NULL;
3478     PackFile_add_segment(interpreter, &interpreter->initial_pf->directory,
3479             &pf->directory.base);
3480     do_sub_pragmas(interpreter, pf->cur_cs, PBC_LOADED, NULL);
3481     return pf;
3482 }
3483
3484 /*
3485
3486 =item C<void
3487 Parrot_load_bytecode(Interp *interpreter, STRING *filename)>
3488
3489 Load and append a bytecode, IMC or PASM file into interpreter.
3490
3491 Load some bytecode (PASM, PIR, PBC ...) and append it to the current
3492 directory.
3493
3494 =cut
3495
3496 */
3497
3498 /*
3499  * intermediate hook during changes
3500  */
3501 /* XXX Declare this elsewhere */
3502 void * IMCC_compile_file (Parrot_Interp interp, const char *s);
3503
3504 void
3505 Parrot_load_bytecode(Interp *interpreter, STRING *file_str)
3506 {
3507     char *filename;
3508     STRING *wo_ext, *ext, *pbc, *path;
3509     enum_runtime_ft file_type;
3510     PMC *is_loaded_hash;
3511
3512     parrot_split_path_ext(interpreter, file_str, &wo_ext, &ext);
3513     /* check if wo_ext is loaded */
3514     is_loaded_hash = VTABLE_get_pmc_keyed_int(interpreter,
3515         interpreter->iglobals, IGLOBALS_PBC_LIBS);
3516     if (VTABLE_exists_keyed_str(interpreter, is_loaded_hash, wo_ext))
3517         return;
3518     pbc = const_string(interpreter, "pbc");
3519     if (string_equal(interpreter, ext, pbc) == 0)
3520         file_type = PARROT_RUNTIME_FT_PBC;
3521     else
3522         file_type = PARROT_RUNTIME_FT_SOURCE;
3523
3524     path = Parrot_locate_runtime_file_str(interpreter, file_str, file_type);
3525     if (!path) {
3526         real_exception(interpreter, NULL, E_LibraryNotLoadedError,
3527                 "Couldn't find file '%Ss'", file_str);
3528         return;
3529     }
3530     /* remember wo_ext => full_path mapping */
3531     VTABLE_set_string_keyed_str(interpreter, is_loaded_hash,
3532             wo_ext, path);
3533     filename = string_to_cstring(interpreter, path);
3534     if ( file_type == PARROT_RUNTIME_FT_PBC) {
3535         PackFile_append_pbc(interpreter, filename);
3536     }
3537     else {
3538         STRING *err;
3539         struct PackFile_ByteCode * const cs = IMCC_compile_file_s(interpreter,
3540                 filename, &err);
3541         if (cs) {
3542             do_sub_pragmas(interpreter, cs, PBC_LOADED, NULL);
3543         }
3544         else
3545             real_exception(interpreter, NULL, E_LibraryNotLoadedError,
3546                 "compiler returned NULL ByteCode '%Ss' - %Ss", file_str, err);
3547     }
3548     string_cstring_free(filename);
3549 }
3550
3551 /*
3552
3553 =item C<void
3554 PackFile_fixup_subs(Interp *interpreter, pbc_action_enum_t, PMC *eval)>
3555
3556 Run :load or :immediate subroutines for the current code segment.
3557 If C<eval> is given, set this is the owner of the subroutines.
3558
3559 =cut
3560
3561 */
3562
3563 void
3564 PackFile_fixup_subs(Interp *interpreter, pbc_action_enum_t what, PMC *eval)
3565 {
3566     do_sub_pragmas(interpreter, interpreter->code, what, eval);
3567 }
3568
3569 /*
3570
3571 =back
3572
3573 =head1 HISTORY
3574
3575 Rework by Melvin; new bytecode format, make bytecode portable. (Do
3576 endian conversion and wordsize transforms on the fly.)
3577
3578 leo applied and modified Juergen Boemmels packfile patch giving an
3579 extensible packfile format with directory reworked again, with common
3580 chunks (C<default_*>).
3581
3582 2003.11.21 leo: moved low level item fetch routines to new
3583 F<pf/pf_items.c>
3584
3585 =cut
3586
3587 */
3588
3589
3590 /*
3591  * Local variables:
3592  *   c-file-style: "parrot"
3593  * End:
3594  * vim: expandtab shiftwidth=4:
3595  */