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