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 = convertToRBH(closure);
 296 #endif
 297                 ASSERT(rbh != NULL);
 298             }
 299         }
 300     }
 301     /* Pack an indirection to the original closure! */
 302     else
 303         PackOffset(clpacklocn);
 304 }
 305 \end{code}
 306
 307 %************************************************************************
 308 %*                                                                      *
 309 \subsection[simple-pack-routines]{Simple Packing Routines}
 310 %*                                                                      *
 311 %************************************************************************
 312
 313 @Pack@ is the basic packing routine.  It just writes a word of
 314 data into the pack buffer and increments the pack location.
 315
 316 \begin{code}
 317 static void
 318 Pack(data)
 319 W_ data;
 320 {
 321   ASSERT(packlocn < PACK_BUFFER_SIZE);
 322   PackBuffer[packlocn++] = data;
 323 }
 324 \end{code}
 325
 326 If a closure is local, make it global.  Then, divide its weight for export.
 327 The GA is then packed into the pack buffer.
 328
 329 \begin{code}
 330 static void
 331 GlobaliseAndPackGA(closure)
 332 P_ closure;
 333 {
 334     globalAddr *ga;
 335     globalAddr packGA;
 336
 337     if ((ga = LAGAlookup(closure)) == NULL)
 338         ga = MakeGlobal(closure, rtsTrue);
 339     splitWeight(&packGA, ga);
 340     ASSERT(packGA.weight > 0);
 341
 342 #ifdef PACK_DEBUG
 343     fprintf(stderr, "Packing (%x, %d, %x)\n",
 344       packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
 345 #endif
 346     Pack((W_) packGA.weight);
 347     Pack((W_) packGA.loc.gc.gtid);
 348     Pack((W_) packGA.loc.gc.slot);
 349 }
 350 \end{code}
 351
 352 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
 353 address follows instead of PE, slot.
 354
 355 \begin{code}
 356 static void
 357 PackPLC(addr)
 358 P_ addr;
 359 {
 360     Pack(0L);                   /* weight */
 361     Pack((W_) addr);            /* address */
 362 }
 363 \end{code}
 364
 365 @PackOffset@ packs a special GA value that will be interpreted as
 366 an offset to a closure in the pack buffer.  This is used to avoid
 367 unfolding the graph structure into a tree.
 368
 369 \begin{code}
 370 static void
 371 PackOffset(offset)
 372 int offset;
 373 {
 374 #ifdef PACK_DEBUG
 375     fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
 376 #endif
 377     Pack(1L);                   /* weight */
 378     Pack(0L);                   /* pe */
 379     Pack(offset);               /* slot/offset */
 380 }
 381 \end{code}
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection[pack-offsets]{Offsets into the Pack Buffer}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 The offset hash table is used during packing to record the location in
 390 the pack buffer of each closure which is packed.
 391
 392 \begin{code}
 393 static HashTable *offsettable;
 394 \end{code}
 395
 396 @InitPacking@ initialises the packing buffer etc.
 397
 398 \begin{code}
 399 static void
 400 InitPacking(STG_NO_ARGS)
 401 {
 402   packlocn = PACK_HDR_SIZE;
 403   unpackedsize = 0;
 404   reservedPAsize = 0;
 405   RoomInBuffer = rtsTrue;
 406   InitClosureQueue();
 407   offsettable = allocHashTable();
 408 }
 409 \end{code}
 410
 411 @DonePacking@ is called when we've finished packing.  It releases memory
 412 etc.
 413
 414 \begin{code}
 415 static void
 416 DonePacking(STG_NO_ARGS)
 417 {
 418   freeHashTable(offsettable,NULL);
 419   offsettable = NULL;
 420 }
 421 \end{code}
 422
 423 @AmPacking@ records that the closure is being packed.  Note the abuse
 424 of the data field in the hash table -- this saves calling @malloc@!
 425
 426 \begin{code}
 427 static void
 428 AmPacking(closure)
 429 P_ closure;
 430 {
 431 #ifdef PACK_DEBUG
 432     fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n",
 433       closure, INFO_PTR(closure), packlocn);
 434 #endif
 435     insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
 436 }
 437 \end{code}
 438
 439 @OffsetFor@ returns an offset for a closure which is already being
 440 packed.
 441
 442 \begin{code}
 443 static int
 444 OffsetFor(closure)
 445 P_ closure;
 446 {
 447     return (int) (W_) lookupHashTable(offsettable, (W_) closure);
 448 }
 449 \end{code}
 450
 451 @NotYetPacking@ determines whether the closure's already being packed.
 452 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.
 453
 454 \begin{code}
 455 static rtsBool
 456 NotYetPacking(offset)
 457 int offset;
 458 {
 459   return(offset < PACK_HDR_SIZE);
 460 }
 461 \end{code}
 462
 463 @RoomToPack@ determines whether there's room to pack the closure into
 464 the pack buffer based on
 465
 466 o how full the buffer is already,
 467 o the closures' size and number of pointers (which must be packed as GAs),
 468 o the size and number of pointers held by any primitive arrays that it points to
 469
 470 It has a *side-effect* in assigning RoomInBuffer to False.
 471
 472 \begin{code}
 473 static rtsBool
 474 RoomToPack(size, ptrs)
 475 W_ size, ptrs;
 476 {
 477     if (RoomInBuffer &&
 478       (packlocn + reservedPAsize + size +
 479         ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE)) {
 480 #ifdef PACK_DEBUG
 481         fprintf(stderr, "Buffer full\n");
 482 #endif
 483         RoomInBuffer = rtsFalse;
 484     }
 485     return (RoomInBuffer);
 486 }
 487 \end{code}
 488
 489 %************************************************************************
 490 %*                                                                      *
 491 \subsection[pack-closure-queue]{Closure Queues}
 492 %*                                                                      *
 493 %************************************************************************
 494
 495 These routines manage the closure queue.
 496
 497 \begin{code}
 498 static W_ clqpos, clqsize;
 499 static P_ ClosureQueue[PACK_BUFFER_SIZE];
 500 \end{code}
 501
 502 @InitClosureQueue@ initialises the closure queue.
 503
 504 \begin{code}
 505 void
 506 InitClosureQueue(STG_NO_ARGS)
 507 {
 508   clqpos = clqsize = 0;
 509 }
 510 \end{code}
 511
 512 @QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
 513 @rtsFalse@ otherwise.
 514
 515 \begin{code}
 516 rtsBool
 517 QueueEmpty(STG_NO_ARGS)
 518 {
 519   return(clqpos >= clqsize);
 520 }
 521 \end{code}
 522
 523 @QueueClosure@ adds its argument to the closure queue.
 524
 525 \begin{code}
 526 void
 527 QueueClosure(closure)
 528 P_ closure;
 529 {
 530   if(clqsize < PACK_BUFFER_SIZE)
 531     ClosureQueue[clqsize++] = closure;
 532   else
 533     {
 534       fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
 535       EXIT(EXIT_FAILURE);
 536     }
 537 }
 538 \end{code}
 539
 540 @DeQueueClosure@ returns the head of the closure queue.
 541
 542 \begin{code}
 543 P_
 544 DeQueueClosure(STG_NO_ARGS)
 545 {
 546   if(!QueueEmpty())
 547     return(ClosureQueue[clqpos++]);
 548   else
 549     return(NULL);
 550 }
 551 \end{code}
 552
 553 %************************************************************************
 554 %*                                                                      *
 555 \subsection[pack-ga-types]{Types of Global Addresses}
 556 %*                                                                      *
 557 %************************************************************************
 558
 559 These routines determine whether a GA is one of a number of special types
 560 of GA.
 561
 562 \begin{code}
 563 rtsBool
 564 isOffset(ga)
 565 globalAddr *ga;
 566 {
 567     return (ga->weight == 1 && ga->loc.gc.gtid == 0);
 568 }
 569
 570 rtsBool
 571 isFixed(ga)
 572 globalAddr *ga;
 573 {
 574     return (ga->weight == 0);
 575 }
 576 \end{code}
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection[pack-print-packet]{Printing Packet Contents}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585 #ifdef DEBUG
 586 void
 587 PrintPacket(buffer)
 588 P_ buffer;
 589 {
 590     W_ size, ptrs, nonptrs, vhs;
 591
 592     globalAddr ga;
 593
 594     W_ bufsize;
 595     P_ parent;
 596     W_ pptr = 0, pptrs = 0, pvhs;
 597
 598     W_ unpacklocn = PACK_HDR_SIZE;
 599     W_ gastart = unpacklocn;
 600     W_ closurestart = unpacklocn;
 601
 602     P_ info;
 603
 604     int i;
 605
 606     InitClosureQueue();
 607
 608     /* Unpack the header */
 609     bufsize = buffer[0];
 610
 611     fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);
 612
 613     do {
 614         gastart = unpacklocn;
 615         ga.weight = buffer[unpacklocn++];
 616         if (ga.weight > 0) {
 617             ga.loc.gc.gtid = buffer[unpacklocn++];
 618             ga.loc.gc.slot = buffer[unpacklocn++];
 619         } else
 620             ga.loc.plc = (P_) buffer[unpacklocn++];
 621         closurestart = unpacklocn;
 622
 623         if (isFixed(&ga)) {
 624             fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
 625         } else if (isOffset(&ga)) {
 626             fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
 627         }
 628         /* Print normal closures */
 629         else {
 630             fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
 631               ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
 632
 633             info = get_closure_info((P_) (buffer + closurestart), &size, &ptrs, &nonptrs, &vhs);
 634
 635             if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
 636               size = ptrs = nonptrs = vhs = 0;
 637
 638             if (IS_THUNK(info)) {
 639                 if (IS_UPDATABLE(info))
 640                     fputs("SHARED ", stderr);
 641                 else
 642                     fputs("UNSHARED ", stderr);
 643             }
 644             if (IS_BLACK_HOLE(info)) {
 645                 fputs("BLACK HOLE\n", stderr);
 646             } else {
 647                 /* Fixed header */
 648                 fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
 649                 for (i = 1; i < FIXED_HS; i++)
 650                     fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 651
 652                 /* Variable header */
 653                 if (vhs > 0) {
 654                     fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);
 655
 656                     for (i = 1; i < vhs; i++)
 657                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 658                 }
 659
 660                 fprintf(stderr, "] PTRS %u", ptrs);
 661
 662                 /* Non-pointers */
 663                 if (nonptrs > 0) {
 664                     fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
 665
 666                     for (i = 1; i < nonptrs; i++)
 667                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
 668
 669                     putc(']', stderr);
 670                 }
 671                 putc('\n', stderr);
 672             }
 673
 674             /* Add to queue for processing */
 675             QueueClosure((P_) (buffer + closurestart));
 676         }
 677
 678         /* Locate next parent pointer */
 679         pptr++;
 680         while (pptr + 1 > pptrs) {
 681             parent = DeQueueClosure();
 682
 683             if (parent == NULL)
 684                 break;
 685             else {
 686                 (void) get_closure_info(parent, &size, &pptrs, &nonptrs, &pvhs);
 687                 pptr = 0;
 688             }
 689         }
 690     } while (parent != NULL);
 691
 692     fprintf(stderr, "--- End ---\n\n");
 693 }
 694 #endif
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection[pack-get-closure-info]{Closure Info}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 @get_closure_info@ determines the size, number of pointers etc. for this
 704 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
 705
 706 [Can someone please keep this function up to date.  I keep needing it
 707  (or something similar) for interpretive code, and it keeps
 708  bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95]
 709
 710 \begin{code}
 711 P_
 712 get_closure_info(closure, size, ptrs, nonptrs, vhs)
 713 P_ closure;
 714 W_ *size, *ptrs, *nonptrs, *vhs;
 715 {
 716     P_ ip = (P_) INFO_PTR(closure);
 717
 718     switch (INFO_TYPE(ip)) {
 719     case INFO_SPEC_U_TYPE:
 720     case INFO_SPEC_S_TYPE:
 721     case INFO_SPEC_N_TYPE:
 722         *size = SPEC_CLOSURE_SIZE(closure);
 723         *ptrs = SPEC_CLOSURE_NoPTRS(closure);
 724         *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
 725         *vhs = 0 /*SPEC_VHS*/;
 726         break;
 727
 728     case INFO_GEN_U_TYPE:
 729     case INFO_GEN_S_TYPE:
 730     case INFO_GEN_N_TYPE:
 731         *size = GEN_CLOSURE_SIZE(closure);
 732         *ptrs = GEN_CLOSURE_NoPTRS(closure);
 733         *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
 734         *vhs = GEN_VHS;
 735         break;
 736
 737     case INFO_DYN_TYPE:
 738         *size = DYN_CLOSURE_SIZE(closure);
 739         *ptrs = DYN_CLOSURE_NoPTRS(closure);
 740         *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
 741         *vhs = DYN_VHS;
 742         break;
 743
 744     case INFO_TUPLE_TYPE:
 745         *size = TUPLE_CLOSURE_SIZE(closure);
 746         *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
 747         *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
 748         *vhs = TUPLE_VHS;
 749         break;
 750
 751     case INFO_DATA_TYPE:
 752         *size = DATA_CLOSURE_SIZE(closure);
 753         *ptrs = DATA_CLOSURE_NoPTRS(closure);
 754         *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
 755         *vhs = DATA_VHS;
 756         break;
 757
 758     case INFO_IMMUTUPLE_TYPE:
 759     case INFO_MUTUPLE_TYPE:
 760         *size = MUTUPLE_CLOSURE_SIZE(closure);
 761         *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
 762         *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
 763         *vhs = MUTUPLE_VHS;
 764         break;
 765
 766     case INFO_STATIC_TYPE:
 767         *size = STATIC_CLOSURE_SIZE(closure);
 768         *ptrs = STATIC_CLOSURE_NoPTRS(closure);
 769         *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
 770         *vhs = STATIC_VHS;
 771         break;
 772
 773     case INFO_CAF_TYPE:
 774     case INFO_IND_TYPE:
 775         *size = IND_CLOSURE_SIZE(closure);
 776         *ptrs = IND_CLOSURE_NoPTRS(closure);
 777         *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
 778         *vhs = IND_VHS;
 779         break;
 780
 781     case INFO_CONST_TYPE:
 782         *size = CONST_CLOSURE_SIZE(closure);
 783         *ptrs = CONST_CLOSURE_NoPTRS(closure);
 784         *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
 785         *vhs = CONST_VHS;
 786         break;
 787
 788     case INFO_SPEC_RBH_TYPE:
 789         *size = SPEC_RBH_CLOSURE_SIZE(closure);
 790         *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
 791         *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
 792         if (*ptrs <= 2) {
 793             *nonptrs -= (2 - *ptrs);
 794             *ptrs = 1;
 795         } else
 796             *ptrs -= 1;
 797         *vhs = SPEC_RBH_VHS;
 798         break;
 799
 800     case INFO_GEN_RBH_TYPE:
 801         *size = GEN_RBH_CLOSURE_SIZE(closure);
 802         *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
 803         *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
 804         if (*ptrs <= 2) {
 805             *nonptrs -= (2 - *ptrs);
 806             *ptrs = 1;
 807         } else
 808             *ptrs -= 1;
 809         *vhs = GEN_RBH_VHS;
 810         break;
 811
 812     case INFO_CHARLIKE_TYPE:
 813         *size = CHARLIKE_CLOSURE_SIZE(closure);
 814         *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
 815         *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
 816         *vhs = CHARLIKE_VHS;
 817         break;
 818
 819     case INFO_INTLIKE_TYPE:
 820         *size = INTLIKE_CLOSURE_SIZE(closure);
 821         *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
 822         *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
 823         *vhs = INTLIKE_VHS;
 824         break;
 825
 826     case INFO_FETCHME_TYPE:
 827         *size = FETCHME_CLOSURE_SIZE(closure);
 828         *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
 829         *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
 830         *vhs = FETCHME_VHS;
 831         break;
 832
 833     case INFO_FMBQ_TYPE:
 834         *size = FMBQ_CLOSURE_SIZE(closure);
 835         *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
 836         *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
 837         *vhs = FMBQ_VHS;
 838         break;
 839
 840     case INFO_BQ_TYPE:
 841         *size = BQ_CLOSURE_SIZE(closure);
 842         *ptrs = BQ_CLOSURE_NoPTRS(closure);
 843         *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
 844         *vhs = BQ_VHS;
 845         break;
 846
 847     case INFO_BH_TYPE:
 848         *size = BH_CLOSURE_SIZE(closure);
 849         *ptrs = BH_CLOSURE_NoPTRS(closure);
 850         *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
 851         *vhs = BH_VHS;
 852         break;
 853
 854     default:
 855         fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
 856           INFO_TYPE(ip), (W_) closure);
 857         EXIT(EXIT_FAILURE);
 858     }
 859
 860     return ip;
 861 }
 862 \end{code}
 863
 864 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
 865 is available, but it will not perform garbage collection.
 866
 867 \begin{code}
 868
 869 P_
 870 AllocateHeap(size)
 871 W_ size;
 872 {
 873     P_ newClosure;
 874
 875     /* Allocate a new closure */
 876     if (SAVE_Hp + size > SAVE_HpLim)
 877         return NULL;
 878
 879     newClosure = SAVE_Hp + 1;
 880     SAVE_Hp += size;
 881
 882     return newClosure;
 883 }
 884
 885 void
 886 doGlobalGC(STG_NO_ARGS)
 887 {
 888   fprintf(stderr,"Splat -- we just hit global GC!\n");
 889   EXIT(EXIT_FAILURE);
 890   fishing = rtsFalse;
 891 }
 892 \end{code}
 893
 894 \begin{code}
 895 #endif /* PAR -- whole file */
 896 \end{code}