ghc/runtime/gum/Pack.lc

   1 %
   2 % (c) The Parade/AQUA Projects, Glasgow University, 1995
   3 %     Kevin Hammond, February 15th. 1995
   4 %
   5 %     This is for GUM only.
   6 %
   7 %************************************************************************
   8 %*                                                                      *
   9 \section[Pack.lc]{Packing closures for export to remote processors}
  10 %*                                                                      *
  11 %************************************************************************
  12
  13 This module defines routines for packing closures in the parallel runtime
  14 system (GUM).
  15
  16 \begin{code}
  17 #ifdef PAR /* whole file */
  18
  19 #include "rtsdefs.h"
  20 \end{code}
  21
  22 Static data and code declarations.
  23
  24 \begin{code}
  25 static W_ *PackBuffer = NULL; /* size: can be set via option */
  26
  27 static W_      packlocn, clqsize, clqpos;
  28 static W_      unpackedsize;
  29 static W_      reservedPAsize;                   /*Space reserved for primitive arrays*/
  30 static rtsBool RoomInBuffer;
  31
  32
  33 static void    InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
  34 static rtsBool NotYetPacking PROTO((int offset)),
  35                RoomToPack PROTO((W_ size, W_ ptrs));
  36 static void    AmPacking PROTO((P_ closure));
  37
  38 static void    PackClosure PROTO((P_ closure));
  39 static void    Pack PROTO((W_ data)),
  40                PackPLC PROTO((P_ addr)),
  41                PackOffset PROTO((int offset)),
  42                GlobaliseAndPackGA PROTO((P_ closure));
  43
  44 static int     OffsetFor PROTO((P_ closure));
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 @PackNearbyGraph@ packs a closure and associated graph into a static
  54 buffer (@PackBuffer@).  It returns the address of this buffer and the
  55 size of the data packed into the buffer (in its second parameter,
  56 @packbuffersize@).  The associated graph is packed in a depth first
  57 manner, hence it uses an explicit queue of closures to be packed
  58 rather than simply using a recursive algorithm.  Once the packet is
  59 full, closures (other than primitive arrays) are packed as FetchMes,
  60 and their children are not queued for packing.
  61
  62 \begin{code}
  63 P_
  64 PackNearbyGraph(closure, packbuffersize)
  65 P_ closure;
  66 W_ *packbuffersize;
  67 {
  68     /* Ensure enough heap for all possible RBH_Save closures */
  69
  70     ASSERT(RTSflags.ParFlags.packBufferSize > 0);
  71
  72     if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
  73         return NULL;
  74
  75     InitPacking();
  76
  77     QueueClosure(closure);
  78     do {
  79         PackClosure(DeQueueClosure());
  80     } while (!QueueEmpty());
  81
  82     /* Record how much space is needed to unpack the graph */
  83     PackBuffer[0] = unpackedsize;
  84
  85     /* Set the size parameter */
  86     ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
  87     *packbuffersize = packlocn;
  88
  89     DonePacking();
  90
  91     return (PackBuffer);
  92 }
  93 \end{code}
  94
  95 @PackTSO@ and @PackStkO@ are entry points for two special kinds of
  96 closure which are used in the parallel RTS.  Compared with other
  97 closures they are rather awkward to pack because they don't follow the
  98 normal closure layout (where all pointers occur before all non-pointers).
  99 Luckily, they're only needed when migrating threads between processors.
 100
 101 \begin{code}
 102 W_ *
 103 PackTSO(tso,packbuffersize)
 104 P_ tso;
 105 W_ *packbuffersize;
 106 {
 107   *packbuffersize = 0;
 108   PackBuffer[0] = PackBuffer[1] = 0;
 109   return(PackBuffer);
 110 }
 111
 112 W_ *
 113 PackStkO(stko,packbuffersize)
 114 P_ stko;
 115 W_ *packbuffersize;
 116 {
 117   *packbuffersize = 0;
 118   PackBuffer[0] = PackBuffer[1] = 0;
 119   return(PackBuffer);
 120 }
 121 \end{code}
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection[PackClosure]{Packing Closures}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 @PackClosure@ is the heart of the normal packing code.  It packs a
 131 single closure into the pack buffer, skipping over any indirections
 132 and globalising it as necessary, queues any child pointers for further
 133 packing, and turns it into a @FetchMe@ or revertible black hole
 134 (@RBH@) locally if it was a thunk.  Before the actual closure is
 135 packed, a suitable global address (GA) is inserted in the pack buffer.
 136 There is always room to pack a fetch-me to the closure (guaranteed by
 137 the RoomToPack calculation), and this is packed if there is no room
 138 for the entire closure.
 139
 140 Space is allocated for any primitive array children of a closure, and
 141 hence a primitive array can always be packed along with it's parent
 142 closure.
 143
 144 \begin{code}
 145 void
 146 PackClosure(closure)
 147 P_ closure;
 148 {
 149     W_ size, ptrs, nonptrs, vhs;
 150     int i, clpacklocn;
 151
 152     while (IS_INDIRECTION(INFO_PTR(closure))) {
 153         /* Don't pack indirection closures */
 154 #ifdef PACK_DEBUG
 155         fprintf(stderr, "Shorted an indirection at %x", closure);
 156 #endif
 157         closure = (P_) IND_CLOSURE_PTR(closure);
 158     }
 159
 160     clpacklocn = OffsetFor(closure);
 161
 162     /* If the closure's not already being packed */
 163     if (NotYetPacking(clpacklocn)) {
 164         P_ info;
 165
 166         /*
 167          * PLCs reside on all of the PEs already. Just pack the
 168          * address as a GA (a bit of a kludge, since an address may
 169          * not fit in *any* of the individual GA fields). Const,
 170          * charlike and small intlike closures are converted into
 171          * PLCs.
 172          */
 173         switch (INFO_TYPE(INFO_PTR(closure))) {
 174
 175         case INFO_CHARLIKE_TYPE:
 176 #ifdef PACK_DEBUG
 177             fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
 178 #endif
 179             PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
 180             return;
 181
 182         case INFO_CONST_TYPE:
 183 #ifdef PACK_DEBUG
 184             fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
 185 #endif
 186             PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
 187             return;
 188
 189         case INFO_STATIC_TYPE:
 190         case INFO_CAF_TYPE:     /* For now we ship indirections to CAFs: They are
 191                                  * evaluated on each PE if needed */
 192 #ifdef PACK_DEBUG
 193             fprintf(stderr, "Packing a PLC %x\n", closure);
 194 #endif
 195             PackPLC(closure);
 196             return;
 197
 198         case INFO_INTLIKE_TYPE:
 199             {
 200                 I_ val = INTLIKE_VALUE(closure);
 201
 202                 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 203 #ifdef PACK_DEBUG
 204                     fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
 205 #endif
 206                     PackPLC(INTLIKE_CLOSURE(val));
 207                     return;
 208                 } else {
 209 #ifdef PACK_DEBUG
 210                     fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
 211 #endif
 212                     break;
 213                 }
 214             }
 215         default:
 216 #ifdef PACK_DEBUG
 217             fprintf(stderr, "Not a PLC: ");
 218 #endif
 219         }                       /* Switch */
 220
 221         /* Otherwise it's not Fixed */
 222
 223         info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs);
 224
 225         if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
 226             size = ptrs = nonptrs = vhs = 0;
 227
 228         /*
 229          * Now peek ahead to see whether the closure has any primitive array
 230          * children
 231          */
 232         for (i = 0; i < ptrs; ++i) {
 233             P_ childInfo;
 234             W_ childSize, childPtrs, childNonPtrs, childVhs;
 235
 236             childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
 237               &childSize, &childPtrs, &childNonPtrs, &childVhs);
 238             if (IS_BIG_MOTHER(childInfo)) {
 239                 reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
 240                   + childPtrs * PACK_FETCHME_SIZE;
 241             }
 242         }
 243
 244         /* Record the location of the GA */
 245         AmPacking(closure);
 246
 247         /* Pack the global address */
 248         GlobaliseAndPackGA(closure);
 249
 250         /*
 251          * Pack a fetchme to the closure if it's a black hole, or the buffer is full
 252          * and it isn't a primitive array. N.B. Primitive arrays are always packed
 253          * (because their parents index into them directly)
 254          */
 255
 256         if (IS_BLACK_HOLE(info) ||
 257           !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
 258           || IS_BIG_MOTHER(info))) {
 259
 260             ASSERT(packlocn > PACK_HDR_SIZE);
 261
 262             /* Just pack as a FetchMe */
 263             info = FetchMe_info;
 264             for (i = 0; i < FIXED_HS; ++i) {
 265                 if (i == INFO_HDR_POSN)
 266                     Pack((W_) FetchMe_info);
 267                 else
 268                     Pack(closure[i]);
 269             }
 270
 271             unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
 272
 273         } else {
 274             /* At last! A closure we can actually pack! */
 275
 276             if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
 277                 fprintf(stderr, "Warning: Replicated a Mutable closure!\n");
 278
 279             for (i = 0; i < FIXED_HS + vhs; ++i)
 280                 Pack(closure[i]);
 281
 282             for (i = 0; i < ptrs; ++i)
 283                 QueueClosure(((PP_) (closure))[i + FIXED_HS + vhs]);
 284
 285             for (i = 0; i < nonptrs; ++i)
 286                 Pack(closure[i + FIXED_HS + vhs + ptrs]);
 287
 288             unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
 289
 290             /*
 291              * Record that this is a revertable black hole so that we can fill in
 292              * its address from the fetch reply.  Problem: unshared thunks may cause
 293              * space leaks this way, their GAs should be deallocated following an
 294              * ACK.
 295              */
 296
 297             if (IS_THUNK(info) && IS_UPDATABLE(info)) {
 298 #ifdef DEBUG
 299                 P_ rbh =
 300 #else
 301                 (void)
 302 #endif
 303                 convertToRBH(closure);
 304
 305                 ASSERT(rbh != NULL);
 306             }
 307         }
 308     }
 309     /* Pack an indirection to the original closure! */
 310     else
 311         PackOffset(clpacklocn);
 312 }
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection[simple-pack-routines]{Simple Packing Routines}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 @Pack@ is the basic packing routine.  It just writes a word of
 322 data into the pack buffer and increments the pack location.
 323
 324 \begin{code}
 325 static void
 326 Pack(data)
 327   W_ data;
 328 {
 329     ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
 330     PackBuffer[packlocn++] = data;
 331 }
 332 \end{code}
 333
 334 If a closure is local, make it global.  Then, divide its weight for export.
 335 The GA is then packed into the pack buffer.
 336
 337 \begin{code}
 338 static void
 339 GlobaliseAndPackGA(closure)
 340 P_ closure;
 341 {
 342     globalAddr *ga;
 343     globalAddr packGA;
 344
 345     if ((ga = LAGAlookup(closure)) == NULL)
 346         ga = MakeGlobal(closure, rtsTrue);
 347     splitWeight(&packGA, ga);
 348     ASSERT(packGA.weight > 0);
 349
 350 #ifdef PACK_DEBUG
 351     fprintf(stderr, "Packing (%x, %d, %x)\n",
 352       packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
 353 #endif
 354     Pack((W_) packGA.weight);
 355     Pack((W_) packGA.loc.gc.gtid);
 356     Pack((W_) packGA.loc.gc.slot);
 357 }
 358 \end{code}
 359
 360 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
 361 address follows instead of PE, slot.
 362
 363 \begin{code}
 364 static void
 365 PackPLC(addr)
 366 P_ addr;
 367 {
 368     Pack(0L);                   /* weight */
 369     Pack((W_) addr);            /* address */
 370 }
 371 \end{code}
 372
 373 @PackOffset@ packs a special GA value that will be interpreted as
 374 an offset to a closure in the pack buffer.  This is used to avoid
 375 unfolding the graph structure into a tree.
 376
 377 \begin{code}
 378 static void
 379 PackOffset(offset)
 380 int offset;
 381 {
 382 #ifdef PACK_DEBUG
 383     fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
 384 #endif
 385     Pack(1L);                   /* weight */
 386     Pack(0L);                   /* pe */
 387     Pack(offset);               /* slot/offset */
 388 }
 389 \end{code}
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection[pack-offsets]{Offsets into the Pack Buffer}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 The offset hash table is used during packing to record the location in
 398 the pack buffer of each closure which is packed.
 399
 400 \begin{code}
 401 static HashTable *offsettable;
 402 \end{code}
 403
 404 @InitPacking@ initialises the packing buffer etc.
 405
 406 \begin{code}
 407 void
 408 InitPackBuffer(STG_NO_ARGS)
 409 {
 410   if (PackBuffer == NULL) { /* not yet allocated */
 411
 412       PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
 413                                          "InitPackBuffer");
 414
 415       InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
 416       AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
 417   }
 418 }
 419
 420 static void
 421 InitPacking(STG_NO_ARGS)
 422 {
 423   /* InitPackBuffer();    now done in ParInit  HWL_ */
 424
 425   packlocn = PACK_HDR_SIZE;
 426   unpackedsize = 0;
 427   reservedPAsize = 0;
 428   RoomInBuffer = rtsTrue;
 429   InitClosureQueue();
 430   offsettable = allocHashTable();
 431 }
 432 \end{code}
 433
 434 @DonePacking@ is called when we've finished packing.  It releases memory
 435 etc.
 436
 437 \begin{code}
 438 static void
 439 DonePacking(STG_NO_ARGS)
 440 {
 441   freeHashTable(offsettable,NULL);
 442   offsettable = NULL;
 443 }
 444 \end{code}
 445
 446 @AmPacking@ records that the closure is being packed.  Note the abuse
 447 of the data field in the hash table -- this saves calling @malloc@!
 448
 449 \begin{code}
 450 static void
 451 AmPacking(closure)
 452 P_ closure;
 453 {
 454 #ifdef PACK_DEBUG
 455     fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n",
 456       closure, INFO_PTR(closure), packlocn);
 457 #endif
 458     insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
 459 }
 460 \end{code}
 461
 462 @OffsetFor@ returns an offset for a closure which is already being
 463 packed.
 464
 465 \begin{code}
 466 static int
 467 OffsetFor(P_ closure)
 468 {
 469     return (int) (W_) lookupHashTable(offsettable, (W_) closure);
 470 }
 471 \end{code}
 472
 473 @NotYetPacking@ determines whether the closure's already being packed.
 474 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.
 475
 476 \begin{code}
 477 static rtsBool
 478 NotYetPacking(offset)
 479 int offset;
 480 {
 481   return(offset < PACK_HDR_SIZE);
 482 }
 483 \end{code}
 484
 485 @RoomToPack@ determines whether there's room to pack the closure into
 486 the pack buffer based on
 487
 488 o how full the buffer is already,
 489 o the closures' size and number of pointers (which must be packed as GAs),
 490 o the size and number of pointers held by any primitive arrays that it points to
 491
 492 It has a *side-effect* in assigning RoomInBuffer to False.
 493
 494 \begin{code}
 495 static rtsBool
 496 RoomToPack(size, ptrs)
 497 W_ size, ptrs;
 498 {
 499     if (RoomInBuffer &&
 500       (packlocn + reservedPAsize + size +
 501         ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= RTSflags.ParFlags.packBufferSize)) {
 502 #ifdef PACK_DEBUG
 503         fprintf(stderr, "Buffer full\n");
 504 #endif
 505         RoomInBuffer = rtsFalse;
 506     }
 507     return (RoomInBuffer);
 508 }
 509 \end{code}
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsection[pack-closure-queue]{Closure Queues}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 These routines manage the closure queue.
 518
 519 \begin{code}
 520 static W_ clqpos, clqsize;
 521
 522 static P_ *ClosureQueue = NULL;   /* HWL: init in main */
 523 \end{code}
 524
 525 @InitClosureQueue@ initialises the closure queue.
 526
 527 \begin{code}
 528 void
 529 AllocClosureQueue(size)
 530   W_ size;
 531 {
 532   ASSERT(ClosureQueue == NULL);
 533   ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
 534 }
 535
 536 void
 537 InitClosureQueue(STG_NO_ARGS)
 538 {
 539   clqpos = clqsize = 0;
 540
 541   if ( ClosureQueue == NULL ) {
 542      AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
 543   }
 544 }
 545 \end{code}
 546
 547 @QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
 548 @rtsFalse@ otherwise.
 549
 550 \begin{code}
 551 rtsBool
 552 QueueEmpty(STG_NO_ARGS)
 553 {
 554   return(clqpos >= clqsize);
 555 }
 556 \end{code}
 557
 558 @QueueClosure@ adds its argument to the closure queue.
 559
 560 \begin{code}
 561 void
 562 QueueClosure(closure)
 563 P_ closure;
 564 {
 565   if(clqsize < RTSflags.ParFlags.packBufferSize)
 566     ClosureQueue[clqsize++] = closure;
 567   else
 568     {
 569       fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
 570       EXIT(EXIT_FAILURE);
 571     }
 572 }
 573 \end{code}
 574
 575 @DeQueueClosure@ returns the head of the closure queue.
 576
 577 \begin{code}
 578 P_
 579 DeQueueClosure(STG_NO_ARGS)
 580 {
 581   if(!QueueEmpty())
 582     return(ClosureQueue[clqpos++]);
 583   else
 584     return(NULL);
 585 }
 586 \end{code}
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection[pack-ga-types]{Types of Global Addresses}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 These routines determine whether a GA is one of a number of special types
 595 of GA.
 596
 597 \begin{code}
 598 rtsBool
 599 isOffset(ga)
 600 globalAddr *ga;
 601 {
 602     return (ga->weight == 1 && ga->loc.gc.gtid == 0);
 603 }
 604
 605 rtsBool
 606 isFixed(ga)
 607 globalAddr *ga;
 608 {
 609     return (ga->weight == 0);
 610 }
 611 \end{code}
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection[pack-print-packet]{Printing Packet Contents}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 #ifdef DEBUG
 621 void
 622 PrintPacket(buffer)
 623 P_ buffer;
 624 {
 625     W_ size, ptrs, nonptrs, vhs;
 626
 627     globalAddr ga;
 628
 629     W_ bufsize;
 630     P_ parent;
 631     W_ pptr = 0, pptrs = 0, pvhs;
 632
 633     W_ unpacklocn = PACK_HDR_SIZE;
 634     W_ gastart = unpacklocn;
 635     W_ closurestart = unpacklocn;
 636
 637     P_ info;
 638
 639     int i;
 640
 641     InitClosureQueue();
 642
 643     /* Unpack the header */
 644     bufsize = buffer[0];
 645
 646     fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);
 647
 648     do {
 649         gastart = unpacklocn;
 650         ga.weight = buffer[unpacklocn++];
 651         if (ga.weight > 0) {
 652             ga.loc.gc.gtid = buffer[unpacklocn++];
 653             ga.loc.gc.slot = buffer[unpacklocn++];
 654         } else
 655             ga.loc.plc = (P_) buffer[unpacklocn++];
 656         closurestart = unpacklocn;
 657
 658         if (isFixed(&ga)) {
 659             fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
 660         } else if (isOffset(&ga)) {
 661             fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
 662         }
 663         /* Print normal closures */
 664         else {
 665             fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
 666               ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
 667
 668             info = get_closure_info((P_) (buffer + closurestart), &size, &ptrs, &nonptrs, &vhs);
 669
 670             if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
 671               size = ptrs = nonptrs = vhs = 0;
 672
 673             if (IS_THUNK(info)) {
 674                 if (IS_UPDATABLE(info))
 675                     fputs("SHARED ", stderr);
 676                 else
 677                     fputs("UNSHARED ", stderr);
 678             }
 679             if (IS_BLACK_HOLE(info)) {
 680                 fputs("BLACK HOLE\n", stderr);
 681             } else {
 682                 /* Fixed header */
 683                 fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
 684                 for (i = 1; i < FIXED_HS; i++)
 685                     fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 686
 687                 /* Variable header */
 688                 if (vhs > 0) {
 689                     fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);
 690
 691                     for (i = 1; i < vhs; i++)
 692                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 693                 }
 694
 695                 fprintf(stderr, "] PTRS %u", ptrs);
 696
 697                 /* Non-pointers */
 698                 if (nonptrs > 0) {
 699                     fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
 700
 701                     for (i = 1; i < nonptrs; i++)
 702                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 703
 704                     putc(']', stderr);
 705                 }
 706                 putc('\n', stderr);
 707             }
 708
 709             /* Add to queue for processing */
 710             QueueClosure((P_) (buffer + closurestart));
 711         }
 712
 713         /* Locate next parent pointer */
 714         pptr++;
 715         while (pptr + 1 > pptrs) {
 716             parent = DeQueueClosure();
 717
 718             if (parent == NULL)
 719                 break;
 720             else {
 721                 (void) get_closure_info(parent, &size, &pptrs, &nonptrs, &pvhs);
 722                 pptr = 0;
 723             }
 724         }
 725     } while (parent != NULL);
 726
 727     fprintf(stderr, "--- End ---\n\n");
 728 }
 729 #endif
 730 \end{code}
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection[pack-get-closure-info]{Closure Info}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 @get_closure_info@ determines the size, number of pointers etc. for this
 739 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
 740
 741 [Can someone please keep this function up to date.  I keep needing it
 742  (or something similar) for interpretive code, and it keeps
 743  bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95]
 744
 745 \begin{code}
 746 P_
 747 get_closure_info(closure, size, ptrs, nonptrs, vhs)
 748 P_ closure;
 749 W_ *size, *ptrs, *nonptrs, *vhs;
 750 {
 751     P_ ip = (P_) INFO_PTR(closure);
 752
 753     switch (INFO_TYPE(ip)) {
 754     case INFO_SPEC_U_TYPE:
 755     case INFO_SPEC_S_TYPE:
 756     case INFO_SPEC_N_TYPE:
 757         *size = SPEC_CLOSURE_SIZE(closure);
 758         *ptrs = SPEC_CLOSURE_NoPTRS(closure);
 759         *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
 760         *vhs = 0 /*SPEC_VHS*/;
 761         break;
 762
 763     case INFO_GEN_U_TYPE:
 764     case INFO_GEN_S_TYPE:
 765     case INFO_GEN_N_TYPE:
 766         *size = GEN_CLOSURE_SIZE(closure);
 767         *ptrs = GEN_CLOSURE_NoPTRS(closure);
 768         *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
 769         *vhs = GEN_VHS;
 770         break;
 771
 772     case INFO_DYN_TYPE:
 773         *size = DYN_CLOSURE_SIZE(closure);
 774         *ptrs = DYN_CLOSURE_NoPTRS(closure);
 775         *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
 776         *vhs = DYN_VHS;
 777         break;
 778
 779     case INFO_TUPLE_TYPE:
 780         *size = TUPLE_CLOSURE_SIZE(closure);
 781         *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
 782         *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
 783         *vhs = TUPLE_VHS;
 784         break;
 785
 786     case INFO_DATA_TYPE:
 787         *size = DATA_CLOSURE_SIZE(closure);
 788         *ptrs = DATA_CLOSURE_NoPTRS(closure);
 789         *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
 790         *vhs = DATA_VHS;
 791         break;
 792
 793     case INFO_IMMUTUPLE_TYPE:
 794     case INFO_MUTUPLE_TYPE:
 795         *size = MUTUPLE_CLOSURE_SIZE(closure);
 796         *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
 797         *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
 798         *vhs = MUTUPLE_VHS;
 799         break;
 800
 801     case INFO_STATIC_TYPE:
 802         *size = STATIC_CLOSURE_SIZE(closure);
 803         *ptrs = STATIC_CLOSURE_NoPTRS(closure);
 804         *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
 805         *vhs = STATIC_VHS;
 806         break;
 807
 808     case INFO_CAF_TYPE:
 809     case INFO_IND_TYPE:
 810         *size = IND_CLOSURE_SIZE(closure);
 811         *ptrs = IND_CLOSURE_NoPTRS(closure);
 812         *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
 813         *vhs = IND_VHS;
 814         break;
 815
 816     case INFO_CONST_TYPE:
 817         *size = CONST_CLOSURE_SIZE(closure);
 818         *ptrs = CONST_CLOSURE_NoPTRS(closure);
 819         *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
 820         *vhs = CONST_VHS;
 821         break;
 822
 823     case INFO_SPEC_RBH_TYPE:
 824         *size = SPEC_RBH_CLOSURE_SIZE(closure);
 825         *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
 826         *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
 827         if (*ptrs <= 2) {
 828             *nonptrs -= (2 - *ptrs);
 829             *ptrs = 1;
 830         } else
 831             *ptrs -= 1;
 832         *vhs = SPEC_RBH_VHS;
 833         break;
 834
 835     case INFO_GEN_RBH_TYPE:
 836         *size = GEN_RBH_CLOSURE_SIZE(closure);
 837         *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
 838         *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
 839         if (*ptrs <= 2) {
 840             *nonptrs -= (2 - *ptrs);
 841             *ptrs = 1;
 842         } else
 843             *ptrs -= 1;
 844         *vhs = GEN_RBH_VHS;
 845         break;
 846
 847     case INFO_CHARLIKE_TYPE:
 848         *size = CHARLIKE_CLOSURE_SIZE(closure);
 849         *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
 850         *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
 851         *vhs = CHARLIKE_VHS;
 852         break;
 853
 854     case INFO_INTLIKE_TYPE:
 855         *size = INTLIKE_CLOSURE_SIZE(closure);
 856         *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
 857         *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
 858         *vhs = INTLIKE_VHS;
 859         break;
 860
 861     case INFO_FETCHME_TYPE:
 862         *size = FETCHME_CLOSURE_SIZE(closure);
 863         *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
 864         *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
 865         *vhs = FETCHME_VHS;
 866         break;
 867
 868     case INFO_FMBQ_TYPE:
 869         *size = FMBQ_CLOSURE_SIZE(closure);
 870         *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
 871         *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
 872         *vhs = FMBQ_VHS;
 873         break;
 874
 875     case INFO_BQ_TYPE:
 876         *size = BQ_CLOSURE_SIZE(closure);
 877         *ptrs = BQ_CLOSURE_NoPTRS(closure);
 878         *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
 879         *vhs = BQ_VHS;
 880         break;
 881
 882     case INFO_BH_TYPE:
 883         *size = BH_CLOSURE_SIZE(closure);
 884         *ptrs = BH_CLOSURE_NoPTRS(closure);
 885         *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
 886         *vhs = BH_VHS;
 887         break;
 888
 889     default:
 890         fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
 891           INFO_TYPE(ip), (W_) closure);
 892         EXIT(EXIT_FAILURE);
 893     }
 894
 895     return ip;
 896 }
 897 \end{code}
 898
 899 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
 900 is available, but it will not perform garbage collection.
 901
 902 \begin{code}
 903
 904 P_
 905 AllocateHeap(size)
 906 W_ size;
 907 {
 908     P_ newClosure;
 909
 910     /* Allocate a new closure */
 911     if (SAVE_Hp + size > SAVE_HpLim)
 912         return NULL;
 913
 914     newClosure = SAVE_Hp + 1;
 915     SAVE_Hp += size;
 916
 917     return newClosure;
 918 }
 919
 920 void
 921 doGlobalGC(STG_NO_ARGS)
 922 {
 923   fprintf(stderr,"Splat -- we just hit global GC!\n");
 924   EXIT(EXIT_FAILURE);
 925   fishing = rtsFalse;
 926 }
 927 \end{code}
 928
 929 \begin{code}
 930 #endif /* PAR -- whole file */
 931 \end{code}