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 and for GrAnSim.
   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 The GrAnSim version of the code defines routines for *simulating* the
  17 packing of closures in the same way it
  18 is done in the parallel runtime system. Basically GrAnSim only puts the
  19 addresses of the closures to be transferred into a buffer. This buffer will
  20 then be associated with the event of transferring the graph. When this
  21 event is scheduled, the @UnpackGraph@ routine is called and the buffer
  22 can be discarded afterwards.
  23
  24 Note that in GrAnSim we need many buffers, not just one per PE.
  25
  26 \begin{code}
  27 #if defined(PAR) || defined(GRAN)   /* whole file */
  28
  29 #include "rtsdefs.h"
  30
  31 /* Which RTS flag should be used to get the size of the pack buffer ? */
  32 #if defined(PAR)
  33 #define PACK_BUFFER_SIZE   RTSflags.ParFlags.packBufferSize
  34 #else   /* GRAN */
  35 #define PACK_BUFFER_SIZE   RTSflags.GranFlags.packBufferSize
  36 #endif
  37 \end{code}
  38
  39 Static data and code declarations.
  40
  41 \begin{code}
  42 #if defined(GRAN)
  43 /* To be pedantic: in GrAnSim we're packing *addresses* of closures,
  44    not the closures themselves.
  45 */
  46 static P_ *PackBuffer = NULL; /* size: can be set via option */
  47 #else
  48 static W_ *PackBuffer = NULL;                /* size: can be set via option */
  49 #endif
  50
  51 static W_      packlocn, clqsize, clqpos;
  52 static W_      unpackedsize;
  53 static W_      reservedPAsize;         /*Space reserved for primitive arrays*/
  54 static rtsBool RoomInBuffer;
  55
  56
  57 static void    InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
  58 #if defined(GRAN)
  59 static rtsBool NotYetPacking PROTO((P_ closure));
  60 static void    Pack PROTO((P_ data));
  61 #else
  62 static rtsBool NotYetPacking PROTO((int offset));
  63 static void    Pack PROTO((W_ data));
  64 #endif
  65 static rtsBool RoomToPack PROTO((W_ size, W_ ptrs));
  66 static void    AmPacking PROTO((P_ closure));
  67
  68 static void    PackClosure PROTO((P_ closure))
  69 #if !defined(GRAN)
  70                , PackPLC PROTO((P_ addr))
  71                , PackOffset PROTO((int offset))
  72                , GlobaliseAndPackGA PROTO((P_ closure))
  73 #endif
  74                ;
  75
  76 static int     OffsetFor PROTO((P_ closure));
  77 \end{code}
  78
  79 Bit of a hack for testing if a closure is the root of the graph. This is
  80 set in @PackNearbyGraph@ and tested in @PackClosure@.
  81
  82 \begin{code}
  83 #if defined(GRAN)
  84 I_ packed_thunks = 0;
  85 P_ graphroot;
  86 #endif
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 @PackNearbyGraph@ packs a closure and associated graph into a static
  96 buffer (@PackBuffer@).  It returns the address of this buffer and the
  97 size of the data packed into the buffer (in its second parameter,
  98 @packbuffersize@).  The associated graph is packed in a depth first
  99 manner, hence it uses an explicit queue of closures to be packed
 100 rather than simply using a recursive algorithm.  Once the packet is
 101 full, closures (other than primitive arrays) are packed as FetchMes,
 102 and their children are not queued for packing.
 103
 104 \begin{code}
 105 #  if defined(PAR)
 106 P_
 107 PackNearbyGraph(closure, packbuffersize)
 108 P_ closure;
 109 W_ *packbuffersize;
 110 #  else  /* GRAN */
 111 P_
 112 PackNearbyGraph(closure, tso, packbuffersize)
 113 P_ closure;
 114 P_ tso;
 115 W_ *packbuffersize;
 116 #  endif
 117 {
 118     /* Ensure enough heap for all possible RBH_Save closures */
 119
 120     ASSERT(PACK_BUFFER_SIZE > 0);
 121
 122 #  if defined(GRAN) && defined(GRAN_CHECK)
 123     if ( RTSflags.GranFlags.debug & 0x100 )
 124       fprintf(stderr,"Packing graph with root at 0x%lx (PE %d); demanded by TSO %#lx (%d) (PE %d)  ...\n",
 125               closure, where_is(closure), tso, TSO_ID(tso), where_is(tso) );
 126 #  endif   /* GRAN */
 127
 128     if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
 129         return NULL;
 130
 131     InitPacking();
 132 #  if defined(GRAN)
 133     graphroot = closure;
 134 #  endif
 135
 136     QueueClosure(closure);
 137     do {
 138         PackClosure(DeQueueClosure());
 139     } while (!QueueEmpty());
 140
 141 #  if defined(PAR)
 142     /* Record how much space is needed to unpack the graph */
 143     PackBuffer[0] = unpackedsize;
 144 #  else  /* GRAN */
 145     /* Record how much space is needed to unpack the graph */
 146     PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
 147     PackBuffer[PACK_TSO_LOCN] = tso;
 148     PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
 149 #  endif
 150
 151     /* Set the size parameter */
 152 # if defined(PAR)
 153     ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
 154     *packbuffersize = packlocn;
 155 #  else  /* GRAN */
 156     ASSERT(packlocn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
 157     /* ToDo: Print an earlier, more meaningful message */
 158     if (packlocn==PACK_HDR_SIZE) {  /* i.e. packet is empty */
 159       fprintf(stderr,"EMPTY PACKET! Can't transfer closure %#lx at all!!\n",
 160               closure);
 161       EXIT(EXIT_FAILURE);
 162     }
 163     PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
 164     *packbuffersize = packlocn;
 165 #  endif
 166
 167 #  if !defined(GRAN)
 168     DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */
 169 #  endif
 170
 171 #  if defined(GRAN) && defined(GRAN_CHECK)
 172     tot_packets++;
 173     tot_packet_size += packlocn-PACK_HDR_SIZE  ;
 174
 175     if ( RTSflags.GranFlags.debug & 0x100 ) {
 176       PrintPacket((P_)PackBuffer);
 177     }
 178 #  endif   /* GRAN */
 179
 180     return ((P_)PackBuffer);
 181 }
 182
 183 #if defined(GRAN)
 184 /* This version is used when the node is already local */
 185
 186 P_
 187 PackOneNode(closure, tso, packbuffersize)
 188 P_ closure;
 189 P_ tso;
 190 W_ *packbuffersize;
 191 {
 192     int i, clpacklocn;
 193
 194     InitPacking();
 195
 196 #  if defined(GRAN) && defined(GRAN_CHECK)
 197     if ( RTSflags.GranFlags.debug & 0x100 ) {
 198       W_ size, ptrs, nonptrs, vhs;
 199       P_ info;
 200       char str[80], junk_str[80];
 201
 202       info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
 203       fprintf(stderr,"PackOneNode: %#lx (%s)(PE %#lx) requested by TSO %#lx (%d) (PE %#lx)\n",
 204               closure, str, where_is(closure), tso, TSO_ID(tso), where_is(tso));
 205     }
 206 #  endif
 207
 208     Pack(closure);
 209
 210     /* Record how much space is needed to unpack the graph */
 211     PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
 212     PackBuffer[PACK_TSO_LOCN] = tso;
 213     PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
 214
 215     /* Set the size parameter */
 216     ASSERT(packlocn <= PACK_BUFFER_SIZE);
 217     PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
 218     *packbuffersize = packlocn;
 219
 220 #  if defined(GRAN) && defined(GRAN_CHECK)
 221     tot_packets++;
 222     tot_packet_size += packlocn-PACK_HDR_SIZE  ;
 223
 224     if ( RTSflags.GranFlags.debug & 0x100 ) {
 225       PrintPacket(PackBuffer);
 226     }
 227 #  endif   /* GRAN */
 228
 229     return ((P_)PackBuffer);
 230 }
 231 #endif  /* GRAN */
 232 \end{code}
 233
 234 @PackTSO@ and @PackStkO@ are entry points for two special kinds of
 235 closure which are used in the parallel RTS.  Compared with other
 236 closures they are rather awkward to pack because they don't follow the
 237 normal closure layout (where all pointers occur before all non-pointers).
 238 Luckily, they're only needed when migrating threads between processors.
 239
 240 \begin{code}
 241 #if defined(GRAN)
 242 P_ *
 243 #else
 244 W_ *
 245 #endif
 246 PackTSO(tso,packbuffersize)
 247 P_ tso;
 248 W_ *packbuffersize;
 249 {
 250   *packbuffersize = 0;
 251   PackBuffer[0] = PackBuffer[1] = 0;
 252   return(PackBuffer);
 253 }
 254
 255 #if defined(GRAN)
 256 P_ *
 257 #else
 258 W_ *
 259 #endif
 260 PackStkO(stko,packbuffersize)
 261 P_ stko;
 262 W_ *packbuffersize;
 263 {
 264   *packbuffersize = 0;
 265   PackBuffer[0] = PackBuffer[1] = 0;
 266   return(PackBuffer);
 267 }
 268 \end{code}
 269
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection[PackClosure]{Packing Closures}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 @PackClosure@ is the heart of the normal packing code.  It packs a
 278 single closure into the pack buffer, skipping over any indirections
 279 and globalising it as necessary, queues any child pointers for further
 280 packing, and turns it into a @FetchMe@ or revertible black hole
 281 (@RBH@) locally if it was a thunk.  Before the actual closure is
 282 packed, a suitable global address (GA) is inserted in the pack buffer.
 283 There is always room to pack a fetch-me to the closure (guaranteed by
 284 the RoomToPack calculation), and this is packed if there is no room
 285 for the entire closure.
 286
 287 Space is allocated for any primitive array children of a closure, and
 288 hence a primitive array can always be packed along with it's parent
 289 closure.
 290
 291 \begin{code}
 292 #if defined(PAR)
 293
 294 void
 295 PackClosure(closure)
 296 P_ closure;
 297 {
 298     W_ size, ptrs, nonptrs, vhs;
 299     int i, clpacklocn;
 300     char str[80];
 301
 302     while (IS_INDIRECTION(INFO_PTR(closure))) {
 303         /* Don't pack indirection closures */
 304 #  ifdef PACK_DEBUG
 305         fprintf(stderr, "Shorted an indirection at %x", closure);
 306 #  endif
 307         closure = (P_) IND_CLOSURE_PTR(closure);
 308     }
 309
 310     clpacklocn = OffsetFor(closure);
 311
 312     /* If the closure's not already being packed */
 313     if (NotYetPacking(clpacklocn)) {
 314         P_ info;
 315
 316         /*
 317          * PLCs reside on all of the PEs already. Just pack the
 318          * address as a GA (a bit of a kludge, since an address may
 319          * not fit in *any* of the individual GA fields). Const,
 320          * charlike and small intlike closures are converted into
 321          * PLCs.
 322          */
 323         switch (INFO_TYPE(INFO_PTR(closure))) {
 324
 325         case INFO_CHARLIKE_TYPE:
 326 #  ifdef PACK_DEBUG
 327             fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
 328 #  endif
 329             PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
 330             return;
 331
 332         case INFO_CONST_TYPE:
 333 #  ifdef PACK_DEBUG
 334             fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
 335 #  endif
 336             PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
 337             return;
 338
 339         case INFO_STATIC_TYPE:
 340         case INFO_CAF_TYPE:     /* For now we ship indirections to CAFs: They are
 341                                  * evaluated on each PE if needed */
 342 #  ifdef PACK_DEBUG
 343             fprintf(stderr, "Packing a PLC %x\n", closure);
 344 #  endif
 345             PackPLC(closure);
 346             return;
 347
 348         case INFO_INTLIKE_TYPE:
 349             {
 350                 I_ val = INTLIKE_VALUE(closure);
 351
 352                 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 353 #  ifdef PACK_DEBUG
 354                     fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
 355 #  endif
 356                     PackPLC(INTLIKE_CLOSURE(val));
 357                     return;
 358                 } else {
 359 #  ifdef PACK_DEBUG
 360                     fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
 361 #  endif
 362                     break;
 363                 }
 364             }
 365         default:
 366 #  ifdef PACK_DEBUG
 367             fprintf(stderr, "Not a PLC: ");
 368 #  endif
 369         }                       /* Switch */
 370
 371         /* Otherwise it's not Fixed */
 372
 373         info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
 374
 375         if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
 376             size = ptrs = nonptrs = vhs = 0;
 377
 378         /*
 379          * Now peek ahead to see whether the closure has any primitive array
 380          * children
 381          */
 382         for (i = 0; i < ptrs; ++i) {
 383             P_ childInfo;
 384             W_ childSize, childPtrs, childNonPtrs, childVhs;
 385
 386             childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
 387               &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
 388             if (IS_BIG_MOTHER(childInfo)) {
 389                 reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
 390                   + childPtrs * PACK_FETCHME_SIZE;
 391             }
 392         }
 393
 394         /* Record the location of the GA */
 395         AmPacking(closure);
 396
 397         /* Pack the global address */
 398         GlobaliseAndPackGA(closure);
 399
 400         /*
 401          * Pack a fetchme to the closure if it's a black hole, or the buffer is full
 402          * and it isn't a primitive array. N.B. Primitive arrays are always packed
 403          * (because their parents index into them directly)
 404          */
 405
 406         if (IS_BLACK_HOLE(info) ||
 407           !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
 408           || IS_BIG_MOTHER(info))) {
 409
 410             ASSERT(packlocn > PACK_HDR_SIZE);
 411
 412             /* Just pack as a FetchMe */
 413             info = FetchMe_info;
 414             for (i = 0; i < FIXED_HS; ++i) {
 415                 if (i == INFO_HDR_POSN)
 416                     Pack((W_) FetchMe_info);
 417                 else
 418                     Pack(closure[i]);
 419             }
 420
 421             unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
 422
 423         } else {
 424             /* At last! A closure we can actually pack! */
 425
 426             if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
 427                 fprintf(stderr, "Warning: Replicated a Mutable closure!\n");
 428
 429             for (i = 0; i < FIXED_HS + vhs; ++i)
 430                 Pack(closure[i]);
 431
 432             for (i = 0; i < ptrs; ++i)
 433                 QueueClosure(((PP_) (closure))[i + FIXED_HS + vhs]);
 434
 435             for (i = 0; i < nonptrs; ++i)
 436                 Pack(closure[i + FIXED_HS + vhs + ptrs]);
 437
 438             unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
 439
 440             /*
 441              * Record that this is a revertable black hole so that we can fill in
 442              * its address from the fetch reply.  Problem: unshared thunks may cause
 443              * space leaks this way, their GAs should be deallocated following an
 444              * ACK.
 445              */
 446
 447             if (IS_THUNK(info) && IS_UPDATABLE(info)) {
 448 #  ifdef DEBUG
 449                 P_ rbh =
 450 #  else
 451                 (void)
 452 #  endif
 453                 convertToRBH(closure);
 454
 455                 ASSERT(rbh != NULL);
 456             }
 457         }
 458     }
 459     /* Pack an indirection to the original closure! */
 460     else
 461         PackOffset(clpacklocn);
 462 }
 463
 464 #else  /* GRAN */
 465
 466 /* Fake the packing of a closure */
 467
 468 void
 469 PackClosure(closure)
 470 P_ closure;
 471 {
 472     W_ size, ptrs, nonptrs, vhs;
 473     W_ childSize, childPtrs, junk;   /*size, no. ptrs etc. of a child closure*/
 474     P_ childInfo;
 475     P_ info;
 476     int i, clpacklocn;
 477     W_ PAsize = 0;           /*total size + no. ptrs of all child prim arrays*/
 478     W_ PAptrs = 0;
 479     char str[80], junk_str[80];
 480     rtsBool will_be_rbh, no_more_thunks_please;
 481
 482     /* In GranSim we don't pack and unpack closures -- we just simulate */
 483     /* that by updating the bitmask. So, the graph structure is unchanged */
 484     /* i.e. we don't short out indirections here. -- HWL */
 485
 486     if (where_is(closure) != where_is(graphroot)) {
 487       /* GUM would pack a FETCHME here; simulate that by increasing the */
 488       /* unpacked size accordingly but don't pack anything -- HWL */
 489       unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(closure);
 490       return;
 491     }
 492     /* clpacklocn = OffsetFor(closure); */
 493
 494     /* If the closure's not already being packed */
 495     if (NotYetPacking(closure)) {
 496         switch (INFO_TYPE(INFO_PTR(closure))) {
 497         case INFO_SPEC_RBH_TYPE:
 498         case INFO_GEN_RBH_TYPE:
 499 #  if defined(GRAN) && defined(GRAN_CHECK)
 500           if ( RTSflags.GranFlags.debug & 0x100 ) {
 501             fprintf(stderr,"************ Avoid packing RBH @ %#lx!\n", closure);
 502           }
 503 #  endif
 504           /* Just ignore RBHs i.e. they stay where they are */
 505           return;
 506
 507         case INFO_CHARLIKE_TYPE:
 508         case INFO_CONST_TYPE:
 509         case INFO_STATIC_TYPE:
 510         case INFO_CAF_TYPE:       /* For now we ship indirections to CAFs:
 511                                    * They are evaluated on each PE if needed */
 512           Pack(closure);
 513           return;
 514
 515         case INFO_INTLIKE_TYPE:
 516           {
 517             I_ val = INTLIKE_VALUE(closure);
 518             if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 519               Pack(closure);
 520               return;
 521             } else {
 522               break;
 523             }
 524           }
 525         default:
 526           /* Just fall through to the rest of the function */
 527         }     /* Switch */
 528
 529         /* Otherwise it's not Fixed */
 530
 531         info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
 532         will_be_rbh = IS_THUNK(info) && IS_UPDATABLE(info);
 533         no_more_thunks_please =
 534            (RTSflags.GranFlags.ThunksToPack>0) &&
 535            (packed_thunks>=RTSflags.GranFlags.ThunksToPack);
 536
 537         if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
 538             size = ptrs = nonptrs = vhs = 0;
 539
 540         /* Now peek ahead to see whether the closure has any primitive */
 541         /* array children */
 542         for (i = 0; i < ptrs; ++i) {
 543             P_ childInfo;
 544             W_ childSize, childPtrs, childNonPtrs, childVhs;
 545
 546           childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
 547                                        &childSize, &childPtrs, &childNonPtrs,
 548                                        &childVhs, junk_str);
 549           if (IS_BIG_MOTHER(childInfo)) {
 550                 reservedPAsize += PACK_GA_SIZE + FIXED_HS +
 551                                   childVhs + childNonPtrs +
 552                                   childPtrs * PACK_FETCHME_SIZE;
 553             PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
 554             PAptrs += childPtrs;
 555           }
 556         }
 557
 558         /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
 559          * is full and it isn't a primitive array. N.B. Primitive arrays are
 560          * always packed (because their parents index into them directly) */
 561
 562         if (IS_BLACK_HOLE(info) ||
 563             !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
 564               || IS_BIG_MOTHER(info)))
 565           return;
 566
 567         /* At last! A closure we can actually pack! */
 568
 569         if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
 570             fprintf(stderr,"Warning: Replicated a Mutable closure!");
 571
 572 #  if defined(GRAN) && defined(GRAN_CHECK)
 573         if (no_more_thunks_please && will_be_rbh) {
 574           tot_cuts++;
 575           if ( RTSflags.GranFlags.debug & 0x100 )
 576             fprintf(stderr,"PackClosure (w/ RTSflags.GranFlags.ThunksToPack=%d): Cutting tree with root at %#lx\n",
 577                       RTSflags.GranFlags.ThunksToPack, closure);
 578         } else if (will_be_rbh || (closure==graphroot) ) {
 579             packed_thunks++;
 580             tot_thunks++;
 581         }
 582 #  endif
 583         if (!(no_more_thunks_please && will_be_rbh)) {
 584           Pack(closure);         /* actual PACKING done here --  HWL */
 585           for (i = 0; i < ptrs; ++i)
 586             QueueClosure(((StgPtrPtr) (closure))[i + FIXED_HS + vhs]);
 587
 588           /* Turn thunk into a revertible black hole. */
 589           if (will_be_rbh)
 590             {
 591              P_ rbh;
 592
 593 #  if defined(GRAN) && defined(GRAN_CHECK)
 594              if ( RTSflags.GranFlags.debug & 0x100 ) {
 595                fprintf(stderr,"> RBHing the following closure:\n (%#lx) ",
 596                                 closure);
 597                G_PPN(closure);                          /* see StgDebug */
 598              }
 599 #  endif
 600              rbh = convertToRBH(closure);
 601              ASSERT(rbh != NULL);
 602             }
 603         }
 604       }
 605     else /* !NotYetPacking(clpacklocn) */
 606          /* Don't have to do anything in GrAnSim if closure is already */
 607          /* packed -- HWL */
 608       {
 609 #  if defined(GRAN) && defined(GRAN_CHECK)
 610         if ( RTSflags.GranFlags.debug & 0x100 )
 611           fprintf(stderr,"*** Closure %#lx is already packed and omitted now!\n",
 612                   closure);
 613 #  endif
 614       }
 615 }
 616 #endif  /* PAR */
 617 \end{code}
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection[simple-pack-routines]{Simple Packing Routines}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 About  packet sizes  in GrAnSim: In  GrAnSim  we use  a  malloced block  of
 626 gransim_pack_buffer_size words to   simulate a  packet of  pack_buffer_size
 627 words.  In the simulated  PackBuffer  we only keep   the  addresses of  the
 628 closures that would be packed in the parallel  system (see Pack). To decide
 629 if a  packet overflow  occurs   pack_buffer_size must be   compared  versus
 630 unpackedsize (see RoomToPack).      Currently, there is    no  multi packet
 631 strategy implemented, so in  the case of  an overflow  we just stop  adding
 632 closures  to the  closure queue.  If  an  overflow of the  simulated packet
 633 occurs, we just realloc some more space for it and carry on as usual.
 634 % -- HWL
 635
 636 \begin{code}
 637 #if defined(GRAN)
 638 static P_ *
 639 InstantiatePackBuffer () {
 640
 641   PackBuffer =
 642     /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
 643     (P_ *) stgMallocWords(RTSflags.GranFlags.packBufferSize_internal+PACK_HDR_SIZE,
 644                           "InstantiatePackBuffer") ;
 645
 646   PackBuffer[PACK_SIZE_LOCN] = (P_)RTSflags.GranFlags.packBufferSize_internal;
 647
 648   return (PackBuffer);
 649 }
 650 #endif
 651 \end{code}
 652
 653 @Pack@ is the basic packing routine.  It just writes a word of
 654 data into the pack buffer and increments the pack location.
 655
 656 \begin{code}
 657 #if defined(PAR)
 658 static void
 659 Pack(data)
 660   W_ data;
 661 {
 662     ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
 663     PackBuffer[packlocn++] = data;
 664 }
 665 #else  /* GRAN */
 666 static void
 667 Pack(addr)
 668 P_ addr;
 669 {
 670   W_ size, ptrs, nonptrs, vhs;
 671   P_ info;
 672   char str[80];
 673
 674   /* This checks the size of the GrAnSim internal pack buffer. The simulated
 675      pack buffer is checked via RoomToPack (as in GUM) */
 676   if (packlocn >= (int)PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE) {
 677
 678 # if defined(GRAN_CHECK)
 679     if ( RTSflags.GranFlags.debug & 0x8000 ) {
 680       fprintf(stderr, "Increasing size of PackBuffer %#lx to %d words (PE %u @ %d)\n",
 681               PackBuffer, PackBuffer[PACK_SIZE_LOCN]+REALLOC_SZ,
 682               CurrentProc, CurrentTime[CurrentProc]);
 683     }
 684 # endif
 685     PackBuffer = (P_ *) realloc(PackBuffer,
 686                                 sizeof(P_)*(REALLOC_SZ +
 687                                             (int)PackBuffer[PACK_SIZE_LOCN] +
 688                                             PACK_HDR_SIZE)) ;
 689     if (PackBuffer == NULL) {
 690       fprintf(stderr,"Failing to realloc %d more words for PackBuffer %#lx (PE %u @ %d)\n",
 691               REALLOC_SZ, PackBuffer, CurrentProc, CurrentTime[CurrentProc]);
 692       EXIT(EXIT_FAILURE);
 693     }
 694     PackBuffer[PACK_SIZE_LOCN] += REALLOC_SZ;
 695   }
 696
 697   ASSERT(packlocn < PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
 698
 699   if (addr==NULL)
 700     fprintf(stderr,"Qagh {Pack}Daq: Trying to pack 0\n");
 701   PackBuffer[packlocn++] = addr;
 702   /* ASSERT: Data is a closure in GrAnSim here */
 703   info = get_closure_info(addr, &size, &ptrs, &nonptrs, &vhs, str);
 704   unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ?
 705                                         MIN_UPD_SIZE :
 706                                         size);
 707 }
 708 #endif  /* PAR */
 709 \end{code}
 710
 711 If a closure is local, make it global.  Then, divide its weight for export.
 712 The GA is then packed into the pack buffer.
 713
 714 \begin{code}
 715 #if !defined(GRAN)
 716
 717 static void
 718 GlobaliseAndPackGA(closure)
 719 P_ closure;
 720 {
 721     globalAddr *ga;
 722     globalAddr packGA;
 723
 724     if ((ga = LAGAlookup(closure)) == NULL)
 725         ga = MakeGlobal(closure, rtsTrue);
 726     splitWeight(&packGA, ga);
 727     ASSERT(packGA.weight > 0);
 728
 729 #ifdef PACK_DEBUG
 730     fprintf(stderr, "Packing (%x, %d, %x)\n",
 731       packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
 732 #endif
 733     Pack((W_) packGA.weight);
 734     Pack((W_) packGA.loc.gc.gtid);
 735     Pack((W_) packGA.loc.gc.slot);
 736 }
 737 \end{code}
 738
 739 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
 740 address follows instead of PE, slot.
 741
 742 \begin{code}
 743 static void
 744 PackPLC(addr)
 745 P_ addr;
 746 {
 747     Pack(0L);                   /* weight */
 748     Pack((W_) addr);            /* address */
 749 }
 750 \end{code}
 751
 752 @PackOffset@ packs a special GA value that will be interpreted as
 753 an offset to a closure in the pack buffer.  This is used to avoid
 754 unfolding the graph structure into a tree.
 755
 756 \begin{code}
 757 static void
 758 PackOffset(offset)
 759 int offset;
 760 {
 761 #ifdef PACK_DEBUG
 762     fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
 763 #endif
 764     Pack(1L);                   /* weight */
 765     Pack(0L);                   /* pe */
 766     Pack(offset);               /* slot/offset */
 767 }
 768 #endif  /* !GRAN */
 769 \end{code}
 770
 771 %************************************************************************
 772 %*                                                                      *
 773 \subsection[pack-offsets]{Offsets into the Pack Buffer}
 774 %*                                                                      *
 775 %************************************************************************
 776
 777 The offset hash table is used during packing to record the location in
 778 the pack buffer of each closure which is packed.
 779
 780 \begin{code}
 781 #if defined(PAR)
 782 static HashTable *offsettable;
 783 \end{code}
 784
 785 @InitPacking@ initialises the packing buffer etc.
 786
 787 \begin{code}
 788 void
 789 InitPackBuffer(STG_NO_ARGS)
 790 {
 791   if (PackBuffer == NULL) { /* not yet allocated */
 792
 793       PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
 794                                          "InitPackBuffer");
 795
 796       InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
 797       AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
 798   }
 799 }
 800 #endif /* PAR */
 801
 802 static void
 803 InitPacking(STG_NO_ARGS)
 804 {
 805 #if defined(GRAN)
 806   PackBuffer = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
 807                                             /* NB: free in UnpackGraph */
 808 #endif
 809
 810   packlocn = PACK_HDR_SIZE;
 811   unpackedsize = 0;
 812   reservedPAsize = 0;
 813   RoomInBuffer = rtsTrue;
 814   InitClosureQueue();
 815 #if defined(PAR)
 816   offsettable = allocHashTable();
 817 #else
 818   packed_thunks = 0;
 819 #endif
 820 }
 821 \end{code}
 822
 823 @DonePacking@ is called when we've finished packing.  It releases memory
 824 etc.
 825
 826 \begin{code}
 827 #if defined(PAR)
 828
 829 static void
 830 DonePacking(STG_NO_ARGS)
 831 {
 832   freeHashTable(offsettable,NULL);
 833   offsettable = NULL;
 834 }
 835 \end{code}
 836
 837 @AmPacking@ records that the closure is being packed.  Note the abuse
 838 of the data field in the hash table -- this saves calling @malloc@!
 839
 840 \begin{code}
 841 static void
 842 AmPacking(closure)
 843 P_ closure;
 844 {
 845 #ifdef PACK_DEBUG
 846     fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n",
 847       closure, INFO_PTR(closure), packlocn);
 848 #endif
 849     insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
 850 }
 851 \end{code}
 852
 853 @OffsetFor@ returns an offset for a closure which is already being
 854 packed.
 855
 856 \begin{code}
 857 static int
 858 OffsetFor(P_ closure)
 859 {
 860     return (int) (W_) lookupHashTable(offsettable, (W_) closure);
 861 }
 862 \end{code}
 863
 864 @NotYetPacking@ determines whether the closure's already being packed.
 865 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.
 866
 867 \begin{code}
 868 static rtsBool
 869 NotYetPacking(offset)
 870 int offset;
 871 {
 872   return(offset < PACK_HDR_SIZE);
 873 }
 874
 875 #else  /* GRAN */
 876
 877 static rtsBool
 878 NotYetPacking(closure)
 879 P_ closure;
 880 { int i;
 881   rtsBool found = rtsFalse;
 882
 883   for (i=PACK_HDR_SIZE; (i<packlocn) && !found; i++)
 884     found = PackBuffer[i]==closure;
 885
 886   return (!found);
 887 }
 888 #endif
 889 \end{code}
 890
 891 @RoomToPack@ determines whether there's room to pack the closure into
 892 the pack buffer based on
 893
 894 o how full the buffer is already,
 895 o the closures' size and number of pointers (which must be packed as GAs),
 896 o the size and number of pointers held by any primitive arrays that it points to
 897
 898 It has a *side-effect* in assigning RoomInBuffer to False.
 899
 900 \begin{code}
 901 static rtsBool
 902 RoomToPack(size, ptrs)
 903 W_ size, ptrs;
 904 {
 905 #if defined(PAR)
 906     if (RoomInBuffer &&
 907       (packlocn + reservedPAsize + size +
 908         ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
 909     {
 910 #ifdef PACK_DEBUG
 911         fprintf(stderr, "Buffer full\n");
 912 #endif
 913         RoomInBuffer = rtsFalse;
 914     }
 915 #else   /* GRAN */
 916     if (RoomInBuffer &&
 917         (unpackedsize + reservedPAsize + size +
 918         ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
 919     {
 920 #if defined(GRAN_CHECK)
 921     if ( RTSflags.GranFlags.debug & 0x100 )
 922         fprintf(stderr, "Buffer full\n");
 923 #endif
 924         RoomInBuffer = rtsFalse;
 925     }
 926 #endif
 927     return (RoomInBuffer);
 928 }
 929 \end{code}
 930
 931 %************************************************************************
 932 %*                                                                      *
 933 \subsection[pack-closure-queue]{Closure Queues}
 934 %*                                                                      *
 935 %************************************************************************
 936
 937 These routines manage the closure queue.
 938
 939 \begin{code}
 940 static W_ clqpos, clqsize;
 941
 942 static P_ *ClosureQueue = NULL;   /* HWL: init in main */
 943 \end{code}
 944
 945 @InitClosureQueue@ initialises the closure queue.
 946
 947 \begin{code}
 948 void
 949 AllocClosureQueue(size)
 950   W_ size;
 951 {
 952   ASSERT(ClosureQueue == NULL);
 953   ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
 954 }
 955
 956 void
 957 InitClosureQueue(STG_NO_ARGS)
 958 {
 959   clqpos = clqsize = 0;
 960
 961   if ( ClosureQueue == NULL )
 962      AllocClosureQueue(PACK_BUFFER_SIZE);
 963 }
 964 \end{code}
 965
 966 @QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
 967 @rtsFalse@ otherwise.
 968
 969 \begin{code}
 970 rtsBool
 971 QueueEmpty(STG_NO_ARGS)
 972 {
 973   return(clqpos >= clqsize);
 974 }
 975 \end{code}
 976
 977 @QueueClosure@ adds its argument to the closure queue.
 978
 979 \begin{code}
 980 void
 981 QueueClosure(closure)
 982 P_ closure;
 983 {
 984   if(clqsize < PACK_BUFFER_SIZE )
 985     ClosureQueue[clqsize++] = closure;
 986   else
 987     {
 988       fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
 989       EXIT(EXIT_FAILURE);
 990     }
 991 }
 992 \end{code}
 993
 994 @DeQueueClosure@ returns the head of the closure queue.
 995
 996 \begin{code}
 997 P_
 998 DeQueueClosure(STG_NO_ARGS)
 999 {
1000   if(!QueueEmpty())
1001     return(ClosureQueue[clqpos++]);
1002   else
1003     return(NULL);
1004 }
1005 \end{code}
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection[pack-ga-types]{Types of Global Addresses}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 These routines determine whether a GA is one of a number of special types
1014 of GA.
1015
1016 \begin{code}
1017 #if defined(PAR)
1018 rtsBool
1019 isOffset(ga)
1020 globalAddr *ga;
1021 {
1022     return (ga->weight == 1 && ga->loc.gc.gtid == 0);
1023 }
1024
1025 rtsBool
1026 isFixed(ga)
1027 globalAddr *ga;
1028 {
1029     return (ga->weight == 0);
1030 }
1031 #endif
1032 \end{code}
1033
1034 %************************************************************************
1035 %*                                                                      *
1036 \subsection[pack-print-packet]{Printing Packet Contents}
1037 %*                                                                      *
1038 %************************************************************************
1039
1040 \begin{code}
1041 #if defined(DEBUG) || defined(GRAN_CHECK)
1042
1043 #if defined(PAR)
1044 void
1045 PrintPacket(buffer)
1046 P_ buffer;
1047 {
1048     W_ size, ptrs, nonptrs, vhs;
1049     char str[80];
1050
1051     globalAddr ga;
1052
1053     W_ bufsize;
1054     P_ parent;
1055     W_ pptr = 0, pptrs = 0, pvhs;
1056
1057     W_ unpacklocn = PACK_HDR_SIZE;
1058     W_ gastart = unpacklocn;
1059     W_ closurestart = unpacklocn;
1060
1061     P_ info;
1062
1063     int i;
1064
1065     InitClosureQueue();
1066
1067     /* Unpack the header */
1068     bufsize = buffer[0];
1069
1070     fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);
1071
1072     do {
1073         gastart = unpacklocn;
1074         ga.weight = buffer[unpacklocn++];
1075         if (ga.weight > 0) {
1076             ga.loc.gc.gtid = buffer[unpacklocn++];
1077             ga.loc.gc.slot = buffer[unpacklocn++];
1078         } else
1079             ga.loc.plc = (P_) buffer[unpacklocn++];
1080         closurestart = unpacklocn;
1081
1082         if (isFixed(&ga)) {
1083             fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
1084         } else if (isOffset(&ga)) {
1085             fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
1086         }
1087         /* Print normal closures */
1088         else {
1089             fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
1090               ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
1091
1092             info = get_closure_info((P_) (buffer + closurestart), &size,
1093                                     &ptrs, &nonptrs, &vhs, str);
1094
1095             if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
1096               size = ptrs = nonptrs = vhs = 0;
1097
1098             if (IS_THUNK(info)) {
1099                 if (IS_UPDATABLE(info))
1100                     fputs("SHARED ", stderr);
1101                 else
1102                     fputs("UNSHARED ", stderr);
1103             }
1104             if (IS_BLACK_HOLE(info)) {
1105                 fputs("BLACK HOLE\n", stderr);
1106             } else {
1107                 /* Fixed header */
1108                 fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
1109                 for (i = 1; i < FIXED_HS; i++)
1110                     fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1111
1112                 /* Variable header */
1113                 if (vhs > 0) {
1114                     fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);
1115
1116                     for (i = 1; i < vhs; i++)
1117                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1118                 }
1119
1120                 fprintf(stderr, "] PTRS %u", ptrs);
1121
1122                 /* Non-pointers */
1123                 if (nonptrs > 0) {
1124                     fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
1125
1126                     for (i = 1; i < nonptrs; i++)
1127                         fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1128
1129                     putc(']', stderr);
1130                 }
1131                 putc('\n', stderr);
1132             }
1133
1134             /* Add to queue for processing */
1135             QueueClosure((P_) (buffer + closurestart));
1136         }
1137
1138         /* Locate next parent pointer */
1139         pptr++;
1140         while (pptr + 1 > pptrs) {
1141             parent = DeQueueClosure();
1142
1143             if (parent == NULL)
1144                 break;
1145             else {
1146                 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
1147                                         &pvhs, str);
1148                 pptr = 0;
1149             }
1150         }
1151     } while (parent != NULL);
1152
1153     fprintf(stderr, "--- End ---\n\n");
1154 }
1155 #else  /* GRAN */
1156 void
1157 PrintPacket(buffer)
1158 P_ buffer;
1159 {
1160     extern char *info_hdr_type(P_ infoptr);  /* defined in Threads.lc */
1161     extern char *info_type(P_ infoptr);      /* defined in Threads.lc */
1162
1163     char str1[80], str2[80], junk_str[80];
1164
1165     W_ size, ptrs, nonptrs, vhs;
1166
1167     /* globalAddr ga; */
1168
1169     W_ bufsize, unpackedsize ;
1170     P_ parent;
1171     W_ pptr = 0, pptrs = 0, pvhs;
1172
1173     W_ unpacklocn = PACK_HDR_SIZE;
1174     W_ gastart = unpacklocn;
1175     W_ closurestart = unpacklocn;
1176
1177     P_ info, tso;
1178     P_ closure;
1179
1180     int i;
1181
1182     InitClosureQueue();
1183
1184 #    if defined(GRAN) && defined(GRAN_CHECK)
1185     if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
1186       fprintf(stderr,"Packet @ 0x%lx hs no flag : 0x%lx\n",
1187               buffer, buffer[PACK_FLAG_LOCN]);
1188       EXIT(EXIT_FAILURE);
1189     }
1190 #    endif
1191
1192     tso = (P_) buffer[PACK_TSO_LOCN];
1193
1194     /* Unpack the header */
1195     unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
1196     bufsize = buffer[PACK_SIZE_LOCN];
1197
1198     fprintf(stderr, "Packed Packet %#lx, size %u (unpacked size is %u); demanded by TSO %#lx (%d)(PE %d)\n--- Begin ---\n",
1199                     buffer, bufsize, unpackedsize, tso, TSO_ID(tso), where_is(tso));
1200
1201     do {
1202         closurestart = unpacklocn;
1203         closure = (P_) buffer[unpacklocn++];
1204
1205         fprintf(stderr, "[%u]: (%#lx) ", closurestart, closure);
1206
1207         info = get_closure_info((P_) (closure),
1208                                          &size, &ptrs, &nonptrs, &vhs,str1);
1209         strcpy(str2,info_type(info));
1210         fprintf(stderr, "(%s|%s) ", str1, str2);
1211
1212         if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
1213           size = ptrs = nonptrs = vhs = 0;
1214
1215         if (IS_THUNK(info)) {
1216                 if (IS_UPDATABLE(info))
1217                     fputs("SHARED ", stderr);
1218                 else
1219                     fputs("UNSHARED ", stderr);
1220         }
1221         if (IS_BLACK_HOLE(info)) {
1222                 fputs("BLACK HOLE\n", stderr);
1223         } else {
1224                 /* Fixed header */
1225                 fprintf(stderr, "FH [%#lx", closure[0]);
1226                 for (i = 1; i < FIXED_HS; i++)
1227                     fprintf(stderr, " %#lx", closure[i]);
1228
1229                 /* Variable header */
1230                 if (vhs > 0) {
1231                     fprintf(stderr, "] VH [%#lx", closure[FIXED_HS]);
1232
1233                     for (i = 1; i < vhs; i++)
1234                         fprintf(stderr, " %#lx", closure[FIXED_HS+i]);
1235                 }
1236
1237                 fprintf(stderr, "] PTRS %u", ptrs);
1238
1239                 /* Non-pointers */
1240                 if (nonptrs > 0) {
1241                     fprintf(stderr, " NPTRS [%#lx", closure[FIXED_HS+vhs]);
1242
1243                     for (i = 1; i < nonptrs; i++)
1244                         fprintf(stderr, " %#lx", closure[FIXED_HS+vhs+i]);
1245
1246                     putc(']', stderr);
1247                 }
1248                 putc('\n', stderr);
1249         }
1250     } while (unpacklocn<bufsize) ;  /* (parent != NULL); */
1251
1252     fprintf(stderr, "--- End ---\n\n");
1253 }
1254 #endif /* PAR */
1255 #endif /* DEBUG || GRAN_CHECK */
1256 \end{code}
1257
1258 %************************************************************************
1259 %*                                                                      *
1260 \subsection[pack-get-closure-info]{Closure Info}
1261 %*                                                                      *
1262 %************************************************************************
1263
1264 @get_closure_info@ determines the size, number of pointers etc. for this
1265 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
1266
1267 [Can someone please keep this function up to date.  I keep needing it
1268  (or something similar) for interpretive code, and it keeps
1269  bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95]
1270
1271 \begin{code}
1272 P_
1273 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
1274 P_ closure;
1275 W_ *size, *ptrs, *nonptrs, *vhs;
1276 char *type;
1277 {
1278    P_ ip = (P_) INFO_PTR(closure);
1279
1280    if (closure==NULL) {
1281      fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
1282      *size = *ptrs = *nonptrs = *vhs = 0;
1283      strcpy(type,"ERROR in get_closure_info");
1284      return;
1285    } else if (closure==Prelude_Z91Z93_closure) {
1286      /* fprintf(stderr, "Qagh {get_closure_info}Daq: Prelude_Z91Z93_closure closure\n"); */
1287      *size = *ptrs = *nonptrs = *vhs = 0;
1288      strcpy(type,"Prelude_Z91Z93_closure");
1289      return;
1290    };
1291
1292     ip = (P_) INFO_PTR(closure);
1293
1294     switch (INFO_TYPE(ip)) {
1295     case INFO_SPEC_U_TYPE:
1296     case INFO_SPEC_S_TYPE:
1297     case INFO_SPEC_N_TYPE:
1298         *size = SPEC_CLOSURE_SIZE(closure);
1299         *ptrs = SPEC_CLOSURE_NoPTRS(closure);
1300         *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
1301         *vhs = 0 /*SPEC_VHS*/;
1302         strcpy(type,"SPEC");
1303         break;
1304
1305     case INFO_GEN_U_TYPE:
1306     case INFO_GEN_S_TYPE:
1307     case INFO_GEN_N_TYPE:
1308         *size = GEN_CLOSURE_SIZE(closure);
1309         *ptrs = GEN_CLOSURE_NoPTRS(closure);
1310         *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
1311         *vhs = GEN_VHS;
1312         strcpy(type,"GEN");
1313         break;
1314
1315     case INFO_DYN_TYPE:
1316         *size = DYN_CLOSURE_SIZE(closure);
1317         *ptrs = DYN_CLOSURE_NoPTRS(closure);
1318         *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
1319         *vhs = DYN_VHS;
1320         strcpy(type,"DYN");
1321         break;
1322
1323     case INFO_TUPLE_TYPE:
1324         *size = TUPLE_CLOSURE_SIZE(closure);
1325         *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
1326         *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
1327         *vhs = TUPLE_VHS;
1328         strcpy(type,"TUPLE");
1329         break;
1330
1331     case INFO_DATA_TYPE:
1332         *size = DATA_CLOSURE_SIZE(closure);
1333         *ptrs = DATA_CLOSURE_NoPTRS(closure);
1334         *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
1335         *vhs = DATA_VHS;
1336         strcpy(type,"DATA");
1337         break;
1338
1339     case INFO_IMMUTUPLE_TYPE:
1340     case INFO_MUTUPLE_TYPE:
1341         *size = MUTUPLE_CLOSURE_SIZE(closure);
1342         *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
1343         *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
1344         *vhs = MUTUPLE_VHS;
1345         strcpy(type,"(IM)MUTUPLE");
1346         break;
1347
1348     case INFO_STATIC_TYPE:
1349         *size = STATIC_CLOSURE_SIZE(closure);
1350         *ptrs = STATIC_CLOSURE_NoPTRS(closure);
1351         *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
1352         *vhs = STATIC_VHS;
1353         strcpy(type,"STATIC");
1354         break;
1355
1356     case INFO_CAF_TYPE:
1357     case INFO_IND_TYPE:
1358         *size = IND_CLOSURE_SIZE(closure);
1359         *ptrs = IND_CLOSURE_NoPTRS(closure);
1360         *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
1361         *vhs = IND_VHS;
1362         strcpy(type,"CAF|IND");
1363         break;
1364
1365     case INFO_CONST_TYPE:
1366         *size = CONST_CLOSURE_SIZE(closure);
1367         *ptrs = CONST_CLOSURE_NoPTRS(closure);
1368         *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
1369         *vhs = CONST_VHS;
1370         strcpy(type,"CONST");
1371         break;
1372
1373     case INFO_SPEC_RBH_TYPE:
1374         *size = SPEC_RBH_CLOSURE_SIZE(closure);
1375         *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
1376         *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
1377         if (*ptrs <= 2) {
1378             *nonptrs -= (2 - *ptrs);
1379             *ptrs = 1;
1380         } else
1381             *ptrs -= 1;
1382         *vhs = SPEC_RBH_VHS;
1383         strcpy(type,"SPEC_RBH");
1384         break;
1385
1386     case INFO_GEN_RBH_TYPE:
1387         *size = GEN_RBH_CLOSURE_SIZE(closure);
1388         *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
1389         *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
1390         if (*ptrs <= 2) {
1391             *nonptrs -= (2 - *ptrs);
1392             *ptrs = 1;
1393         } else
1394             *ptrs -= 1;
1395         *vhs = GEN_RBH_VHS;
1396         strcpy(type,"GEN_RBH");
1397         break;
1398
1399     case INFO_CHARLIKE_TYPE:
1400         *size = CHARLIKE_CLOSURE_SIZE(closure);
1401         *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
1402         *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
1403         *vhs = CHARLIKE_VHS;
1404         strcpy(type,"CHARLIKE");
1405         break;
1406
1407     case INFO_INTLIKE_TYPE:
1408         *size = INTLIKE_CLOSURE_SIZE(closure);
1409         *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
1410         *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
1411         *vhs = INTLIKE_VHS;
1412         strcpy(type,"INTLIKE");
1413         break;
1414
1415 #  if !defined(GRAN)
1416     case INFO_FETCHME_TYPE:
1417         *size = FETCHME_CLOSURE_SIZE(closure);
1418         *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
1419         *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
1420         *vhs = FETCHME_VHS;
1421         strcpy(type,"FETCHME");
1422         break;
1423
1424     case INFO_FMBQ_TYPE:
1425         *size = FMBQ_CLOSURE_SIZE(closure);
1426         *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
1427         *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
1428         *vhs = FMBQ_VHS;
1429         strcpy(type,"FMBQ");
1430         break;
1431 #  endif
1432
1433     case INFO_BQ_TYPE:
1434         *size = BQ_CLOSURE_SIZE(closure);
1435         *ptrs = BQ_CLOSURE_NoPTRS(closure);
1436         *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
1437         *vhs = BQ_VHS;
1438         strcpy(type,"BQ");
1439         break;
1440
1441     case INFO_BH_TYPE:
1442         *size = BH_CLOSURE_SIZE(closure);
1443         *ptrs = BH_CLOSURE_NoPTRS(closure);
1444         *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
1445         *vhs = BH_VHS;
1446         strcpy(type,"BH");
1447         break;
1448
1449     case INFO_TSO_TYPE:
1450         *size = 0; /* TSO_CLOSURE_SIZE(closure); */
1451         *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
1452         *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
1453         *vhs = TSO_VHS;
1454         strcpy(type,"TSO");
1455         break;
1456
1457     case INFO_STKO_TYPE:
1458         *size = 0;
1459         *ptrs = 0;
1460         *nonptrs = 0;
1461         *vhs = STKO_VHS;
1462         strcpy(type,"STKO");
1463         break;
1464
1465     default:
1466         fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
1467           INFO_TYPE(ip), (W_) closure);
1468         EXIT(EXIT_FAILURE);
1469     }
1470
1471     return ip;
1472 }
1473 \end{code}
1474
1475 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
1476 is available, but it will not perform garbage collection.
1477
1478 \begin{code}
1479 P_
1480 AllocateHeap(size)
1481 W_ size;
1482 {
1483     P_ newClosure;
1484
1485     /* Allocate a new closure */
1486     if (SAVE_Hp + size > SAVE_HpLim)
1487         return NULL;
1488
1489     newClosure = SAVE_Hp + 1;
1490     SAVE_Hp += size;
1491
1492     return newClosure;
1493 }
1494
1495 #if defined(PAR)
1496
1497 void
1498 doGlobalGC(STG_NO_ARGS)
1499 {
1500   fprintf(stderr,"Splat -- we just hit global GC!\n");
1501   EXIT(EXIT_FAILURE);
1502   fishing = rtsFalse;
1503 }
1504
1505 #endif /* PAR */
1506 \end{code}
1507
1508 \begin{code}
1509 #endif /* PAR  || GRAN  -- whole file */
1510 \end{code}