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