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