src/pmc_freeze.c

   1 /*
   2 Copyright (C) 2001-2007, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/pmc_freeze.c - Freeze and thaw functionality
   8
   9 =head1 DESCRIPTION
  10
  11 Freeze uses the C<next_for_GC pointer()> to remember seen PMCs. PMCs are
  12 written as IDs (or tags), which are calculated from their arena address.
  13 This PMC number is multiplied by four. The 2 low bits indicate a seen
  14 PMC or a PMC of the same type as the previous one respectively.
  15
  16 Thawing PMCs uses a list with (maximum) size of the amount of PMCs to
  17 keep track of retrieved PMCs.
  18
  19 The individual information of PMCs is frozen/thawed by their vtables.
  20
  21 To avoid recursion, the whole functionality is driven by
  22 C<< pmc->vtable->visit >>, which is called for the first PMC initially.
  23 Container PMCs call a "todo-callback" for all contained PMCs. The
  24 individual action vtable (freeze/thaw) is then called for all todo-PMCs.
  25
  26 In the current implementation C<IMAGE_IO> is a stand-in for some kind of
  27 serializer PMC which will eventually be written. It associates a Parrot
  28 C<STRING> with a vtable.
  29
  30 =cut
  31
  32 */
  33
  34 #include "parrot/parrot.h"
  35
  36 /* default.pmc thawing of properties */
  37 PARROT_API void
  38 Parrot_default_thaw(Interp* , PMC* pmc, visit_info *info);
  39
  40 /* XXX This should be in a header file. */
  41 PARROT_API void
  42 Parrot_default_thawfinish(PARROT_INTERP, PMC* pmc, visit_info *info);
  43
  44
  45 /* HEADERIZER HFILE: include/parrot/pmc_freeze.h */
  46 /* HEADERIZER BEGIN: static */
  47 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  48
  49 static void add_pmc_next_for_GC(SHIM_INTERP,
  50     ARGIN(PMC *pmc),
  51     ARGOUT(visit_info *info))
  52         __attribute__nonnull__(2)
  53         __attribute__nonnull__(3)
  54         FUNC_MODIFIES(*info);
  55
  56 static void add_pmc_todo_list(PARROT_INTERP,
  57     ARGIN_NULLOK(PMC *pmc),
  58     ARGIN(visit_info *info))
  59         __attribute__nonnull__(1)
  60         __attribute__nonnull__(3);
  61
  62 static void cleanup_next_for_GC(PARROT_INTERP)
  63         __attribute__nonnull__(1);
  64
  65 static void cleanup_next_for_GC_pool(ARGIN(Small_Object_Pool *pool))
  66         __attribute__nonnull__(1);
  67
  68 static void create_image(PARROT_INTERP,
  69     ARGIN_NULLOK(PMC *pmc),
  70     ARGMOD(visit_info *info))
  71         __attribute__nonnull__(1)
  72         __attribute__nonnull__(3)
  73         FUNC_MODIFIES(*info);
  74
  75 PARROT_INLINE
  76 static void do_action(PARROT_INTERP,
  77     ARGIN_NULLOK(PMC *pmc),
  78     ARGIN(visit_info *info),
  79     int seen,
  80     UINTVAL id)
  81         __attribute__nonnull__(1)
  82         __attribute__nonnull__(3);
  83
  84 PARROT_INLINE
  85 static void do_thaw(PARROT_INTERP, ARGIN(PMC* pmc), ARGIN(visit_info *info))
  86         __attribute__nonnull__(1)
  87         __attribute__nonnull__(2)
  88         __attribute__nonnull__(3);
  89
  90 PARROT_INLINE
  91 static void freeze_pmc(PARROT_INTERP,
  92     ARGIN_NULLOK(PMC *pmc),
  93     ARGIN(visit_info *info),
  94     int seen,
  95     UINTVAL id)
  96         __attribute__nonnull__(1)
  97         __attribute__nonnull__(3);
  98
  99 static void ft_init(PARROT_INTERP, ARGIN(visit_info *info))
 100         __attribute__nonnull__(1)
 101         __attribute__nonnull__(2);
 102
 103 static UINTVAL id_from_pmc(PARROT_INTERP, ARGIN(PMC* pmc))
 104         __attribute__nonnull__(1)
 105         __attribute__nonnull__(2);
 106
 107 PARROT_INLINE
 108 static int next_for_GC_seen(PARROT_INTERP,
 109     ARGIN_NULLOK(PMC *pmc),
 110     ARGIN(visit_info *info),
 111     ARGOUT(UINTVAL *id))
 112         __attribute__nonnull__(1)
 113         __attribute__nonnull__(3)
 114         __attribute__nonnull__(4)
 115         FUNC_MODIFIES(*id);
 116
 117 static void op_append(PARROT_INTERP,
 118     ARGIN(STRING *s),
 119     opcode_t b,
 120     size_t len)
 121         __attribute__nonnull__(1)
 122         __attribute__nonnull__(2);
 123
 124 PARROT_INLINE
 125 static void op_check_size(PARROT_INTERP, ARGIN(STRING *s), size_t len)
 126         __attribute__nonnull__(1)
 127         __attribute__nonnull__(2);
 128
 129 static void pmc_add_ext(PARROT_INTERP, ARGIN(PMC *pmc))
 130         __attribute__nonnull__(1)
 131         __attribute__nonnull__(2);
 132
 133 static void push_ascii_integer(PARROT_INTERP, ARGIN(IMAGE_IO *io), INTVAL v)
 134         __attribute__nonnull__(1)
 135         __attribute__nonnull__(2);
 136
 137 static void push_ascii_number(PARROT_INTERP,
 138     ARGIN(const IMAGE_IO *io),
 139     FLOATVAL v)
 140         __attribute__nonnull__(1)
 141         __attribute__nonnull__(2);
 142
 143 static void push_ascii_pmc(PARROT_INTERP,
 144     ARGIN(IMAGE_IO *io),
 145     ARGIN(const PMC* v))
 146         __attribute__nonnull__(1)
 147         __attribute__nonnull__(2)
 148         __attribute__nonnull__(3);
 149
 150 static void push_ascii_string(PARROT_INTERP,
 151     ARGIN(IMAGE_IO *io),
 152     ARGIN(const STRING *s))
 153         __attribute__nonnull__(1)
 154         __attribute__nonnull__(2)
 155         __attribute__nonnull__(3);
 156
 157 static void push_opcode_integer(PARROT_INTERP,
 158     ARGIN(IMAGE_IO *io),
 159     INTVAL v)
 160         __attribute__nonnull__(1)
 161         __attribute__nonnull__(2);
 162
 163 static void push_opcode_number(PARROT_INTERP,
 164     ARGIN(IMAGE_IO *io),
 165     FLOATVAL v)
 166         __attribute__nonnull__(1)
 167         __attribute__nonnull__(2);
 168
 169 static void push_opcode_pmc(PARROT_INTERP,
 170     ARGIN(IMAGE_IO *io),
 171     ARGIN(PMC* v))
 172         __attribute__nonnull__(1)
 173         __attribute__nonnull__(2)
 174         __attribute__nonnull__(3);
 175
 176 static void push_opcode_string(PARROT_INTERP,
 177     ARGIN(IMAGE_IO *io),
 178     ARGIN(STRING *v))
 179         __attribute__nonnull__(1)
 180         __attribute__nonnull__(2)
 181         __attribute__nonnull__(3);
 182
 183 PARROT_WARN_UNUSED_RESULT
 184 PARROT_CAN_RETURN_NULL
 185 static PMC* run_thaw(PARROT_INTERP,
 186     ARGIN(STRING* image),
 187     visit_enum_type what)
 188         __attribute__nonnull__(1)
 189         __attribute__nonnull__(2);
 190
 191 static INTVAL shift_ascii_integer(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 192         __attribute__nonnull__(2);
 193
 194 static FLOATVAL shift_ascii_number(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 195         __attribute__nonnull__(2);
 196
 197 PARROT_WARN_UNUSED_RESULT
 198 PARROT_CAN_RETURN_NULL
 199 static PMC* shift_ascii_pmc(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 200         __attribute__nonnull__(2);
 201
 202 PARROT_WARN_UNUSED_RESULT
 203 PARROT_CAN_RETURN_NULL
 204 static STRING* shift_ascii_string(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 205         __attribute__nonnull__(1)
 206         __attribute__nonnull__(2);
 207
 208 static INTVAL shift_opcode_integer(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 209         __attribute__nonnull__(2);
 210
 211 static FLOATVAL shift_opcode_number(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 212         __attribute__nonnull__(2);
 213
 214 PARROT_WARN_UNUSED_RESULT
 215 PARROT_CAN_RETURN_NULL
 216 static PMC* shift_opcode_pmc(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 217         __attribute__nonnull__(1)
 218         __attribute__nonnull__(2);
 219
 220 PARROT_WARN_UNUSED_RESULT
 221 PARROT_CANNOT_RETURN_NULL
 222 static STRING* shift_opcode_string(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 223         __attribute__nonnull__(1)
 224         __attribute__nonnull__(2);
 225
 226 static void str_append(PARROT_INTERP,
 227     ARGMOD(STRING *s),
 228     ARGIN(const void *b),
 229     size_t len)
 230         __attribute__nonnull__(1)
 231         __attribute__nonnull__(2)
 232         __attribute__nonnull__(3)
 233         FUNC_MODIFIES(*s);
 234
 235 PARROT_INLINE
 236 PARROT_CANNOT_RETURN_NULL
 237 static PMC* thaw_create_pmc(PARROT_INTERP,
 238     ARGIN(const visit_info *info),
 239     INTVAL type)
 240         __attribute__nonnull__(1)
 241         __attribute__nonnull__(2);
 242
 243 PARROT_INLINE
 244 static int thaw_pmc(PARROT_INTERP,
 245     ARGMOD(visit_info *info),
 246     ARGOUT(UINTVAL *id),
 247     ARGOUT(INTVAL *type))
 248         __attribute__nonnull__(1)
 249         __attribute__nonnull__(2)
 250         __attribute__nonnull__(3)
 251         __attribute__nonnull__(4)
 252         FUNC_MODIFIES(*info)
 253         FUNC_MODIFIES(*id)
 254         FUNC_MODIFIES(*type);
 255
 256 static void todo_list_init(PARROT_INTERP, ARGOUT(visit_info *info))
 257         __attribute__nonnull__(1)
 258         __attribute__nonnull__(2)
 259         FUNC_MODIFIES(*info);
 260
 261 PARROT_INLINE
 262 static int todo_list_seen(PARROT_INTERP,
 263     ARGIN(PMC *pmc),
 264     ARGMOD(visit_info *info),
 265     ARGOUT(UINTVAL *id))
 266         __attribute__nonnull__(1)
 267         __attribute__nonnull__(2)
 268         __attribute__nonnull__(3)
 269         __attribute__nonnull__(4)
 270         FUNC_MODIFIES(*info)
 271         FUNC_MODIFIES(*id);
 272
 273 static void visit_loop_next_for_GC(PARROT_INTERP,
 274     ARGIN(PMC *current),
 275     ARGIN(visit_info *info))
 276         __attribute__nonnull__(1)
 277         __attribute__nonnull__(2)
 278         __attribute__nonnull__(3);
 279
 280 static void visit_loop_todo_list(PARROT_INTERP,
 281     ARGIN_NULLOK(PMC *current),
 282     ARGIN(visit_info *info))
 283         __attribute__nonnull__(1)
 284         __attribute__nonnull__(3);
 285
 286 static void visit_next_for_GC(PARROT_INTERP,
 287     ARGIN(PMC* pmc),
 288     ARGIN(visit_info* info))
 289         __attribute__nonnull__(1)
 290         __attribute__nonnull__(2)
 291         __attribute__nonnull__(3);
 292
 293 static void visit_todo_list(PARROT_INTERP,
 294     ARGIN(PMC* pmc),
 295     ARGIN(visit_info* info))
 296         __attribute__nonnull__(1)
 297         __attribute__nonnull__(2)
 298         __attribute__nonnull__(3);
 299
 300 static void visit_todo_list_thaw(PARROT_INTERP,
 301     ARGIN(PMC* old),
 302     ARGIN(visit_info* info))
 303         __attribute__nonnull__(1)
 304         __attribute__nonnull__(2)
 305         __attribute__nonnull__(3);
 306
 307 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
 308 /* HEADERIZER END: static */
 309
 310 /*
 311  * define this to 1 for testing
 312  */
 313 #ifndef FREEZE_ASCII
 314 #  define FREEZE_ASCII 0
 315 #endif
 316
 317 /*
 318  * normal freeze can use next_for_GC ptrs or a seen hash
 319  */
 320 #define FREEZE_USE_NEXT_FOR_GC 0
 321
 322 /*
 323  * when thawing a string longer then this size, we first do a
 324  * DOD run and then block DOD/GC - the system can't give us more headers
 325  */
 326 #define THAW_BLOCK_DOD_SIZE 100000
 327
 328 /*
 329  * preallocate freeze image for aggregates with this estimation
 330  */
 331 #if FREEZE_ASCII
 332 #  define FREEZE_BYTES_PER_ITEM 17
 333 #else
 334 #  define FREEZE_BYTES_PER_ITEM 9
 335 #endif
 336
 337 /*
 338
 339 =head2 Image Stream Functions
 340
 341 =over 4
 342
 343 =item C<static void str_append>
 344
 345 Appends C<len> bytes from buffer C<*b> to string C<*s>.
 346
 347 Plain ascii - for testing only:
 348
 349 For speed reasons we mess around with the string buffers directly.
 350
 351 No encoding of strings, no transcoding.
 352
 353 =cut
 354
 355 */
 356
 357 static void
 358 str_append(PARROT_INTERP, ARGMOD(STRING *s), ARGIN(const void *b), size_t len)
 359 {
 360     const size_t used = s->bufused;
 361     const int need_free = (int)PObj_buflen(s) - used - len;
 362     /*
 363      * grow by factor 1.5 or such
 364      */
 365     if (need_free <= 16) {
 366         size_t new_size = (size_t) (PObj_buflen(s) * 1.5);
 367         if (new_size < PObj_buflen(s) - need_free + 512)
 368             new_size = PObj_buflen(s) - need_free + 512;
 369         Parrot_reallocate_string(interp, s, new_size);
 370         PARROT_ASSERT(PObj_buflen(s) - used - len >= 15);
 371     }
 372     mem_sys_memcopy((void *)((ptrcast_t)s->strstart + used), b, len);
 373     s->bufused += len;
 374     s->strlen += len;
 375 }
 376
 377 /*
 378
 379 =item C<static void push_ascii_integer>
 380
 381 Pushes an ASCII version of the integer C<v> onto the end of the C<*io>
 382 "stream".
 383
 384 =cut
 385
 386 */
 387
 388 static void
 389 push_ascii_integer(PARROT_INTERP, ARGIN(IMAGE_IO *io), INTVAL v)
 390 {
 391     char buffer[20];
 392     const size_t len = snprintf(buffer, sizeof (buffer), "%d ", (int) v);
 393     str_append(interp, io->image, buffer, len);
 394 }
 395
 396 /*
 397
 398 =item C<static void push_ascii_number>
 399
 400 Pushes an ASCII version of the number C<v> onto the end of the C<*io>
 401 "stream".
 402
 403 =cut
 404
 405 */
 406
 407 static void
 408 push_ascii_number(PARROT_INTERP, ARGIN(const IMAGE_IO *io), FLOATVAL v)
 409 {
 410     char buffer[40];
 411     const size_t len = snprintf(buffer, sizeof (buffer), "%g ", (double) v);
 412     str_append(interp, io->image, buffer, len);
 413 }
 414
 415 /*
 416
 417 =item C<static void push_ascii_string>
 418
 419 Pushes an ASCII version of the string C<*s> onto the end of the C<*io>
 420 "stream".
 421
 422 For testing only - no encodings and such.
 423
 424 XXX no string delimiters - so no space allowed.
 425
 426 =cut
 427
 428 */
 429
 430 static void
 431 push_ascii_string(PARROT_INTERP, ARGIN(IMAGE_IO *io), ARGIN(const STRING *s))
 432 {
 433     const UINTVAL length = string_length(interp, s);
 434     char * const buffer = (char *)malloc(4*length); /* XXX Why 4?  What does that mean? */
 435     char *cursor = buffer;
 436     UINTVAL idx = 0;
 437
 438     /* temporary--write out in UTF-8 */
 439     for (idx = 0; idx < length; ++idx) {
 440         *cursor++ = (unsigned char)string_index(interp, s, idx);
 441     }
 442
 443     str_append(interp, io->image, buffer, cursor - buffer);
 444     str_append(interp, io->image, " ", 1);
 445
 446     mem_sys_free(buffer);
 447 }
 448
 449 /*
 450
 451 =item C<static void push_ascii_pmc>
 452
 453 Pushes an ASCII version of the PMC C<*v> onto the end of the C<*io>
 454 "stream".
 455
 456 =cut
 457
 458 */
 459
 460 static void
 461 push_ascii_pmc(PARROT_INTERP, ARGIN(IMAGE_IO *io), ARGIN(const PMC* v))
 462 {
 463     char buffer[20];
 464     const size_t len = snprintf(buffer, sizeof (buffer), "%p ", (const void *)v);
 465     str_append(interp, io->image, buffer, len);
 466 }
 467
 468 /*
 469
 470 =item C<static INTVAL shift_ascii_integer>
 471
 472 Removes and returns an integer from the start of the C<*io> "stream".
 473
 474 =cut
 475
 476 */
 477
 478 static INTVAL
 479 shift_ascii_integer(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 480 {
 481     char * const start = (char*)io->image->strstart;
 482     char *p = start;
 483     const INTVAL i = strtoul(p, &p, 10);
 484
 485     ++p;
 486     PARROT_ASSERT(p <= start + io->image->bufused);
 487     io->image->strstart = p;
 488     io->image->bufused -= (p - start);
 489     PARROT_ASSERT((int)io->image->bufused >= 0);
 490     return i;
 491 }
 492
 493 /*
 494
 495 =item C<static FLOATVAL shift_ascii_number>
 496
 497 Removes and returns an number from the start of the C<*io> "stream".
 498
 499 =cut
 500
 501 */
 502
 503 static FLOATVAL
 504 shift_ascii_number(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 505 {
 506     char * const start = (char*)io->image->strstart;
 507     char *p = start;
 508     const FLOATVAL f = (FLOATVAL) strtod(p, &p);
 509
 510     ++p;
 511     PARROT_ASSERT(p <= start + io->image->bufused);
 512     io->image->strstart = p;
 513     io->image->bufused -= (p - start);
 514     PARROT_ASSERT((int)io->image->bufused >= 0);
 515     return f;
 516 }
 517
 518 /*
 519
 520 =item C<static STRING* shift_ascii_string>
 521
 522 Removes and returns an string from the start of the C<*io> "stream".
 523
 524 =cut
 525
 526 */
 527
 528 PARROT_WARN_UNUSED_RESULT
 529 PARROT_CAN_RETURN_NULL
 530 static STRING*
 531 shift_ascii_string(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 532 {
 533     STRING *s;
 534
 535     char * const start = (char*)io->image->strstart;
 536     char *p = start;
 537
 538     while (*p != ' ')
 539         ++p;
 540     ++p;
 541     PARROT_ASSERT(p <= start + io->image->bufused);
 542     io->image->strstart = p;
 543     io->image->bufused -= (p - start);
 544     PARROT_ASSERT((int)io->image->bufused >= 0);
 545     s = string_make(interp, start, p - start - 1, "iso-8859-1", 0);
 546 /*    s = string_make(interp, start, p - start - 1, "UTF-8", 0); */
 547     return s;
 548 }
 549
 550 /*
 551
 552 =item C<static PMC* shift_ascii_pmc>
 553
 554 Removes and returns a PMC from the start of the C<*io> "stream".
 555
 556 =cut
 557
 558 */
 559
 560 PARROT_WARN_UNUSED_RESULT
 561 PARROT_CAN_RETURN_NULL
 562 static PMC*
 563 shift_ascii_pmc(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 564 {
 565     char * const start = (char*)io->image->strstart;
 566     char *p = start;
 567     const unsigned long i = strtoul(p, &p, 16);
 568     ++p;
 569     PARROT_ASSERT(p <= start + io->image->bufused);
 570     io->image->strstart = p;
 571     io->image->bufused -= (p - start);
 572     PARROT_ASSERT((int)io->image->bufused >= 0);
 573     return (PMC*) i;
 574 }
 575
 576 /*
 577
 578 =back
 579
 580 =head2 C<opcode_t> IO Functions
 581
 582 =over 4
 583
 584 =item C<static void op_check_size>
 585
 586 Checks the size of the "stream" buffer to see if it can accommodate
 587 C<len> more bytes. If not then the buffer is expanded.
 588
 589 =cut
 590
 591 */
 592
 593 PARROT_INLINE
 594 static void
 595 op_check_size(PARROT_INTERP, ARGIN(STRING *s), size_t len)
 596 {
 597     const size_t used = s->bufused;
 598     const int need_free = (int)PObj_buflen(s) - used - len;
 599     /*
 600      * grow by factor 1.5 or such
 601      */
 602     if (need_free <= 16) {
 603         size_t new_size = (size_t) (PObj_buflen(s) * 1.5);
 604         if (new_size < PObj_buflen(s) - need_free + 512)
 605             new_size = PObj_buflen(s) - need_free + 512;
 606         Parrot_reallocate_string(interp, s, new_size);
 607         PARROT_ASSERT(PObj_buflen(s) - used - len >= 15);
 608     }
 609 #ifndef DISABLE_GC_DEBUG
 610     Parrot_go_collect(interp);
 611 #endif
 612 }
 613
 614 /*
 615
 616 =item C<static void op_append>
 617
 618 Appends the opcode C<b> to the string C<*s>.
 619
 620 =cut
 621
 622 */
 623
 624 static void
 625 op_append(PARROT_INTERP, ARGIN(STRING *s), opcode_t b, size_t len)
 626 {
 627     op_check_size(interp, s, len);
 628     *((opcode_t *)((ptrcast_t)s->strstart + s->bufused)) = b;
 629     s->bufused += len;
 630     s->strlen += len;
 631 }
 632
 633 /*
 634
 635 =item C<static void push_opcode_integer>
 636
 637 Pushes the integer C<v> onto the end of the C<*io> "stream".
 638
 639 XXX assumes sizeof (opcode_t) == sizeof (INTVAL).
 640
 641 =cut
 642
 643 */
 644
 645 static void
 646 push_opcode_integer(PARROT_INTERP, ARGIN(IMAGE_IO *io), INTVAL v)
 647 {
 648     PARROT_ASSERT(sizeof (opcode_t) == sizeof (INTVAL));
 649     op_append(interp, io->image, (opcode_t)v, sizeof (opcode_t));
 650 }
 651
 652 /*
 653
 654 =item C<static void push_opcode_number>
 655
 656 Pushes the number C<v> onto the end of the C<*io> "stream".
 657
 658 =cut
 659
 660 */
 661
 662 static void
 663 push_opcode_number(PARROT_INTERP, ARGIN(IMAGE_IO *io), FLOATVAL v)
 664 {
 665     const size_t   len  = PF_size_number() * sizeof (opcode_t);
 666     STRING * const s    = io->image;
 667     const size_t   used = s->bufused;
 668     opcode_t      *ignored;
 669
 670     op_check_size(interp, s, len);
 671     ignored = PF_store_number((opcode_t *)((ptrcast_t)s->strstart + used), &v);
 672     UNUSED(ignored);
 673
 674     s->bufused += len;
 675     s->strlen  += len;
 676 }
 677
 678 /*
 679
 680 =item C<static void push_opcode_string>
 681
 682 Pushes the string C<*v> onto the end of the C<*io> "stream".
 683
 684 =cut
 685
 686 */
 687
 688 static void
 689 push_opcode_string(PARROT_INTERP, ARGIN(IMAGE_IO *io), ARGIN(STRING *v))
 690 {
 691     const size_t len = PF_size_string(v) * sizeof (opcode_t);
 692     STRING * const s = io->image;
 693     const size_t used = s->bufused;
 694     opcode_t      *ignored;
 695
 696     op_check_size(interp, s, len);
 697     ignored = PF_store_string((opcode_t *)((ptrcast_t)s->strstart + used), v);
 698     UNUSED(ignored);
 699
 700     s->bufused += len;
 701     s->strlen += len;
 702 }
 703
 704 /*
 705
 706 =item C<static void push_opcode_pmc>
 707
 708 Pushes the PMC C<*v> onto the end of the C<*io> "stream".
 709
 710 =cut
 711
 712 */
 713
 714 static void
 715 push_opcode_pmc(PARROT_INTERP, ARGIN(IMAGE_IO *io), ARGIN(PMC* v))
 716 {
 717     op_append(interp, io->image, (opcode_t)v, sizeof (opcode_t));
 718 }
 719
 720 /*
 721
 722 =item C<static INTVAL shift_opcode_integer>
 723
 724 Removes and returns an integer from the start of the C<*io> "stream".
 725
 726 TODO - The shift functions aren't portable yet. We need to have a
 727 packfile header for wordsize and endianess.
 728
 729 =cut
 730
 731 */
 732
 733 static INTVAL
 734 shift_opcode_integer(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 735 {
 736     const char * const   start  = (char *)io->image->strstart;
 737     char               **opcode = &io->image->strstart;
 738     const INTVAL i              = PF_fetch_integer(io->pf,
 739                                     (const opcode_t **)opcode);
 740
 741     io->image->bufused -= ((char *)io->image->strstart - start);
 742     PARROT_ASSERT((int)io->image->bufused >= 0);
 743
 744     return i;
 745 }
 746
 747 /*
 748
 749 =item C<static PMC* shift_opcode_pmc>
 750
 751 Removes and returns an PMC from the start of the C<*io> "stream".
 752
 753 Note that this actually reads a PMC id, not a PMC.
 754
 755 =cut
 756
 757 */
 758
 759 PARROT_WARN_UNUSED_RESULT
 760 PARROT_CAN_RETURN_NULL
 761 static PMC*
 762 shift_opcode_pmc(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 763 {
 764     INTVAL i = shift_opcode_integer(interp, io);
 765     return (PMC *)i;
 766 }
 767
 768 /*
 769
 770 =item C<static FLOATVAL shift_opcode_number>
 771
 772 Removes and returns an number from the start of the C<*io> "stream".
 773
 774 =cut
 775
 776 */
 777
 778 static FLOATVAL
 779 shift_opcode_number(SHIM_INTERP, ARGIN(IMAGE_IO *io))
 780 {
 781     const char * const   start  = (const char *)io->image->strstart;
 782     char               **opcode = &io->image->strstart;
 783     const FLOATVAL       f      = PF_fetch_number(io->pf,
 784                                     (const opcode_t **)opcode);
 785
 786     io->image->bufused -= ((char *)io->image->strstart - start);
 787     PARROT_ASSERT((int)io->image->bufused >= 0);
 788
 789     return f;
 790 }
 791
 792 /*
 793
 794 =item C<static STRING* shift_opcode_string>
 795
 796 Removes and returns a string from the start of the C<*io> "stream".
 797
 798 =cut
 799
 800 */
 801
 802 PARROT_WARN_UNUSED_RESULT
 803 PARROT_CANNOT_RETURN_NULL
 804 static STRING*
 805 shift_opcode_string(PARROT_INTERP, ARGIN(IMAGE_IO *io))
 806 {
 807     char * const   start  = (char*)io->image->strstart;
 808     char         **opcode = &io->image->strstart;
 809     STRING * const s      = PF_fetch_string(interp, io->pf,
 810                                 (const opcode_t **)opcode);
 811
 812     io->image->bufused -= ((char *)io->image->strstart - start);
 813     PARROT_ASSERT((int)io->image->bufused >= 0);
 814
 815     return s;
 816 }
 817
 818 /*
 819
 820 =back
 821
 822 =head2 Helper Functions
 823
 824 =over 4
 825
 826 =item C<static void pmc_add_ext>
 827
 828 Adds a C<PMC_EXT> to C<*pmc>.
 829
 830 =cut
 831
 832 */
 833
 834 static void
 835 pmc_add_ext(PARROT_INTERP, ARGIN(PMC *pmc))
 836 {
 837     if (pmc->vtable->flags & VTABLE_PMC_NEEDS_EXT)
 838         add_pmc_ext(interp, pmc);
 839 }
 840
 841 /*
 842
 843 =item C<static void cleanup_next_for_GC_pool>
 844
 845 Sets all the C<next_for_GC> pointers to C<NULL>.
 846
 847 =cut
 848
 849 */
 850
 851 static void
 852 cleanup_next_for_GC_pool(ARGIN(Small_Object_Pool *pool))
 853 {
 854     Small_Object_Arena *arena;
 855
 856     for (arena = pool->last_Arena; arena; arena = arena->prev) {
 857         PMC *p = (PMC *)arena->start_objects;
 858         UINTVAL i;
 859
 860         for (i = 0; i < arena->used; i++) {
 861             if (!PObj_on_free_list_TEST(p)) {
 862                 if (p->pmc_ext)
 863                     PMC_next_for_GC(p) = PMCNULL;
 864             }
 865             p++;
 866         }
 867     }
 868 }
 869
 870 /*
 871
 872 =item C<static void cleanup_next_for_GC>
 873
 874 Cleans up the C<next_for_GC> pointers.
 875
 876 =cut
 877
 878 */
 879
 880 static void
 881 cleanup_next_for_GC(PARROT_INTERP)
 882 {
 883     cleanup_next_for_GC_pool(interp->arena_base->pmc_pool);
 884     cleanup_next_for_GC_pool(interp->arena_base->constant_pmc_pool);
 885 }
 886
 887 /*
 888  * this function setup stuff may be replaced by a real PMC
 889  * in the future
 890  * TODO add read/write header functions, e.g. vtable->init_pmc
 891  */
 892
 893 #if FREEZE_ASCII
 894 static image_funcs ascii_funcs = {
 895     push_ascii_integer,
 896     push_ascii_pmc,
 897     push_ascii_string,
 898     push_ascii_number,
 899     shift_ascii_integer,
 900     shift_ascii_pmc,
 901     shift_ascii_string,
 902     shift_ascii_number
 903 };
 904 #else
 905 static image_funcs opcode_funcs = {
 906     push_opcode_integer,
 907     push_opcode_pmc,
 908     push_opcode_string,
 909     push_opcode_number,
 910     shift_opcode_integer,
 911     shift_opcode_pmc,
 912     shift_opcode_string,
 913     shift_opcode_number
 914 };
 915 #endif
 916
 917 /*
 918
 919 =item C<static void ft_init>
 920
 921 Initializes the freeze/thaw subsystem.
 922
 923 =cut
 924
 925 */
 926
 927 static void
 928 ft_init(PARROT_INTERP, ARGIN(visit_info *info))
 929 {
 930     STRING *s = info->image;
 931     PackFile *pf;
 932
 933     /* We want to store a 16-byte aligned header, but the actual
 934      * header may be shorter. */
 935     const unsigned int header_length = PACKFILE_HEADER_BYTES +
 936         (PACKFILE_HEADER_BYTES % 16 ?
 937          16 - PACKFILE_HEADER_BYTES % 16 : 0);
 938
 939     info->image_io = mem_allocate_typed(IMAGE_IO);
 940     info->image_io->image = s = info->image;
 941 #if FREEZE_ASCII
 942     info->image_io->vtable = &ascii_funcs;
 943 #else
 944     info->image_io->vtable = &opcode_funcs;
 945 #endif
 946     pf = info->image_io->pf = PackFile_new(interp, 0);
 947     if (info->what == VISIT_FREEZE_NORMAL ||
 948         info->what == VISIT_FREEZE_AT_DESTRUCT) {
 949
 950         op_check_size(interp, s, header_length);
 951         mem_sys_memcopy(s->strstart, pf->header, PACKFILE_HEADER_BYTES);
 952         s->bufused += header_length;
 953         s->strlen += header_length;
 954     }
 955     else {
 956         if (string_length(interp, s) < header_length) {
 957             real_exception(interp, NULL, E_IOError,
 958                     "bad string to thaw");
 959         }
 960         mem_sys_memcopy(pf->header, s->strstart, PACKFILE_HEADER_BYTES);
 961         PackFile_assign_transforms(pf);
 962         s->bufused -= header_length;
 963         LVALUE_CAST(char *, s->strstart) += header_length;
 964     }
 965
 966     info->last_type = -1;
 967     info->id_list = pmc_new(interp, enum_class_Array);
 968     info->id = 0;
 969     info->extra_flags = EXTRA_IS_NULL;
 970     info->container = NULL;
 971 }
 972
 973 /*
 974
 975 =item C<static void todo_list_init>
 976
 977 Initializes the C<*info> lists.
 978
 979 =cut
 980
 981 */
 982
 983 static void
 984 todo_list_init(PARROT_INTERP, ARGOUT(visit_info *info))
 985 {
 986     info->visit_pmc_now = visit_todo_list;
 987     info->visit_pmc_later = add_pmc_todo_list;
 988     /* we must use PMCs here, so that they get marked properly */
 989     info->todo = pmc_new(interp, enum_class_Array);
 990     info->seen = Parrot_new_INTVAL_hash(interp, 0);
 991
 992     ft_init(interp, info);
 993 }
 994
 995
 996 /*
 997
 998 =item C<static void freeze_pmc>
 999
1000 Freeze PMC, setting type, seen, and "same-as-last" indicators as
1001 appropriate.
1002
1003 =cut
1004
1005 */
1006
1007 PARROT_INLINE
1008 static void
1009 freeze_pmc(PARROT_INTERP, ARGIN_NULLOK(PMC *pmc), ARGIN(visit_info *info),
1010         int seen, UINTVAL id)
1011 {
1012     IMAGE_IO * const io = info->image_io;
1013     INTVAL type;
1014
1015     if (PMC_IS_NULL(pmc)) {
1016         /* NULL + seen bit */
1017         VTABLE_push_pmc(interp, io, (PMC*) 1);
1018         return;
1019     }
1020     type = pmc->vtable->base_type;
1021
1022     if (PObj_is_object_TEST(pmc))
1023         type = enum_class_Object;
1024     if (seen) {
1025         if (info->extra_flags) {
1026             id |= 3;
1027             VTABLE_push_pmc(interp, io, (PMC*)id);
1028             VTABLE_push_integer(interp, io, info->extra_flags);
1029             return;
1030         }
1031         id |= 1;         /* mark bit 0 if this PMC is known */
1032     }
1033     else if (type == info->last_type) {
1034         id |= 2;         /* mark bit 1 and don't write type */
1035     }
1036     VTABLE_push_pmc(interp, io, (PMC*)id);
1037     if (! (id & 3)) {    /* else write type */
1038         VTABLE_push_integer(interp, io, type);
1039         info->last_type = type;
1040     }
1041 }
1042
1043 /*
1044
1045 =item C<static int thaw_pmc>
1046
1047 Freeze and thaw a PMC (id).
1048
1049 For example, the ASCII representation of the C<Array>
1050
1051     P0 = [P1=666, P2=777, P0]
1052
1053 may look like this:
1054
1055     0xdf4 30 3 0xdf8 33 666 0xdf2 777 0xdf5
1056
1057 where 30 is C<class_enum_Array>, 33 is C<class_enum_Integer>, the
1058 type of the second C<Integer> is suppressed, the repeated P0 has bit 0
1059 set.
1060
1061 =cut
1062
1063 */
1064
1065 PARROT_INLINE
1066 static int
1067 thaw_pmc(PARROT_INTERP, ARGMOD(visit_info *info),
1068         ARGOUT(UINTVAL *id), ARGOUT(INTVAL *type))
1069 {
1070     PMC *n;
1071     IMAGE_IO * const io = info->image_io;
1072     int seen = 0;
1073
1074     info->extra_flags = EXTRA_IS_NULL;
1075     n = VTABLE_shift_pmc(interp, io);
1076     if (((UINTVAL) n & 3) == 3) {
1077         /* pmc has extra data */
1078         info->extra_flags = VTABLE_shift_integer(interp, io);
1079     }
1080     else if ((UINTVAL) n & 1) {     /* seen PMCs have bit 0 set */
1081         seen = 1;
1082     }
1083     else if ((UINTVAL) n & 2) { /* prev PMC was same type */
1084         *type = info->last_type;
1085     }
1086     else {                       /* type follows */
1087         *type = VTABLE_shift_integer(interp, io);
1088         info->last_type = *type;
1089         if (*type <= 0)
1090             real_exception(interp, NULL, 1, "Unknown PMC type to thaw %d", (int) *type);
1091         if (*type >= interp->n_vtable_max ||
1092             !interp->vtables[*type]) {
1093             /* that ought to be a class */
1094             *type = enum_class_Class;
1095         }
1096     }
1097     *id = (UINTVAL) n;
1098     return seen;
1099 }
1100
1101 /*
1102
1103 =item C<static void do_action>
1104
1105 Called from C<visit_next_for_GC()> and C<visit_todo_list()> to perform
1106 the action specified in C<< info->what >>.
1107
1108 Currently only C<VISIT_FREEZE_NORMAL> is implemented.
1109
1110 =cut
1111
1112 */
1113
1114 PARROT_INLINE
1115 static void
1116 do_action(PARROT_INTERP, ARGIN_NULLOK(PMC *pmc), ARGIN(visit_info *info),
1117         int seen, UINTVAL id)
1118 {
1119     switch (info->what) {
1120         case VISIT_FREEZE_AT_DESTRUCT:
1121         case VISIT_FREEZE_NORMAL:
1122             freeze_pmc(interp, pmc, info, seen, id);
1123             if (pmc)
1124                 info->visit_action = pmc->vtable->freeze;
1125             break;
1126         default:
1127             real_exception(interp, NULL, 1, "Illegal action %ld", (long)info->what);
1128     }
1129 }
1130
1131 /*
1132
1133 =item C<static PMC* thaw_create_pmc>
1134
1135 Called from C<do_thaw()> to attach the vtable etc. to C<*pmc>.
1136
1137 =cut
1138
1139 */
1140
1141 PARROT_INLINE
1142 PARROT_CANNOT_RETURN_NULL
1143 static PMC*
1144 thaw_create_pmc(PARROT_INTERP, ARGIN(const visit_info *info),
1145         INTVAL type)
1146 {
1147     PMC *pmc;
1148     switch (info->what) {
1149         case VISIT_THAW_NORMAL:
1150             pmc = pmc_new_noinit(interp, type);
1151             break;
1152         case VISIT_THAW_CONSTANTS:
1153             pmc = constant_pmc_new_noinit(interp, type);
1154             break;
1155         default:
1156             real_exception(interp, NULL, 1, "Illegal visit_next type");
1157     }
1158     return pmc;
1159 }
1160
1161 /*
1162
1163 =item C<static void do_thaw>
1164
1165 Called by C<visit_todo_list_thaw()> to thaw and return a PMC.
1166
1167 C<seen> is false if this is the first time the PMC has been encountered.
1168
1169 =cut
1170
1171 */
1172
1173 PARROT_INLINE
1174 static void
1175 do_thaw(PARROT_INTERP, ARGIN(PMC* pmc), ARGIN(visit_info *info))
1176 {
1177     UINTVAL id;
1178     INTVAL type;
1179     PMC ** pos;
1180     int must_have_seen;
1181     type = 0; /* it's set below, avoid compiler warning. */
1182     must_have_seen = thaw_pmc(interp, info, &id, &type);
1183
1184     id >>= 2;
1185
1186     if (!id) {
1187         /* got a NULL PMC */
1188         pmc = PMCNULL;
1189         if (!info->thaw_result)
1190             info->thaw_result = pmc;
1191         else
1192             *info->thaw_ptr = pmc;
1193         return;
1194     }
1195
1196     pos = (PMC **)list_get(interp, (List *)PMC_data(info->id_list), id, enum_type_PMC);
1197     if (pos == (void*)-1)
1198         pos = NULL;
1199     else if (pos) {
1200         pmc = *(PMC**)pos;
1201         if (!pmc)
1202             pos = NULL;
1203     }
1204     if (pos) {
1205         if (info->extra_flags == EXTRA_IS_PROP_HASH) {
1206             Parrot_default_thaw(interp, pmc, info);
1207             return;
1208         }
1209         /* else maybe VTABLE_thaw ... but there is no other extra stuff */
1210
1211 #if FREEZE_USE_NEXT_FOR_GC
1212         /*
1213          * the next_for_GC method doesn't keep track of repeated scalars
1214          * and such, as these are lacking the next_for_GC pointer, so
1215          * these are just duplicated with their data.
1216          * But we track these when thawing, so that we don't create dups
1217          */
1218         if (!must_have_seen) {
1219             /* so we must consume the bytecode */
1220             VTABLE_thaw(interp, pmc, info);
1221         }
1222 #else
1223         PARROT_ASSERT(must_have_seen);
1224 #endif
1225         /*
1226          * that's a duplicate
1227          if (info->container)
1228          GC_WRITE_BARRIER(interp, info->container, NULL, pmc);
1229          */
1230         *info->thaw_ptr = pmc;
1231         return;
1232     }
1233
1234     PARROT_ASSERT(!must_have_seen);
1235     pmc = thaw_create_pmc(interp, info, type);
1236
1237     VTABLE_thaw(interp, pmc, info);
1238     if (info->extra_flags == EXTRA_CLASS_EXISTS) {
1239         pmc = (PMC *)info->extra;
1240         info->extra = NULL;
1241         info->extra_flags = 0;
1242     }
1243     if (!info->thaw_result)
1244         info->thaw_result = pmc;
1245     else {
1246         if (info->container) {
1247             GC_WRITE_BARRIER(interp, info->container, NULL, pmc);
1248         }
1249         *info->thaw_ptr = pmc;
1250     }
1251     list_assign(interp, (List *)PMC_data(info->id_list), id, pmc, enum_type_PMC);
1252     /* remember nested aggregates depth first */
1253     if (pmc->pmc_ext)
1254         list_unshift(interp, (List *)PMC_data(info->todo), pmc, enum_type_PMC);
1255 }
1256
1257
1258 /*
1259
1260 =item C<static UINTVAL id_from_pmc>
1261
1262 Find a PMC in an arena, and return an id (left-shifted 2 bits),
1263 based on its position.
1264
1265 If not found, throw an exception.
1266
1267 =cut
1268
1269 */
1270
1271 static UINTVAL
1272 id_from_pmc(PARROT_INTERP, ARGIN(PMC* pmc))
1273 {
1274     UINTVAL id = 1;     /* first PMC in first arena */
1275     Small_Object_Arena *arena;
1276     Small_Object_Pool *pool;
1277
1278     pmc = (PMC*)PObj_to_ARENA(pmc);
1279     pool = interp->arena_base->pmc_pool;
1280     for (arena = pool->last_Arena; arena; arena = arena->prev) {
1281         const ptrdiff_t ptr_diff = (ptrdiff_t)pmc - (ptrdiff_t)arena->start_objects;
1282         if (ptr_diff >= 0 && ptr_diff <
1283                 (ptrdiff_t)(arena->used * pool->object_size)) {
1284             PARROT_ASSERT(ptr_diff % pool->object_size == 0);
1285             id += ptr_diff / pool->object_size;
1286             return id << 2;
1287         }
1288         id += arena->total_objects;
1289     }
1290
1291     pool = interp->arena_base->constant_pmc_pool;
1292     for (arena = pool->last_Arena; arena; arena = arena->prev) {
1293         const ptrdiff_t ptr_diff = (ptrdiff_t)pmc - (ptrdiff_t)arena->start_objects;
1294         if (ptr_diff >= 0 && ptr_diff <
1295                 (ptrdiff_t)(arena->used * pool->object_size)) {
1296             PARROT_ASSERT(ptr_diff % pool->object_size == 0);
1297             id += ptr_diff / pool->object_size;
1298             return id << 2;
1299         }
1300         id += arena->total_objects;
1301     }
1302
1303     real_exception(interp, NULL, 1, "Couldn't find PMC in arenas");
1304 }
1305
1306 /*
1307
1308 =item C<static void add_pmc_next_for_GC>
1309
1310 Remembers the PMC for later processing.
1311
1312 =cut
1313
1314 */
1315
1316 static void
1317 add_pmc_next_for_GC(SHIM_INTERP, ARGIN(PMC *pmc), ARGOUT(visit_info *info))
1318 {
1319     if (pmc->pmc_ext) {
1320         PMC_next_for_GC(info->mark_ptr) = pmc;
1321         info->mark_ptr = PMC_next_for_GC(pmc) = pmc;
1322     }
1323 }
1324
1325 /*
1326
1327 =item C<static int next_for_GC_seen>
1328
1329 Remembers next child to visit via the C<next_for_GC pointer> generate a
1330 unique ID per PMC and freeze the ID (not the PMC address) so thaw the
1331 hash-lookup can be replaced by an array lookup then which is a lot
1332 faster.
1333
1334 =cut
1335
1336 */
1337
1338 PARROT_INLINE
1339 static int
1340 next_for_GC_seen(PARROT_INTERP, ARGIN_NULLOK(PMC *pmc),
1341         ARGIN(visit_info *info), ARGOUT(UINTVAL *id))
1342 {
1343     int seen = 0;
1344
1345     if (PMC_IS_NULL(pmc)) {
1346         *id = 0;
1347         return 1;
1348     }
1349
1350     /*
1351      * we can only remember PMCs with a next_for_GC pointer
1352      * which is located in pmc_ext
1353      */
1354     if (pmc->pmc_ext) {
1355         /* already seen? */
1356         if (!PMC_IS_NULL(PMC_next_for_GC(pmc))) {
1357             seen = 1;
1358             goto skip;
1359         }
1360         /* put pmc at the end of the list */
1361         PMC_next_for_GC(info->mark_ptr) = pmc;
1362         /* make end self-referential */
1363         info->mark_ptr = PMC_next_for_GC(pmc) = pmc;
1364     }
1365 skip:
1366     *id = id_from_pmc(interp, pmc);
1367     return seen;
1368 }
1369
1370 /*
1371
1372 =item C<static void add_pmc_todo_list>
1373
1374 Remembers the PMC to be processed later.
1375
1376 =cut
1377
1378 */
1379
1380 static void
1381 add_pmc_todo_list(PARROT_INTERP, ARGIN_NULLOK(PMC *pmc), ARGIN(visit_info *info))
1382 {
1383     list_push(interp, (List *)PMC_data(info->todo), pmc, enum_type_PMC);
1384 }
1385
1386 /*
1387
1388 =item C<static int todo_list_seen>
1389
1390 Returns true if the PMC was seen, otherwise it put it on the todo list,
1391 generates an ID (tag) for PMC, offset by 4 as are addresses, low bits
1392 are flags.
1393
1394 =cut
1395
1396 */
1397
1398 PARROT_INLINE
1399 static int
1400 todo_list_seen(PARROT_INTERP, ARGIN(PMC *pmc), ARGMOD(visit_info *info),
1401         ARGOUT(UINTVAL *id))
1402 {
1403     HashBucket * const b =
1404         parrot_hash_get_bucket(interp, (Hash *)PMC_struct_val(info->seen), pmc);
1405
1406     if (b) {
1407         *id = (UINTVAL) b->value;
1408         return 1;
1409     }
1410
1411     info->id += 4;      /* next id to freeze */
1412     *id = info->id;
1413     parrot_hash_put(interp, (Hash *)PMC_struct_val(info->seen), pmc, (void*)*id);
1414     /* remember containers */
1415     if (pmc->pmc_ext)
1416         list_unshift(interp, (List *)PMC_data(info->todo), pmc, enum_type_PMC);
1417     return 0;
1418 }
1419
1420 /*
1421
1422 =item C<static void visit_next_for_GC>
1423
1424 C<visit_child> callbacks:
1425
1426 Checks if the PMC was seen, generate an ID for it if not, then do the
1427 appropriate action.
1428
1429 =cut
1430
1431 */
1432
1433 static void
1434 visit_next_for_GC(PARROT_INTERP, ARGIN(PMC* pmc), ARGIN(visit_info* info))
1435 {
1436     UINTVAL id;
1437     const int seen = next_for_GC_seen(interp, pmc, info, &id);
1438     UNUSED(seen);
1439
1440     real_exception(interp, NULL, 1, "todo convert to depth first");
1441     /* do_action(interp, pmc, info, seen, id); UNCOMMENT WHEN TODO IS DONE*/
1442     /*
1443      * TODO probe for class methods that override the default.
1444      * To avoid overhead, we could have an array[class_enums]
1445      * which (after first find_method) has a bit, if a user
1446      * callback is there.
1447      */
1448     /* UNCOMMENT WHEN TODO IS DONE
1449     if (!seen)
1450         (info->visit_action)(interp, pmc, info);
1451     */
1452 }
1453
1454 /*
1455
1456 =item C<static void visit_todo_list>
1457
1458 Checks the seen PMC via the todo list.
1459
1460 =cut
1461
1462 */
1463
1464 static void
1465 visit_todo_list(PARROT_INTERP, ARGIN(PMC* pmc), ARGIN(visit_info* info))
1466 {
1467     UINTVAL id;
1468     int seen;
1469
1470     if (PMC_IS_NULL(pmc)) {
1471         seen = 1;
1472         id = 0;
1473     }
1474     else
1475         seen = todo_list_seen(interp, pmc, info, &id);
1476     do_action(interp, pmc, info, seen, id);
1477     if (!seen)
1478         (info->visit_action)(interp, pmc, info);
1479 }
1480
1481 /*
1482
1483 =item C<static void visit_todo_list_thaw>
1484
1485 Callback for thaw - action first.
1486
1487 Todo-list and seen handling is all in C<do_thaw()>.
1488
1489 =cut
1490
1491 */
1492
1493 static void
1494 visit_todo_list_thaw(PARROT_INTERP, ARGIN(PMC* old), ARGIN(visit_info* info))
1495 {
1496     do_thaw(interp, old, info);
1497 }
1498
1499 /*
1500
1501 =item C<static void visit_loop_next_for_GC>
1502
1503 Put first item on todo list, then run as long as there are items to be
1504 done.
1505
1506 =cut
1507
1508 */
1509
1510 static void
1511 visit_loop_next_for_GC(PARROT_INTERP, ARGIN(PMC *current),
1512         ARGIN(visit_info *info))
1513 {
1514     visit_next_for_GC(interp, current, info);
1515     if (current->pmc_ext) {
1516         PMC *prev = NULL;
1517
1518         while (current != prev) {
1519             VTABLE_visit(interp, current, info);
1520             prev = current;
1521             current = PMC_next_for_GC(current);
1522         }
1523     }
1524 }
1525
1526 /*
1527
1528 =item C<static void visit_loop_todo_list>
1529
1530 The thaw loop.
1531
1532 =cut
1533
1534 */
1535
1536 static void
1537 visit_loop_todo_list(PARROT_INTERP, ARGIN_NULLOK(PMC *current),
1538         ARGIN(visit_info *info))
1539 {
1540     List * const todo = (List *)PMC_data(info->todo);
1541     PMC **list_item;
1542     int i;
1543     List *finish_list;
1544     int finished_first = 0;
1545
1546     const int thawing =
1547         info->what == VISIT_THAW_CONSTANTS ||
1548         info->what == VISIT_THAW_NORMAL;
1549
1550     if (thawing) {
1551         /*
1552          * create a list that contains PMCs that need thawfinish
1553          */
1554         PMC * const finish_list_pmc = pmc_new(interp, enum_class_Array);
1555         finish_list = (List *)PMC_data(finish_list_pmc);
1556     }
1557     else
1558         finish_list = NULL;
1559
1560     (info->visit_pmc_now)(interp, current, info);
1561     /*
1562      * can't cache upper limit, visit may append items
1563      */
1564 again:
1565     while ((list_item = (PMC**)list_shift(interp, todo, enum_type_PMC))) {
1566         current = *list_item;
1567         if (!current) {
1568             real_exception(interp, NULL, 1,
1569                     "NULL current PMC in visit_loop_todo_list");
1570         }
1571         VTABLE_visit(interp, current, info);
1572         if (thawing) {
1573             if (current == info->thaw_result)
1574                 finished_first = 1;
1575             if (current->vtable && current->vtable->thawfinish !=
1576                     Parrot_default_thawfinish)
1577                 list_unshift(interp, finish_list, current, enum_type_PMC);
1578         }
1579     }
1580
1581     if (thawing) {
1582         INTVAL n;
1583         /*
1584          * if image isn't consumed, there are some extra data to thaw
1585          */
1586         if (info->image->bufused > 0) {
1587             (info->visit_pmc_now)(interp, NULL, info);
1588             goto again;
1589         }
1590         /*
1591          * on thawing call thawfinish for each processed PMC
1592          */
1593         if (!finished_first) {
1594             /*
1595              * the first create PMC might not be in the list,
1596              * if it has no pmc_ext
1597              */
1598             list_unshift(interp, finish_list, info->thaw_result, enum_type_PMC);
1599         }
1600         n = list_length(interp, finish_list);
1601         for (i = 0; i < n ; ++i) {
1602             current = *(PMC**)list_get(interp, finish_list, i, enum_type_PMC);
1603             if (!PMC_IS_NULL(current))
1604                 VTABLE_thawfinish(interp, current, info);
1605         }
1606     }
1607 }
1608
1609 /*
1610
1611 =item C<static void create_image>
1612
1613 Allocate image to some estimated size.
1614
1615 =cut
1616
1617 */
1618
1619 static void
1620 create_image(PARROT_INTERP, ARGIN_NULLOK(PMC *pmc), ARGMOD(visit_info *info))
1621 {
1622     INTVAL len;
1623     if (!PMC_IS_NULL(pmc) && (VTABLE_does(interp, pmc,
1624                 string_from_literal(interp, "array")) ||
1625         VTABLE_does(interp, pmc,
1626                 string_from_literal(interp, "hash")))) {
1627         const INTVAL items = VTABLE_elements(interp, pmc);
1628         /*
1629          * TODO check e.g. first item of aggregate and estimate size
1630          */
1631         len = items * FREEZE_BYTES_PER_ITEM;
1632     }
1633     else
1634         len = FREEZE_BYTES_PER_ITEM;
1635
1636     info->image = string_make_empty(interp, enum_stringrep_one, len);
1637 }
1638
1639 /*
1640
1641 =item C<static PMC* run_thaw>
1642
1643 Performs thawing. C<what> indicates what to be thawed.
1644
1645 Thaw could use the C<next_for_GC> pointers as todo-list too, but this
1646 would need 2 runs through the arenas to clean the C<next_for_GC>
1647 pointers.
1648
1649 For now it seems cheaper to use a list for remembering contained
1650 aggregates. We could of course decide dynamically, which strategy to
1651 use, e.g.: given a big image, the first thawed item is a small
1652 aggregate. This implies, it probably contains (or some big strings) more
1653 nested containers, for which the C<next_for_GC> approach could be a win.
1654
1655 =cut
1656
1657 */
1658
1659 PARROT_WARN_UNUSED_RESULT
1660 PARROT_CAN_RETURN_NULL
1661 static PMC*
1662 run_thaw(PARROT_INTERP, ARGIN(STRING* image), visit_enum_type what)
1663 {
1664     visit_info info;
1665     int dod_block = 0;
1666     const UINTVAL bufused = image->bufused;
1667
1668     info.image = image;
1669     /*
1670      * if we are thawing a lot of PMCs, its cheaper to do
1671      * a DOD run first and then block DOD - the limit should be
1672      * chosen so that no more then one DOD run would be triggered
1673      *
1674      * XXX
1675      *
1676      * md5_3.pir shows a segfault during thawing the config hash
1677      * info->thaw_ptr becomes invalid - seems that the hash got
1678      * collected under us.
1679      */
1680     if (1 || (string_length(interp, image) > THAW_BLOCK_DOD_SIZE)) {
1681         Parrot_do_dod_run(interp, 1);
1682         Parrot_block_GC_mark(interp);
1683         Parrot_block_GC_sweep(interp);
1684         dod_block = 1;
1685     }
1686
1687     info.what = what;   /* _NORMAL or _CONSTANTS */
1688     todo_list_init(interp, &info);
1689     info.visit_pmc_now = visit_todo_list_thaw;
1690     info.visit_pmc_later = add_pmc_todo_list;
1691
1692     info.thaw_result = NULL;
1693     /*
1694      * run thaw loop
1695      */
1696     visit_loop_todo_list(interp, NULL, &info);
1697     /*
1698      * thaw does "consume" the image string by incrementing strstart
1699      * and decrementing bufused - restore that
1700      */
1701     LVALUE_CAST(char *, image->strstart) -= bufused;
1702     image->bufused = bufused;
1703     PARROT_ASSERT(image->strstart >= (char *)PObj_bufstart(image));
1704
1705     if (dod_block) {
1706         Parrot_unblock_GC_mark(interp);
1707         Parrot_unblock_GC_sweep(interp);
1708     }
1709     PackFile_destroy(interp, info.image_io->pf);
1710     mem_sys_free(info.image_io);
1711     info.image_io = NULL;
1712     return info.thaw_result;
1713 }
1714
1715 /*
1716
1717 =back
1718
1719 =head2 Public Interface
1720
1721 =over 4
1722
1723 =item C<STRING* Parrot_freeze_at_destruct>
1724
1725 This function must not consume any resources (except the image itself).
1726 It uses the C<next_for_GC> pointer, so its not reentrant and must not be
1727 interrupted by a DOD run.
1728
1729 =cut
1730
1731 */
1732
1733 PARROT_API
1734 PARROT_WARN_UNUSED_RESULT
1735 PARROT_CAN_RETURN_NULL
1736 STRING*
1737 Parrot_freeze_at_destruct(PARROT_INTERP, ARGIN(PMC* pmc))
1738 {
1739     visit_info info;
1740
1741     Parrot_block_GC_mark(interp);
1742     cleanup_next_for_GC(interp);
1743     info.what = VISIT_FREEZE_AT_DESTRUCT;
1744     info.mark_ptr = pmc;
1745     info.thaw_ptr = NULL;
1746     info.visit_pmc_now = visit_next_for_GC;
1747     info.visit_pmc_later = add_pmc_next_for_GC;
1748     create_image(interp, pmc, &info);
1749     ft_init(interp, &info);
1750
1751     visit_loop_next_for_GC(interp, pmc, &info);
1752
1753     Parrot_unblock_GC_mark(interp);
1754     PackFile_destroy(interp, info.image_io->pf);
1755     mem_sys_free(info.image_io);
1756     return info.image;
1757 }
1758
1759 /*
1760
1761 =item C<STRING* Parrot_freeze>
1762
1763 Freeze using either method.
1764
1765 =cut
1766
1767 */
1768
1769 PARROT_API
1770 PARROT_WARN_UNUSED_RESULT
1771 PARROT_CAN_RETURN_NULL
1772 STRING*
1773 Parrot_freeze(PARROT_INTERP, ARGIN(PMC* pmc))
1774 {
1775 #if FREEZE_USE_NEXT_FOR_GC
1776     /*
1777      * we could do a DOD run here before, to free resources
1778      */
1779     return Parrot_freeze_at_destruct(interp, pmc);
1780 #else
1781     /*
1782      * freeze using a todo list and seen hash
1783      * Please note that both have to be PMCs, so that trace_system_stack
1784      * can call mark on the PMCs
1785      */
1786     visit_info info;
1787
1788     info.what = VISIT_FREEZE_NORMAL;
1789     create_image(interp, pmc, &info);
1790     todo_list_init(interp, &info);
1791
1792     visit_loop_todo_list(interp, pmc, &info);
1793
1794     PackFile_destroy(interp, info.image_io->pf);
1795     mem_sys_free(info.image_io);
1796     return info.image;
1797 #endif
1798 }
1799
1800 /*
1801
1802 =item C<PMC* Parrot_thaw>
1803
1804 Thaw a PMC, called from the C<thaw> opcode.
1805
1806 =cut
1807
1808 */
1809
1810 PARROT_API
1811 PARROT_WARN_UNUSED_RESULT
1812 PARROT_CAN_RETURN_NULL
1813 PMC*
1814 Parrot_thaw(PARROT_INTERP, ARGIN(STRING* image))
1815 {
1816     return run_thaw(interp, image, VISIT_THAW_NORMAL);
1817 }
1818
1819 /*
1820
1821 =item C<PMC* Parrot_thaw_constants>
1822
1823 Thaw the constants. This is used by PackFile for unpacking PMC
1824 constants.
1825
1826 =cut
1827
1828 */
1829
1830 PARROT_API
1831 PARROT_WARN_UNUSED_RESULT
1832 PARROT_CAN_RETURN_NULL
1833 PMC*
1834 Parrot_thaw_constants(PARROT_INTERP, ARGIN(STRING* image))
1835 {
1836     return run_thaw(interp, image, VISIT_THAW_CONSTANTS);
1837 }
1838
1839 /*
1840
1841 =item C<PMC* Parrot_clone>
1842
1843 There are for sure shortcuts to clone faster, e.g. always thaw the image
1844 immediately or use a special callback. But for now we just thaw a frozen
1845 PMC.
1846
1847 =cut
1848
1849 */
1850
1851 PARROT_API
1852 PARROT_WARN_UNUSED_RESULT
1853 PARROT_CAN_RETURN_NULL
1854 PMC*
1855 Parrot_clone(PARROT_INTERP, ARGIN(PMC* pmc))
1856 {
1857     return VTABLE_clone(interp, pmc);
1858 }
1859
1860 /*
1861
1862 =back
1863
1864 =head1 TODO
1865
1866 The seen-hash version for freezing might go away sometimes.
1867
1868 =head1 SEE ALSO
1869
1870 Lot of discussion on p6i and F<docs/dev/pmc_freeze.pod>.
1871
1872 =head1 HISTORY
1873
1874 Initial version by leo 2003.11.03 - 2003.11.07.
1875
1876 =cut
1877
1878 */
1879
1880
1881 /*
1882  * Local variables:
1883  *   c-file-style: "parrot"
1884  * End:
1885  * vim: expandtab shiftwidth=4:
1886  */