src/packfile.c

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