src/pmc_freeze.c

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