ghc/rts/parallel/Pack.c

   1 /*
   2    Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
   3    $Id: Pack.c,v 1.8 2001/07/24 05:04:59 ken Exp $
   4
   5    Graph packing and unpacking code for sending it to another processor
   6    and retrieving the original graph structure from the packet.
   7    In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
   8    Used in GUM and GrAnSim.
   9
  10    The GrAnSim version of the code defines routines for *simulating* the
  11    packing of closures in the same way it is done in the parallel runtime
  12    system. Basically GrAnSim only puts the addresses of the closures to be
  13    transferred into a buffer. This buffer will then be associated with the
  14    event of transferring the graph. When this event is scheduled, the
  15    @UnpackGraph@ routine is called and the buffer can be discarded
  16    afterwards.
  17
  18    Note that in GranSim we need many buffers, not just one per PE.
  19 */
  20
  21 //@node Graph packing, , ,
  22 //@section Graph packing
  23
  24 #if defined(PAR) || defined(GRAN)   /* whole file */
  25
  26 //@menu
  27 //* Includes::
  28 //* Prototypes::
  29 //* Global variables::
  30 //* ADT of Closure Queues::
  31 //* Initialisation for packing::
  32 //* Packing Functions::
  33 //* Low level packing routines::
  34 //* Unpacking routines::
  35 //* Aux fcts for packing::
  36 //* Printing Packet Contents::
  37 //* End of file::
  38 //@end menu
  39 //*/
  40
  41 //@node Includes, Prototypes, Graph packing, Graph packing
  42 //@subsection Includes
  43
  44 #include "Rts.h"
  45 #include "RtsFlags.h"
  46 #include "RtsUtils.h"
  47 #include "ClosureTypes.h"
  48 #include "Storage.h"
  49 #include "Hash.h"
  50 #include "Parallel.h"
  51 #include "GranSimRts.h"
  52 #include "ParallelRts.h"
  53 # if defined(DEBUG)
  54 # include "Sanity.h"
  55 # include "Printer.h"
  56 # include "ParallelDebug.h"
  57 # endif
  58 #include "FetchMe.h"
  59
  60 /* Which RTS flag should be used to get the size of the pack buffer ? */
  61 # if defined(PAR)
  62 #  define RTS_PACK_BUFFER_SIZE   RtsFlags.ParFlags.packBufferSize
  63 # else   /* GRAN */
  64 #  define RTS_PACK_BUFFER_SIZE   RtsFlags.GranFlags.packBufferSize
  65 # endif
  66
  67 //@node Prototypes, Global variables, Includes, Graph packing
  68 //@subsection Prototypes
  69 /*
  70    Code declarations.
  71 */
  72
  73 //@node ADT of closure queues, Init for packing, Prototypes, Prototypes
  74 //@subsubsection ADT of closure queues
  75
  76 static inline void        InitClosureQueue(void);
  77 static inline rtsBool     QueueEmpty(void);
  78 static inline void        QueueClosure(StgClosure *closure);
  79 static inline StgClosure *DeQueueClosure(void);
  80
  81 //@node Init for packing, Packing routines, ADT of closure queues, Prototypes
  82 //@subsubsection Init for packing
  83
  84 static void     InitPacking(rtsBool unpack);
  85 # if defined(PAR)
  86 rtsBool         InitPackBuffer(void);
  87 # elif defined(GRAN)
  88 rtsPackBuffer  *InstantiatePackBuffer (void);
  89 static void     reallocPackBuffer (void);
  90 # endif
  91
  92 //@node Packing routines, Low level packing fcts, Init for packing, Prototypes
  93 //@subsubsection Packing routines
  94
  95 static void    PackClosure (StgClosure *closure);
  96
  97 //@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
  98 //@subsubsection Low level packing fcts
  99
 100 # if defined(GRAN)
 101 static  void    Pack (StgClosure *data);
 102 # else
 103 static  void    Pack (StgWord data);
 104
 105 static void    PackGeneric(StgClosure *closure);
 106 static void    PackArray(StgClosure *closure);
 107 static void    PackPLC (StgPtr addr);
 108 static void    PackOffset (int offset);
 109 static void    PackPAP(StgPAP *pap);
 110 static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
 111 static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
 112 static void           PackFetchMe(StgClosure *closure);
 113
 114 static void    GlobaliseAndPackGA (StgClosure *closure);
 115 # endif
 116
 117 //@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
 118 //@subsubsection Unpacking routines
 119
 120 # if defined(PAR)
 121 void        InitPendingGABuffer(nat size);
 122 void        CommonUp(StgClosure *src, StgClosure *dst);
 123 static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure,
 124                                   rtsBool hasGA);
 125 static nat         FillInClosure(StgWord ***bufptrP, StgClosure *graph);
 126 static void        LocateNextParent(StgClosure **parentP,
 127                                     nat *pptrP, nat *pptrsP, nat *sizeP);
 128 StgClosure        *UnpackGraph(rtsPackBuffer *packBuffer,
 129                                globalAddr **gamap,
 130                                nat *nGAs);
 131 static  StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP,
 132                                    globalAddr *ga);
 133 static  StgWord   **UnpackGA(StgWord **bufptr, globalAddr *ga);
 134 static  StgClosure *UnpackOffset(globalAddr *ga);
 135 static  StgClosure *UnpackPLC(globalAddr *ga);
 136 static  void        UnpackArray(StgWord ***bufptrP, StgClosure *graph);
 137 static  nat         UnpackPAP(StgWord ***bufptrP, StgClosure *graph);
 138
 139 # elif defined(GRAN)
 140 void        CommonUp(StgClosure *src, StgClosure *dst);
 141 StgClosure *UnpackGraph(rtsPackBuffer* buffer);
 142 #endif
 143
 144 //@node Aux fcts for packing,  , Unpacking routines, Prototypes
 145 //@subsubsection Aux fcts for packing
 146
 147 # if defined(PAR)
 148 static void     DonePacking(void);
 149 static void     AmPacking(StgClosure *closure);
 150 static int      OffsetFor(StgClosure *closure);
 151 static rtsBool  NotYetPacking(int offset);
 152 static inline rtsBool  RoomToPack (nat size, nat ptrs);
 153 static inline rtsBool  isOffset(globalAddr *ga);
 154 static inline rtsBool  isFixed(globalAddr *ga);
 155 static inline rtsBool  isConstr(globalAddr *ga);
 156 static inline rtsBool  isUnglobalised(globalAddr *ga);
 157 # elif defined(GRAN)
 158 static void     DonePacking(void);
 159 static rtsBool  NotYetPacking(StgClosure *closure);
 160 # endif
 161
 162 //@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
 163 //@subsection Global variables
 164 /*
 165   Static data declarations
 166 */
 167
 168 static nat     pack_locn,           /* ptr to first free loc in pack buffer */
 169                clq_size, clq_pos,
 170                buf_id = 1;          /* identifier for buffer */
 171 static nat     unpacked_size;
 172 static rtsBool roomInBuffer;
 173 #if defined(PAR)
 174 static GlobalTaskId dest_gtid=0;    /* destination for message to send */
 175 #endif
 176
 177 /*
 178    The pack buffer
 179    To be pedantic: in GrAnSim we're packing *addresses* of closures,
 180    not the closures themselves.
 181 */
 182 static rtsPackBuffer *globalPackBuffer = NULL,    /* for packing a graph */
 183                      *globalUnpackBuffer = NULL;  /* for unpacking a graph */
 184
 185
 186 /*
 187   Bit of a hack for testing if a closure is the root of the graph. This is
 188   set in @PackNearbyGraph@ and tested in @PackClosure@.
 189 */
 190
 191 static nat          packed_thunks = 0;
 192 static StgClosure  *graph_root;
 193
 194 # if defined(PAR)
 195 /*
 196   The offset hash table is used during packing to record the location in
 197   the pack buffer of each closure which is packed.
 198 */
 199 //@cindex offsetTable
 200 static HashTable *offsetTable;
 201
 202 //@cindex PendingGABuffer
 203 static globalAddr *PendingGABuffer, *gaga;
 204
 205 # endif /* PAR */
 206
 207
 208 //@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
 209 //@subsection ADT of Closure Queues
 210
 211 //@menu
 212 //* Closure Queues::
 213 //* Init routines::
 214 //* Basic routines::
 215 //@end menu
 216
 217 //@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
 218 //@subsubsection Closure Queues
 219 /*
 220   Closure Queues
 221
 222   These routines manage the closure queue.
 223 */
 224
 225 static nat clq_pos, clq_size;
 226
 227 static StgClosure **ClosureQueue = NULL;   /* HWL: init in main */
 228
 229 #if defined(DEBUG)
 230 static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
 231 #endif
 232
 233 //@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
 234 //@subsubsection Init routines
 235
 236 /* @InitClosureQueue@ allocates and initialises the closure queue. */
 237
 238 //@cindex InitClosureQueue
 239 static inline void
 240 InitClosureQueue(void)
 241 {
 242   clq_pos = clq_size = 0;
 243
 244   if (ClosureQueue==NULL)
 245     ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE,
 246                                                  "InitClosureQueue");
 247 }
 248
 249 //@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
 250 //@subsubsection Basic routines
 251
 252 /*
 253   QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
 254 */
 255
 256 //@cindex QueueEmpty
 257 static inline rtsBool
 258 QueueEmpty(void)
 259 {
 260   return(clq_pos >= clq_size);
 261 }
 262
 263 /* QueueClosure adds its argument to the closure queue. */
 264
 265 //@cindex QueueClosure
 266 static inline void
 267 QueueClosure(closure)
 268 StgClosure *closure;
 269 {
 270   if(clq_size < RTS_PACK_BUFFER_SIZE ) {
 271     IF_PAR_DEBUG(paranoia,
 272                  belch(">__> <<%d>> Q: %p (%s); %d elems in q",
 273                        globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
 274     ClosureQueue[clq_size++] = closure;
 275   } else {
 276     barf("Closure Queue Overflow (EnQueueing %p (%s))",
 277          closure, info_type(closure));
 278   }
 279 }
 280
 281 /* DeQueueClosure returns the head of the closure queue. */
 282
 283 //@cindex DeQueueClosure
 284 static inline StgClosure *
 285 DeQueueClosure(void)
 286 {
 287   if(!QueueEmpty()) {
 288     IF_PAR_DEBUG(paranoia,
 289                  belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
 290                        globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]),
 291                        clq_size-clq_pos));
 292     return(ClosureQueue[clq_pos++]);
 293   } else {
 294     return((StgClosure*)NULL);
 295   }
 296 }
 297
 298 /* DeQueueClosure returns the head of the closure queue. */
 299
 300 #if defined(DEBUG)
 301 //@cindex PrintQueueClosure
 302 static void
 303 PrintQueueClosure(void)
 304 {
 305   nat i;
 306
 307   fputs("Closure queue:", stderr);
 308   for (i=clq_pos; i < clq_size; i++)
 309     fprintf(stderr, "%p (%s), ",
 310             (StgClosure *)ClosureQueue[clq_pos++],
 311             info_type(ClosureQueue[clq_pos++]));
 312   fputc('\n', stderr);
 313 }
 314 #endif
 315
 316 //@node Types of Global Addresses,  , Basic routines, ADT of Closure Queues
 317 //@subsubsection Types of Global Addresses
 318
 319 /*
 320   Types of Global Addresses
 321
 322   These routines determine whether a GA is one of a number of special types
 323   of GA.
 324 */
 325
 326 # if defined(PAR)
 327 //@cindex isOffset
 328 static inline rtsBool
 329 isOffset(globalAddr *ga)
 330 {
 331     return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
 332 }
 333
 334 //@cindex isFixed
 335 static inline rtsBool
 336 isFixed(globalAddr *ga)
 337 {
 338     return (ga->weight == 0U);
 339 }
 340
 341 //@cindex isConstr
 342 static inline rtsBool
 343 isConstr(globalAddr *ga)
 344 {
 345     return (ga->weight == 2U);
 346 }
 347
 348 //@cindex isUnglobalised
 349 static inline rtsBool
 350 isUnglobalised(globalAddr *ga)
 351 {
 352     return (ga->weight == 2U);
 353 }
 354 # endif
 355
 356 //@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
 357 //@subsection Initialisation for packing
 358 /*
 359   Simple Packing Routines
 360
 361   About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
 362   gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
 363   words.  In the simulated PackBuffer we only keep the addresses of the
 364   closures that would be packed in the parallel system (see Pack). To
 365   decide if a packet overflow occurs pack_buffer_size must be compared
 366   versus unpacked_size (see RoomToPack).  Currently, there is no multi
 367   packet strategy implemented, so in the case of an overflow we just stop
 368   adding closures to the closure queue.  If an overflow of the simulated
 369   packet occurs, we just realloc some more space for it and carry on as
 370   usual.  -- HWL
 371 */
 372
 373 # if defined(GRAN)
 374 rtsPackBuffer *
 375 InstantiatePackBuffer (void) {
 376   extern rtsPackBuffer *globalPackBuffer;
 377
 378   globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
 379                          "InstantiatePackBuffer: failed to alloc packBuffer");
 380   globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
 381   globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
 382                                  "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
 383   /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
 384   /* stgMallocWords is now simple allocate in Storage.c */
 385
 386   return (globalPackBuffer);
 387 }
 388
 389 /*
 390    Reallocate the GranSim internal pack buffer to make room for more closure
 391    pointers. This is independent of the check for packet overflow as in GUM
 392 */
 393 static void
 394 reallocPackBuffer (void) {
 395
 396   ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
 397
 398   IF_GRAN_DEBUG(packBuffer,
 399                 belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
 400                       globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
 401                       CurrentProc, CurrentTime[CurrentProc]));
 402
 403   globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer,
 404                                   sizeof(StgClosure*)*(REALLOC_SZ +
 405                                                        (int)globalPackBuffer->size +
 406                                                        sizeofW(rtsPackBuffer))) ;
 407   if (globalPackBuffer==(rtsPackBuffer*)NULL)
 408     barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n",
 409          REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
 410
 411   globalPackBuffer->size += REALLOC_SZ;
 412
 413   ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
 414 }
 415 # endif
 416
 417 # if defined(PAR)
 418 /* @initPacking@ initialises the packing buffer etc. */
 419 //@cindex InitPackBuffer
 420 rtsBool
 421 InitPackBuffer(void)
 422 {
 423   if (globalPackBuffer==(rtsPackBuffer*)NULL) {
 424     if ((globalPackBuffer = (rtsPackBuffer *)
 425          stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
 426                         "InitPackBuffer")) == NULL)
 427       return rtsFalse;
 428   }
 429   return rtsTrue;
 430 }
 431
 432 # endif
 433 //@cindex InitPacking
 434 static void
 435 InitPacking(rtsBool unpack)
 436 {
 437 # if defined(GRAN)
 438   globalPackBuffer = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
 439                                        /* NB: free in UnpackGraph */
 440 # elif defined(PAR)
 441   if (unpack) {
 442     /* allocate a GA-to-GA map (needed for ACK message) */
 443     InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
 444   } else {
 445     /* allocate memory to pack the graph into */
 446     InitPackBuffer();
 447   }
 448 # endif
 449   /* init queue of closures seen during packing */
 450   InitClosureQueue();
 451
 452   if (unpack)
 453     return;
 454
 455   globalPackBuffer->id = buf_id++;  /* buffer id are only used for debugging! */
 456   pack_locn = 0;         /* the index into the actual pack buffer */
 457   unpacked_size = 0;     /* the size of the whole graph when unpacked */
 458   roomInBuffer = rtsTrue;
 459   packed_thunks = 0;   /* total number of thunks packed so far */
 460 # if defined(PAR)
 461   offsetTable = allocHashTable();
 462 # endif
 463 }
 464
 465 //@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
 466 //@subsection Packing Functions
 467
 468 //@menu
 469 //* Packing Sections of Nearby Graph::
 470 //* Packing Closures::
 471 //@end menu
 472
 473 //@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
 474 //@subsubsection Packing Sections of Nearby Graph
 475 /*
 476   Packing Sections of Nearby Graph
 477
 478   @PackNearbyGraph@ packs a closure and associated graph into a static
 479   buffer (@PackBuffer@).  It returns the address of this buffer and the
 480   size of the data packed into the buffer (in its second parameter,
 481   @packBufferSize@).  The associated graph is packed in a depth first
 482   manner, hence it uses an explicit queue of closures to be packed rather
 483   than simply using a recursive algorithm.  Once the packet is full,
 484   closures (other than primitive arrays) are packed as FetchMes, and their
 485   children are not queued for packing.  */
 486
 487 //@cindex PackNearbyGraph
 488
 489 /* NB: this code is shared between GranSim and GUM;
 490        tso only used in GranSim */
 491 rtsPackBuffer *
 492 PackNearbyGraph(closure, tso, packBufferSize, dest)
 493 StgClosure* closure;
 494 StgTSO* tso;
 495 nat *packBufferSize;
 496 GlobalTaskId dest;
 497 {
 498   IF_PAR_DEBUG(resume,
 499                graphFingerPrint[0] = '\0');
 500
 501   ASSERT(RTS_PACK_BUFFER_SIZE > 0);
 502   ASSERT(_HS==1);  // HWL HACK; compile time constant
 503
 504 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
 505   PAR_TICKY_PACK_NEARBY_GRAPH_START();
 506 #endif
 507
 508   /* ToDo: check that we have enough heap for the packet
 509      ngoq ngo'
 510      if (Hp + PACK_HEAP_REQUIRED > HpLim)
 511      return NULL;
 512   */
 513   InitPacking(rtsFalse);
 514 # if defined(PAR)
 515   dest_gtid=dest; //-1 to disable
 516 # elif defined(GRAN)
 517   graph_root = closure;
 518 # endif
 519
 520   IF_GRAN_DEBUG(pack,
 521                 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n    demanded by TSO %d (%p) [PE %u]",
 522                       globalPackBuffer->id, globalPackBuffer, closure, where_is(closure),
 523                       tso->id, tso, where_is((StgClosure*)tso)));
 524
 525   IF_GRAN_DEBUG(pack,
 526                 belch("** PrintGraph of %p is:", closure);
 527                 PrintGraph(closure,0));
 528
 529   IF_PAR_DEBUG(resume,
 530                GraphFingerPrint(closure, graphFingerPrint);
 531                ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
 532                belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n    demanded by TSO %d (%p); Finger-print is\n    {%s}",
 533                      globalPackBuffer->id, globalPackBuffer, closure, mytid,
 534                      tso->id, tso, graphFingerPrint));
 535
 536   IF_PAR_DEBUG(packet,
 537                belch("** PrintGraph of %p is:", closure);
 538                belch("** pack_locn=%d", pack_locn);
 539                PrintGraph(closure,0));
 540
 541   QueueClosure(closure);
 542   do {
 543     PackClosure(DeQueueClosure());
 544   } while (!QueueEmpty());
 545
 546 # if defined(PAR)
 547
 548   /* Record how much space the graph needs in packet and in heap */
 549   globalPackBuffer->tso = tso;       // currently unused, I think (debugging?)
 550   globalPackBuffer->unpacked_size = unpacked_size;
 551   globalPackBuffer->size = pack_locn;
 552
 553   /* Check for buffer overflow (again) */
 554   ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
 555   IF_DEBUG(sanity,                           // write magic end-of-buffer word
 556            globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
 557   *packBufferSize = pack_locn;
 558
 559 # else  /* GRAN */
 560
 561   /* Record how much space is needed to unpack the graph */
 562   // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;  for testing
 563   globalPackBuffer->tso = tso;
 564   globalPackBuffer->unpacked_size = unpacked_size;
 565
 566   // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
 567   /* ToDo: Print an earlier, more meaningful message */
 568   if (pack_locn==0)   /* i.e. packet is empty */
 569     barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
 570          closure);
 571   globalPackBuffer->size = pack_locn;
 572   *packBufferSize = pack_locn;
 573
 574 # endif
 575
 576   DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */
 577
 578 # if defined(GRAN)
 579   IF_GRAN_DEBUG(pack ,
 580                 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
 581                       globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
 582   if (RtsFlags.GranFlags.GranSimStats.Global) {
 583     globalGranStats.tot_packets++;
 584     globalGranStats.tot_packet_size += pack_locn;
 585   }
 586
 587   IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
 588 # elif defined(PAR)
 589   IF_PAR_DEBUG(packet,
 590                 belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
 591                       globalPackBuffer->id, closure, info_type(closure),
 592                       globalPackBuffer->size, packed_thunks,
 593                       globalPackBuffer->unpacked_size));;
 594
 595   IF_DEBUG(sanity, // do a sanity check on the packet just constructed
 596            checkPacket(globalPackBuffer));
 597 # endif   /* GRAN */
 598
 599 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
 600   PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
 601 #endif
 602
 603   return (globalPackBuffer);
 604 }
 605
 606 //@cindex PackOneNode
 607
 608 # if defined(GRAN)
 609 /* This version is used when the node is already local */
 610
 611 rtsPackBuffer *
 612 PackOneNode(closure, tso, packBufferSize)
 613 StgClosure* closure;
 614 StgTSO* tso;
 615 nat *packBufferSize;
 616 {
 617   extern rtsPackBuffer *globalPackBuffer;
 618   int i, clpack_locn;
 619
 620   InitPacking(rtsFalse);
 621
 622   IF_GRAN_DEBUG(pack,
 623                 belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
 624                       closure, info_type(closure),
 625                       where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
 626
 627   Pack(closure);
 628
 629   /* Record how much space is needed to unpack the graph */
 630   globalPackBuffer->tso = tso;
 631   globalPackBuffer->unpacked_size = unpacked_size;
 632
 633   /* Set the size parameter */
 634   ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
 635   globalPackBuffer->size =  pack_locn;
 636   *packBufferSize = pack_locn;
 637
 638   if (RtsFlags.GranFlags.GranSimStats.Global) {
 639     globalGranStats.tot_packets++;
 640     globalGranStats.tot_packet_size += pack_locn;
 641   }
 642   IF_GRAN_DEBUG(pack,
 643     PrintPacket(globalPackBuffer));
 644
 645   return (globalPackBuffer);
 646 }
 647 # endif  /* GRAN */
 648
 649 #if defined(GRAN)
 650
 651 /*
 652    PackTSO and PackStkO are entry points for two special kinds of closure
 653    which are used in the parallel RTS.  Compared with other closures they
 654    are rather awkward to pack because they don't follow the normal closure
 655    layout (where all pointers occur before all non-pointers).  Luckily,
 656    they're only needed when migrating threads between processors.  */
 657
 658 //@cindex PackTSO
 659 rtsPackBuffer*
 660 PackTSO(tso, packBufferSize)
 661 StgTSO *tso;
 662 nat *packBufferSize;
 663 {
 664   extern rtsPackBuffer *globalPackBuffer;
 665   IF_GRAN_DEBUG(pack,
 666                 belch("** Packing TSO %d (%p)", tso->id, tso));
 667   *packBufferSize = 0;
 668   // PackBuffer[0] = PackBuffer[1] = 0; ???
 669   return(globalPackBuffer);
 670 }
 671
 672 //@cindex PackStkO
 673 static rtsPackBuffer*
 674 PackStkO(stko, packBufferSize)
 675 StgPtr stko;
 676 nat *packBufferSize;
 677 {
 678   extern rtsPackBuffer *globalPackBuffer;
 679   IF_GRAN_DEBUG(pack,
 680                 belch("** Packing STKO %p", stko));
 681   *packBufferSize = 0;
 682   // PackBuffer[0] = PackBuffer[1] = 0;
 683   return(globalPackBuffer);
 684 }
 685
 686 static void
 687 PackFetchMe(StgClosure *closure)
 688 {
 689   barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
 690 }
 691
 692 #elif defined(PAR)
 693
 694 static rtsPackBuffer*
 695 PackTSO(tso, packBufferSize)
 696 StgTSO *tso;
 697 nat *packBufferSize;
 698 {
 699   barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
 700        tso->id, tso, packBufferSize);
 701 }
 702
 703 rtsPackBuffer*
 704 PackStkO(stko, packBufferSize)
 705 StgPtr stko;
 706 nat *packBufferSize;
 707 {
 708   barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
 709        stko, packBufferSize);
 710 }
 711
 712 //@cindex PackFetchMe
 713 static void
 714 PackFetchMe(StgClosure *closure)
 715 {
 716   StgInfoTable *ip;
 717   nat i;
 718   int offset;
 719 #if defined(DEBUG)
 720   nat x = pack_locn;
 721 #endif
 722
 723 #if defined(GRAN)
 724   barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
 725 #else
 726   offset = OffsetFor(closure);
 727   if (!NotYetPacking(offset)) {
 728     IF_PAR_DEBUG(pack,
 729                  belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
 730                        closure, info_type(closure), offset));
 731     PackOffset(offset);
 732     // unpacked_size += 0;   // unpacked_size unchanged (closure is shared!!)
 733     return;
 734   }
 735
 736   /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
 737   AmPacking(closure);
 738   /* FMs must be always globalised */
 739   GlobaliseAndPackGA(closure);
 740
 741   IF_PAR_DEBUG(pack,
 742                belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
 743                      closure, info_type(closure),
 744                      globalPackBuffer->buffer[pack_locn-2],
 745                      globalPackBuffer->buffer[pack_locn-1],
 746                      globalPackBuffer->buffer[pack_locn-3]));
 747
 748   /* Pack a FetchMe closure instead of closure */
 749   ip = &stg_FETCH_ME_info;
 750   /* this assumes that the info ptr is always the first word in a closure*/
 751   Pack((StgWord)ip);
 752   for (i = 1; i < _HS; ++i)               // pack rest of fixed header
 753     Pack((StgWord)*(((StgPtr)closure)+i));
 754
 755   unpacked_size += sizeofW(StgFetchMe);
 756   /* size of FETCHME in packed is the same as that constant */
 757   ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
 758   /* In the pack buffer the pointer to a GA (in the FetchMe closure)
 759      is expanded to the full GA; this is a compile-time const */
 760   //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
 761 #endif
 762 }
 763
 764 #endif
 765
 766 #ifdef DIST
 767 static void
 768 PackRemoteRef(StgClosure *closure)
 769 {
 770   StgInfoTable *ip;
 771   nat i;
 772   int offset;
 773
 774   offset = OffsetFor(closure);
 775   if (!NotYetPacking(offset)) {
 776     PackOffset(offset);
 777     unpacked_size += 2;
 778     return;
 779   }
 780
 781   /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
 782   AmPacking(closure);
 783
 784   /* basically we just Globalise, but for sticky things we can't have multiple GAs,
 785      so we must prevent the GAs being split.
 786
 787      In returning things to the true sticky owner, this case is already handled, but for
 788      anything else we just give up at the moment... This needs to be fixed!
 789   */
 790   { globalAddr *ga;
 791     ga = LAGAlookup(closure); // surely this ga must exist?
 792
 793     // ***************************************************************************
 794     // ***************************************************************************
 795     // REMOTE_REF HACK - dual is in SetGAandCommonUp
 796     // - prevents the weight from ever reaching zero
 797     if(ga != NULL)
 798       ga->weight=0x06660666; //anything apart from 0 really...
 799     // ***************************************************************************
 800     // ***************************************************************************
 801
 802     if((ga != NULL)&&(ga->weight / 2 <= 2))
 803       barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
 804                 closure, info_type(closure),
 805                 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);
 806   }
 807   GlobaliseAndPackGA(closure);
 808
 809   IF_PAR_DEBUG(pack,
 810                belch("*>.. Packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
 811                      closure, info_type(closure),
 812                      globalPackBuffer->buffer[pack_locn-2],
 813                      globalPackBuffer->buffer[pack_locn-1],
 814                      globalPackBuffer->buffer[pack_locn-3]));
 815
 816   /* Pack a REMOTE_REF closure instead of closure */
 817   ip = &stg_REMOTE_REF_info;
 818   /* this assumes that the info ptr is always the first word in a closure*/
 819   Pack((StgWord)ip);
 820   for (i = 1; i < _HS; ++i)               // pack rest of fixed header
 821     Pack((StgWord)*(((StgPtr)closure)+i));
 822
 823   unpacked_size += PACK_FETCHME_SIZE;
 824 }
 825 #endif /* DIST */
 826
 827 //@node Packing Closures,  , Packing Sections of Nearby Graph, Packing Functions
 828 //@subsubsection Packing Closures
 829 /*
 830   Packing Closures
 831
 832   @PackClosure@ is the heart of the normal packing code.  It packs a single
 833   closure into the pack buffer, skipping over any indirections and
 834   globalising it as necessary, queues any child pointers for further
 835   packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
 836   locally if it was a thunk.  Before the actual closure is packed, a
 837   suitable global address (GA) is inserted in the pack buffer.  There is
 838   always room to pack a fetch-me to the closure (guaranteed by the
 839   RoomToPack calculation), and this is packed if there is no room for the
 840   entire closure.
 841
 842   Space is allocated for any primitive array children of a closure, and
 843   hence a primitive array can always be packed along with it's parent
 844   closure.  */
 845
 846 //@cindex PackClosure
 847
 848 # if defined(PAR)
 849
 850 void
 851 PackClosure(closure)
 852 StgClosure *closure;
 853 {
 854   StgInfoTable *info;
 855   nat clpack_locn;
 856
 857   ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
 858
 859   closure = UNWIND_IND(closure);
 860   /* now closure is the thing we want to pack */
 861   info = get_itbl(closure);
 862
 863   clpack_locn = OffsetFor(closure);
 864
 865   /* If the closure has been packed already, just pack an indirection to it
 866      to guarantee that the graph doesn't become a tree when unpacked */
 867   if (!NotYetPacking(clpack_locn)) {
 868     PackOffset(clpack_locn);
 869     return;
 870   }
 871
 872   switch (info->type) {
 873
 874   case CONSTR_CHARLIKE:
 875     IF_PAR_DEBUG(pack,
 876                  belch("*>^^ Packing a charlike closure %d",
 877                        ((StgIntCharlikeClosure*)closure)->data));
 878
 879     PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
 880     // NB: unpacked_size of a PLC is 0
 881     return;
 882
 883   case CONSTR_INTLIKE:
 884     {
 885       StgInt val = ((StgIntCharlikeClosure*)closure)->data;
 886
 887       if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 888         IF_PAR_DEBUG(pack,
 889                      belch("*>^^ Packing a small intlike %d as a PLC",
 890                            val));
 891         PackPLC((StgPtr)INTLIKE_CLOSURE(val));
 892         // NB: unpacked_size of a PLC is 0
 893         return;
 894       } else {
 895         IF_PAR_DEBUG(pack,
 896                      belch("*>^^ Packing a big intlike %d as a normal closure",
 897                            val));
 898         PackGeneric(closure);
 899         return;
 900       }
 901     }
 902
 903   case CONSTR:
 904   case CONSTR_1_0:
 905   case CONSTR_0_1:
 906   case CONSTR_2_0:
 907   case CONSTR_1_1:
 908   case CONSTR_0_2:
 909     /* it's a constructor (i.e. plain data) */
 910     IF_PAR_DEBUG(pack,
 911                  belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
 912                        closure, info_type(closure)));
 913     PackGeneric(closure);
 914     return;
 915
 916   case THUNK_STATIC:       // ToDo: check whether that's ok
 917   case FUN_STATIC:       // ToDo: check whether that's ok
 918   case CONSTR_STATIC:
 919   case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
 920                            // evaluated on each PE if needed
 921     IF_PAR_DEBUG(pack,
 922                  belch("*>~~ Packing a %p (%s) as a PLC",
 923                        closure, info_type(closure)));
 924
 925     PackPLC((StgPtr)closure);
 926     // NB: unpacked_size of a PLC is 0
 927     return;
 928
 929   case THUNK_SELECTOR:
 930     {
 931       StgClosure *selectee = ((StgSelector *)closure)->selectee;
 932
 933       IF_PAR_DEBUG(pack,
 934                    belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
 935                          closure, info_type(closure),
 936                          selectee, info_type(selectee)));
 937       PackGeneric(closure);
 938       /* inlined code; probably could use PackGeneric
 939       Pack((StgWord)(*(StgPtr)closure));
 940       Pack((StgWord)(selectee));
 941       QueueClosure(selectee);
 942       unpacked_size += 2;
 943       */
 944     }
 945     return;
 946
 947   case  FUN:
 948   case  FUN_1_0:
 949   case  FUN_0_1:
 950   case  FUN_2_0:
 951   case  FUN_1_1:
 952   case  FUN_0_2:
 953   case  THUNK:
 954   case  THUNK_1_0:
 955   case  THUNK_0_1:
 956   case  THUNK_2_0:
 957   case  THUNK_1_1:
 958   case  THUNK_0_2:
 959     PackGeneric(closure);
 960     return;
 961
 962   case AP_UPD:
 963   case PAP:
 964     /*
 965     barf("*>   Packing of PAP not implemented %p (%s)",
 966                        closure, info_type(closure));
 967
 968        Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
 969        instead. Note that since PAPs contain a chunk of stack as payload,
 970        implementing packing of PAPs is a first step towards thread migration.
 971     IF_PAR_DEBUG(pack,
 972                  belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
 973                        closure, info_type(closure)));
 974     PackFetchMe(closure);
 975     */
 976     PackPAP((StgPAP *)closure);
 977     return;
 978
 979   case CAF_BLACKHOLE:
 980   case BLACKHOLE:
 981   case BLACKHOLE_BQ:
 982   case SE_BLACKHOLE:
 983   case SE_CAF_BLACKHOLE:
 984   case RBH:
 985   case FETCH_ME:
 986   case FETCH_ME_BQ:
 987
 988     /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
 989     //ASSERT(pack_locn > PACK_HDR_SIZE);
 990
 991     IF_PAR_DEBUG(pack,
 992                  belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
 993                        closure, info_type(closure)));
 994     /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
 995            phps short-cut the GA here */
 996     PackFetchMe(closure);
 997     return;
 998
 999 #ifdef DIST
1000   case REMOTE_REF:
1001     IF_PAR_DEBUG(pack,
1002                  belch("*>.. Packing %p (%s) as a REMOTE_REF",
1003                        closure, info_type(closure)));
1004     PackRemoteRef(closure);
1005     /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
1006
1007     return;
1008 #endif
1009
1010   case TSO:
1011   case MVAR:
1012 #ifdef DIST
1013           IF_PAR_DEBUG(pack,
1014                  belch("*>.. Packing %p (%s) as a RemoteRef",
1015                        closure, info_type(closure)));
1016     PackRemoteRef(closure);
1017 #else
1018     barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)",
1019          closure, info_type(closure));
1020 #endif
1021     return;
1022
1023   case ARR_WORDS:
1024     PackArray(closure);
1025     return;
1026
1027   case MUT_ARR_PTRS:
1028   case MUT_ARR_PTRS_FROZEN:
1029   case MUT_VAR:
1030     /*
1031        Eventually, this should use the same packing routine as ARR_WRODS
1032
1033        GlobaliseAndPackGA(closure);
1034        PackArray(closure);
1035        return;
1036     */
1037     barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
1038          closure, info_type(closure));
1039
1040 #  ifdef DEBUG
1041   case BCO:
1042     barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
1043          closure, info_type(closure));
1044     /* never reached */
1045
1046     // check error cases only in a debugging setup
1047   case RET_BCO:
1048   case RET_SMALL:
1049   case RET_VEC_SMALL:
1050   case RET_BIG:
1051   case RET_VEC_BIG:
1052   case RET_DYN:
1053     barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
1054          closure, info_type(closure));
1055     /* never reached */
1056
1057   case UPDATE_FRAME:
1058   case STOP_FRAME:
1059   case CATCH_FRAME:
1060   case SEQ_FRAME:
1061     barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
1062          closure, info_type(closure));
1063     /* never reached */
1064
1065   case BLOCKED_FETCH:
1066   case EVACUATED:
1067     /* something's very wrong */
1068     barf("{Pack}Daq Qagh: found %s (%p) when packing",
1069          info_type(closure), closure);
1070     /* never reached */
1071
1072   case IND:
1073   case IND_OLDGEN:
1074   case IND_PERM:
1075   case IND_OLDGEN_PERM:
1076   case IND_STATIC:
1077     barf("Pack: found IND_... after shorting out indirections %d (%s)",
1078          (nat)(info->type), info_type(closure));
1079
1080   case WEAK:
1081   case FOREIGN:
1082   case STABLE_NAME:
1083     barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
1084          (nat)(info->type), info_type(closure));
1085 #endif
1086
1087   default:
1088     barf("Pack: strange closure %d", (nat)(info->type));
1089   } /* switch */
1090 }
1091
1092 /*
1093   Pack a constructor of unknown size.
1094   Similar to PackGeneric but without creating GAs.
1095 */
1096 #if 0
1097 //@cindex PackConstr
1098 static void
1099 PackConstr(StgClosure *closure)
1100 {
1101   StgInfoTable *info;
1102   nat size, ptrs, nonptrs, vhs, i;
1103   char str[80];
1104
1105   ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
1106
1107   /* get info about basic layout of the closure */
1108   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1109
1110   ASSERT(info->type == CONSTR ||
1111          info->type == CONSTR_1_0 ||
1112          info->type == CONSTR_0_1 ||
1113          info->type == CONSTR_2_0 ||
1114          info->type == CONSTR_1_1 ||
1115          info->type == CONSTR_0_2);
1116
1117   IF_PAR_DEBUG(pack,
1118                fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1119                        closure, info_type(closure), size, ptrs, nonptrs));
1120
1121   /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1122
1123   if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1124     IF_PAR_DEBUG(pack,
1125                  belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1126                        closure, info_type(closure)));
1127     PackFetchMe(closure);
1128     return;
1129   }
1130
1131   /* Record the location of the GA */
1132   AmPacking(closure);
1133
1134   /* Pack Constructor marker */
1135   Pack((StgWord)2);
1136
1137   /* pack fixed and variable header */
1138   for (i = 0; i < _HS + vhs; ++i)
1139     Pack((StgWord)*(((StgPtr)closure)+i));
1140
1141   /* register all ptrs for further packing */
1142   for (i = 0; i < ptrs; ++i)
1143     QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1144
1145   /* pack non-ptrs */
1146   for (i = 0; i < nonptrs; ++i)
1147     Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1148 }
1149 #endif
1150
1151 /*
1152   Generic packing code.
1153   This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
1154 */
1155 //@cindex PackGeneric
1156 static void
1157 PackGeneric(StgClosure *closure)
1158 {
1159   StgInfoTable *info;
1160   StgClosure *rbh;
1161   nat size, ptrs, nonptrs, vhs, i, m;
1162   char str[80];
1163
1164   ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
1165
1166   /* get info about basic layout of the closure */
1167   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1168
1169   ASSERT(!IS_BLACK_HOLE(closure));
1170
1171   IF_PAR_DEBUG(pack,
1172                fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
1173                        closure, info_type(closure), size, ptrs, nonptrs));
1174
1175   /* packing strategies: how many thunks to add to a packet;
1176      default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
1177   if (RtsFlags.ParFlags.thunksToPack &&
1178       packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
1179       closure_THUNK(closure)) {
1180     IF_PAR_DEBUG(pack,
1181                  belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
1182                        packed_thunks, closure, info_type(closure)));
1183     PackFetchMe(closure);
1184     return;
1185   }
1186
1187   /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1188
1189   if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1190     IF_PAR_DEBUG(pack,
1191                  belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1192                        closure, info_type(closure)));
1193     PackFetchMe(closure);
1194     return;
1195   }
1196
1197   /* Record the location of the GA */
1198   AmPacking(closure);
1199   /* Allocate a GA for this closure and put it into the buffer */
1200   /* Checks for globalisation scheme; default: globalise everything thunks */
1201   if ( RtsFlags.ParFlags.globalising == 0 ||
1202        (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1203     GlobaliseAndPackGA(closure);
1204   else
1205     Pack((StgWord)2);  // marker for unglobalised closure
1206
1207
1208   ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1209            info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1210
1211   /* At last! A closure we can actually pack! */
1212   if (ip_MUTABLE(info) && ((info->type != FETCH_ME)||(info->type != REMOTE_REF)))
1213     barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
1214          closure, info_type(closure));
1215
1216   /*
1217      Remember, the generic closure layout is as follows:
1218         +-------------------------------------------------+
1219         | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1220         +-------------------------------------------------+
1221   */
1222   /* pack fixed and variable header */
1223   for (i = 0; i < _HS + vhs; ++i)
1224     Pack((StgWord)*(((StgPtr)closure)+i));
1225
1226   /* register all ptrs for further packing */
1227   for (i = 0; i < ptrs; ++i)
1228     QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1229
1230   /* pack non-ptrs */
1231   for (i = 0; i < nonptrs; ++i)
1232     Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1233
1234   // ASSERT(_HS+vhs+ptrs+nonptrs==size);
1235   if ((m=_HS+vhs+ptrs+nonptrs)<size) {
1236     IF_PAR_DEBUG(pack,
1237                  belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
1238                        closure, info_type(closure), size-m));
1239     for (i=m; i<size; i++)
1240       Pack((StgWord)*(((StgPtr)closure)+i));
1241   }
1242
1243   unpacked_size += size;
1244   //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1245
1246   /*
1247    * Record that this is a revertable black hole so that we can fill in
1248    * its address from the fetch reply.  Problem: unshared thunks may cause
1249    * space leaks this way, their GAs should be deallocated following an
1250    * ACK.
1251    */
1252
1253   if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
1254     rbh = convertToRBH(closure);
1255     ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
1256     ASSERT(rbh == closure);         // rbh at the same position (minced version)
1257     packed_thunks++;
1258   } else if ( closure==graph_root ) {
1259     packed_thunks++;                // root of graph is counted as a thunk
1260   }
1261 }
1262 /*
1263   Pack an array of words.
1264   ToDo: implement packing of MUT_ARRAYs
1265 */
1266
1267 //@cindex PackArray
1268 static void
1269 PackArray(StgClosure *closure)
1270 {
1271   StgInfoTable *info;
1272   nat size, ptrs, nonptrs, vhs;
1273   nat i, n;
1274   char str[80];
1275
1276   /* get info about basic layout of the closure */
1277   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1278
1279   ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1280          info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
1281
1282   n = ((StgArrWords *)closure)->words;
1283   // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
1284
1285   IF_PAR_DEBUG(pack,
1286                belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
1287                      closure, info_type(closure), n,
1288                      arr_words_sizeW((StgArrWords *)closure)));
1289
1290   /* check that we have enough room in the pack buffer */
1291   if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1292     IF_PAR_DEBUG(pack,
1293                  belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1294                        closure, info_type(closure)));
1295     PackFetchMe(closure);
1296     return;
1297   }
1298
1299   /* global stats about arrays sent */
1300   if (RtsFlags.ParFlags.ParStats.Global &&
1301       RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
1302     globalParStats.tot_arrs++;
1303     globalParStats.tot_arr_size += ((StgArrWords *)closure)->words;
1304   }
1305
1306   /* record offset of the closure and allocate a GA */
1307   AmPacking(closure);
1308   /* Checks for globalisation scheme; default: globalise everything thunks */
1309   if ( RtsFlags.ParFlags.globalising == 0 ||
1310        (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1311     GlobaliseAndPackGA(closure);
1312   else
1313     Pack((StgWord)2);  // marker for unglobalised closure
1314
1315   /* Pack the header (2 words: info ptr and the number of words to follow) */
1316   Pack((StgWord)*(StgPtr)closure);
1317   Pack(((StgArrWords *)closure)->words);
1318
1319   /* pack the payload of the closure (all non-ptrs) */
1320   for (i=0; i<n; i++)
1321     Pack((StgWord)((StgArrWords *)closure)->payload[i]);
1322
1323   unpacked_size += arr_words_sizeW((StgArrWords *)closure);
1324 }
1325
1326 /*
1327    Pack a PAP closure.
1328    Note that the representation of a PAP in the buffer is different from
1329    its representation in the heap. In particular, pointers to local
1330    closures are packed directly as FETCHME closures, using
1331    PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
1332    structure. To account for the difference in size we store the packed
1333    size of the closure as part of the PAP's variable header in the buffer.
1334 */
1335
1336 //@cindex PackPAP
1337 static void
1338 PackPAP(StgPAP *pap) {
1339   nat n, i, j, pack_start;
1340   StgPtr p, q;
1341   const StgInfoTable* info;
1342   StgWord bitmap;
1343   /* debugging only */
1344   StgPtr end;
1345   nat size, ptrs, nonptrs, vhs;
1346   char str[80];
1347   nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
1348
1349   /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
1350   //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
1351   ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
1352   IF_DEBUG(sanity,
1353            unpacked_size_before_PAP = unpacked_size);
1354
1355   n = (nat)(pap->n_args);
1356
1357   /* get info about basic layout of the closure */
1358   info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
1359   ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
1360
1361   IF_PAR_DEBUG(pack,
1362                belch("*>**  %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:",
1363                      (StgClosure *)pap, info_type((StgClosure *)pap),
1364                      n, size, ptrs, nonptrs);
1365                printClosure((StgClosure *)pap));
1366
1367   /* check that we have enough room in the pack buffer */
1368   if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1369     IF_PAR_DEBUG(pack,
1370                  belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1371                        (StgClosure *)pap, info_type((StgClosure *)pap)));
1372     PackFetchMe((StgClosure *)pap);
1373     return;
1374   }
1375
1376   /* record offset of the closure and allocate a GA */
1377   AmPacking((StgClosure *)pap);
1378   /* Checks for globalisation scheme; default: globalise everything thunks */
1379   if ( RtsFlags.ParFlags.globalising == 0 ||
1380        (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
1381     GlobaliseAndPackGA((StgClosure *)pap);
1382   else
1383     Pack((StgWord)2);  // marker for unglobalised closure
1384
1385   /* Pack the PAP header */
1386   Pack((StgWord)(pap->header.info));
1387   Pack((StgWord)(pap->n_args));
1388   Pack((StgWord)(pap->fun));
1389   pack_start = pack_locn;   // to compute size of PAP in buffer
1390   Pack((StgWord)0);    // this will be filled in later (size of PAP in buffer)
1391
1392   /* Pack the payload of a PAP i.e. a stack chunk */
1393   /* pointers to start of stack chunk */
1394   p = (StgPtr)(pap->payload);
1395   end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
1396   while (p<end) {
1397     /* the loop body has been borrowed from scavenge_stack */
1398     q = (StgPtr)*p;
1399
1400     /* If we've got a tag, pack all words in that block */
1401     if (IS_ARG_TAG((W_)q)) {   // q stands for the no. of non-ptrs to follow
1402       nat m = ARG_TAG((W_)q);      // first word after this block
1403       IF_PAR_DEBUG(pack,
1404                    belch("*>**    PackPAP @ %p: packing %d words (tagged), starting @ %p",
1405                          p, m, p));
1406       for (i=0; i<m+1; i++)
1407         Pack((StgWord)*(p+i));
1408       p += m+1;                // m words + the tag
1409       continue;
1410     }
1411
1412     /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
1413        ToDo: provide RTS flag to also pack these closures
1414     */
1415     if (! LOOKS_LIKE_GHC_INFO(q) ) {
1416       /* distinguish static closure (PLC) from other closures (FM) */
1417       switch (get_itbl((StgClosure*)q)->type) {
1418       case CONSTR_CHARLIKE:
1419         IF_PAR_DEBUG(pack,
1420                      belch("*>**    PackPAP: packing a charlike closure %d",
1421                            ((StgIntCharlikeClosure*)q)->data));
1422
1423         PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
1424         p++;
1425         break;
1426
1427       case CONSTR_INTLIKE:
1428         {
1429           StgInt val = ((StgIntCharlikeClosure*)q)->data;
1430
1431           if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
1432             IF_PAR_DEBUG(pack,
1433                          belch("*>**    PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1434             PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1435             p++;
1436             break;
1437           } else {
1438             IF_PAR_DEBUG(pack,
1439                          belch("*>**    PackPAP: Packing a ptr to a big intlike %d as a FM",
1440                                val));
1441             Pack((StgWord)(ARGTAG_MAX+1));
1442             PackFetchMe((StgClosure *)q);
1443             p++;
1444             IF_DEBUG(sanity, FMs_in_PAP++);
1445             break;
1446           }
1447         }
1448         case THUNK_STATIC:       // ToDo: check whether that's ok
1449         case FUN_STATIC:       // ToDo: check whether that's ok
1450         case CONSTR_STATIC:
1451         case CONSTR_NOCAF_STATIC:
1452           {
1453             IF_PAR_DEBUG(pack,
1454                          belch("*>**    PackPAP: packing a ptr to a %p (%s) as a PLC",
1455                                q, info_type((StgClosure *)q)));
1456
1457             PackPLC((StgPtr)q);
1458             p++;
1459             break;
1460           }
1461       default:
1462           IF_PAR_DEBUG(pack,
1463                        belch("*>**    PackPAP @ %p: packing FM to %p (%s)",
1464                              p, q, info_type((StgClosure*)q)));
1465           Pack((StgWord)(ARGTAG_MAX+1));
1466           PackFetchMe((StgClosure *)q);
1467           p++;
1468           IF_DEBUG(sanity, FMs_in_PAP++);
1469           break;
1470       }
1471       continue;
1472     }
1473
1474     /*
1475      * Otherwise, q must be the info pointer of an activation
1476      * record.  All activation records have 'bitmap' style layout
1477      * info.
1478      */
1479     info  = get_itbl((StgClosure *)p);
1480     switch (info->type) {
1481
1482       /* Dynamic bitmap: the mask is stored on the stack */
1483     case RET_DYN:
1484       IF_PAR_DEBUG(pack,
1485                    belch("*>**    PackPAP @ %p: RET_DYN",
1486                          p));
1487
1488       /* Pack the header as is */
1489       Pack((StgWord)(((StgRetDyn *)p)->info));
1490       Pack((StgWord)(((StgRetDyn *)p)->liveness));
1491       Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
1492
1493       bitmap = ((StgRetDyn *)p)->liveness;
1494       p      = (P_)&((StgRetDyn *)p)->payload[0];
1495       goto small_bitmap;
1496
1497       /* probably a slow-entry point return address: */
1498     case FUN:
1499     case FUN_STATIC:
1500       {
1501       IF_PAR_DEBUG(pack,
1502                    belch("*>**    PackPAP @ %p: FUN or FUN_STATIC",
1503                          p));
1504
1505       Pack((StgWord)(((StgClosure *)p)->header.info));
1506       p++;
1507
1508       goto follow_srt; //??
1509       }
1510
1511       /* Using generic code here; could inline as in scavenge_stack */
1512     case UPDATE_FRAME:
1513       {
1514         StgUpdateFrame *frame = (StgUpdateFrame *)p;
1515         nat type = get_itbl(frame->updatee)->type;
1516
1517         ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
1518
1519         IF_PAR_DEBUG(pack,
1520                      belch("*>**    PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
1521                            p, frame->updatee, frame->link));
1522
1523         Pack((StgWord)(frame->header.info));
1524         Pack((StgWord)(frame->link));     // ToDo: fix intra-stack pointer
1525         Pack((StgWord)(frame->updatee));  // ToDo: follow link
1526
1527         p += 3;
1528       }
1529
1530       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1531     case STOP_FRAME:
1532       {
1533         IF_PAR_DEBUG(pack,
1534                      belch("*>**    PackPAP @ %p: STOP_FRAME",
1535                            p));
1536         Pack((StgWord)((StgStopFrame *)p)->header.info);
1537         p++;
1538       }
1539
1540     case CATCH_FRAME:
1541       {
1542         IF_PAR_DEBUG(pack,
1543                      belch("*>**    PackPAP @ %p: CATCH_FRAME (handler=%p)",
1544                            p, ((StgCatchFrame *)p)->handler));
1545
1546         Pack((StgWord)((StgCatchFrame *)p)->header.info);
1547         Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
1548         Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
1549         Pack((StgWord)((StgCatchFrame *)p)->handler);
1550         p += 4;
1551       }
1552
1553     case SEQ_FRAME:
1554       {
1555         IF_PAR_DEBUG(pack,
1556                      belch("*>**    PackPAP @ %p: UPDATE_FRAME (link=%p)",
1557                            p, ((StgSeqFrame *)p)->link));
1558
1559         Pack((StgWord)((StgSeqFrame *)p)->header.info);
1560         Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
1561
1562         // ToDo: handle bitmap
1563         bitmap = info->layout.bitmap;
1564
1565         p = (StgPtr)&(((StgClosure *)p)->payload);
1566         goto small_bitmap;
1567       }
1568     case RET_BCO:
1569     case RET_SMALL:
1570     case RET_VEC_SMALL:
1571       IF_PAR_DEBUG(pack,
1572                    belch("*>**    PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
1573                          p, info->layout.bitmap));
1574
1575
1576       Pack((StgWord)((StgClosure *)p)->header.info);
1577       p++;
1578       // ToDo: handle bitmap
1579       bitmap = info->layout.bitmap;
1580       /* this assumes that the payload starts immediately after the info-ptr */
1581
1582     small_bitmap:
1583       while (bitmap != 0) {
1584         if ((bitmap & 1) == 0) {
1585           Pack((StgWord)(ARGTAG_MAX+1));
1586           PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1587           IF_DEBUG(sanity, FMs_in_PAP++);
1588         } else {
1589           Pack((StgWord)*p++);
1590         }
1591         bitmap = bitmap >> 1;
1592       }
1593
1594     follow_srt:
1595         IF_PAR_DEBUG(pack,
1596                      belch("*>--    PackPAP: nothing to do for follow_srt"));
1597       continue;
1598
1599       /* large bitmap (> 32 entries) */
1600     case RET_BIG:
1601     case RET_VEC_BIG:
1602       {
1603         StgPtr q;
1604         StgLargeBitmap *large_bitmap;
1605
1606         IF_PAR_DEBUG(pack,
1607                      belch("*>**    PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
1608                            p, info->layout.large_bitmap));
1609
1610
1611         Pack((StgWord)((StgClosure *)p)->header.info);
1612         p++;
1613
1614         large_bitmap = info->layout.large_bitmap;
1615
1616         for (j=0; j<large_bitmap->size; j++) {
1617           bitmap = large_bitmap->bitmap[j];
1618           q = p + BITS_IN(W_);
1619           while (bitmap != 0) {
1620             if ((bitmap & 1) == 0) {
1621               Pack((StgWord)(ARGTAG_MAX+1));
1622               PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1623               IF_DEBUG(sanity, FMs_in_PAP++);
1624             } else {
1625               Pack((StgWord)*p++);
1626             }
1627             bitmap = bitmap >> 1;
1628           }
1629           if (j+1 < large_bitmap->size) {
1630             while (p < q) {
1631               Pack((StgWord)(ARGTAG_MAX+1));
1632               PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1633               IF_DEBUG(sanity, FMs_in_PAP++);
1634             }
1635           }
1636         }
1637
1638         /* and don't forget to follow the SRT */
1639         goto follow_srt;
1640       }
1641
1642     default:
1643       barf("PackPAP: weird activation record found on stack (@ %p): %d",
1644            p, (int)(info->type));
1645     }
1646   }
1647   // fill in size of the PAP (only the payload!) in buffer
1648   globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1649   /*
1650     We can use the generic pap_sizeW macro to compute the size of the
1651     unpacked PAP because whenever we pack a new FETCHME as part of the
1652     PAP's payload we also adjust unpacked_size accordingly (smart, aren't we?)
1653
1654     NB: the current PAP (un-)packing code  relies on the fact that
1655     the size of the unpacked PAP + size of all unpacked FMs is the same as
1656     the size of the packed PAP!!
1657   */
1658   unpacked_size += pap_sizeW(pap); // sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
1659   IF_DEBUG(sanity,
1660            ASSERT(unpacked_size-unpacked_size_before_PAP==pap_sizeW(pap)+FMs_in_PAP*sizeofW(StgFetchMe)));
1661 }
1662 # else  /* GRAN */
1663
1664 /* Fake the packing of a closure */
1665
1666 void
1667 PackClosure(closure)
1668 StgClosure *closure;
1669 {
1670   StgInfoTable *info, *childInfo;
1671   nat size, ptrs, nonptrs, vhs;
1672   char info_hdr_ty[80];
1673   nat i;
1674   StgClosure *indirectee, *rbh;
1675   char str[80];
1676   rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
1677
1678   is_mutable = rtsFalse;
1679
1680   /* In GranSim we don't pack and unpack closures -- we just simulate
1681      packing by updating the bitmask. So, the graph structure is unchanged
1682      i.e. we don't short out indirections here. -- HWL */
1683
1684   /* Nothing to do with packing but good place to (sanity) check closure;
1685      if the closure is a thunk, it must be unique; otherwise we have copied
1686      work at some point before that which violates one of our main global
1687      assertions in GranSim/GUM */
1688   ASSERT(!closure_THUNK(closure) || is_unique(closure));
1689
1690   IF_GRAN_DEBUG(pack,
1691                 belch("**  Packing closure %p (%s)",
1692                       closure, info_type(closure)));
1693
1694   if (where_is(closure) != where_is(graph_root)) {
1695     IF_GRAN_DEBUG(pack,
1696                   belch("**   faking a FETCHME [current PE: %d, closure's PE: %d]",
1697                         where_is(graph_root), where_is(closure)));
1698
1699     /* GUM would pack a FETCHME here; simulate that by increasing the */
1700     /* unpacked size accordingly but don't pack anything -- HWL */
1701     unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
1702     return;
1703   }
1704
1705   /* If the closure's not already being packed */
1706   if (!NotYetPacking(closure))
1707     /* Don't have to do anything in GrAnSim if closure is already */
1708     /* packed -- HWL */
1709     {
1710       IF_GRAN_DEBUG(pack,
1711                     belch("**    Closure %p is already packed and omitted now!",
1712                             closure));
1713       return;
1714     }
1715
1716   switch (get_itbl(closure)->type) {
1717     /* ToDo: check for sticky bit here? */
1718     /* BH-like closures which must not be moved to another PE */
1719     case CAF_BLACKHOLE:       /* # of ptrs, nptrs: 0,2 */
1720     case SE_BLACKHOLE:        /* # of ptrs, nptrs: 0,2 */
1721     case SE_CAF_BLACKHOLE:    /* # of ptrs, nptrs: 0,2 */
1722     case BLACKHOLE:           /* # of ptrs, nptrs: 0,2 */
1723     case BLACKHOLE_BQ:        /* # of ptrs, nptrs: 1,1 */
1724     case RBH:                 /* # of ptrs, nptrs: 1,1 */
1725       /* same for these parallel specific closures */
1726     case BLOCKED_FETCH:
1727     case FETCH_ME:
1728     case FETCH_ME_BQ:
1729       IF_GRAN_DEBUG(pack,
1730         belch("**    Avoid packing BH-like closures (%p, %s)!",
1731               closure, info_type(closure)));
1732       /* Just ignore RBHs i.e. they stay where they are */
1733       return;
1734
1735     case THUNK_SELECTOR:
1736       {
1737         StgClosure *selectee = ((StgSelector *)closure)->selectee;
1738
1739         IF_GRAN_DEBUG(pack,
1740                       belch("**    Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
1741                             closure, info_type(closure), selectee, info_type(selectee)));
1742         QueueClosure(selectee);
1743         IF_GRAN_DEBUG(pack,
1744                       belch("**    [%p (%s) (Queueing closure) ....]",
1745                             selectee, info_type(selectee)));
1746       }
1747       return;
1748
1749     case CONSTR_STATIC:
1750     case CONSTR_NOCAF_STATIC:
1751                                   /* For now we ship indirections to CAFs:
1752                                    * They are evaluated on each PE if needed */
1753       IF_GRAN_DEBUG(pack,
1754         belch("**    Nothing to pack for %p (%s)!",
1755               closure, info_type(closure)));
1756       // Pack(closure); GUM only
1757       return;
1758
1759     case CONSTR_CHARLIKE:
1760     case CONSTR_INTLIKE:
1761       IF_GRAN_DEBUG(pack,
1762         belch("**    Nothing to pack for %s (%p)!",
1763               closure, info_type(closure)));
1764       // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1765       return;
1766
1767     case AP_UPD:
1768     case PAP:
1769       /* partial applications; special treatment necessary? */
1770       break;
1771
1772     case MVAR:
1773       barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1774            closure, info_type(closure));
1775
1776     case ARR_WORDS:
1777     case MUT_VAR:
1778     case MUT_ARR_PTRS:
1779     case MUT_ARR_PTRS_FROZEN:
1780       /* Mutable objects; require special treatment to ship all data */
1781       is_mutable = rtsTrue;
1782       break;
1783
1784     case WEAK:
1785     case FOREIGN:
1786     case STABLE_NAME:
1787           /* weak pointers and other FFI objects */
1788       barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1789            closure, info_type(closure));
1790
1791     case TSO:
1792       /* parallel objects */
1793       barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1794            closure, info_type(closure));
1795
1796     case BCO:
1797       /* Hugs objects (i.e. closures used by the interpreter) */
1798       barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1799            closure, info_type(closure));
1800
1801     case IND:              /* # of ptrs, nptrs: 1,0 */
1802     case IND_STATIC:       /* # of ptrs, nptrs: 1,0 */
1803     case IND_PERM:         /* # of ptrs, nptrs: 1,1 */
1804     case IND_OLDGEN:       /* # of ptrs, nptrs: 1,1 */
1805     case IND_OLDGEN_PERM:  /* # of ptrs, nptrs: 1,1 */
1806       /* we shouldn't find an indirection here, because we have shorted them
1807          out at the beginning of this functions already.
1808       */
1809       break;
1810       /* should be:
1811       barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1812            closure, info_type(closure));
1813       */
1814
1815     case UPDATE_FRAME:
1816     case CATCH_FRAME:
1817     case SEQ_FRAME:
1818     case STOP_FRAME:
1819       /* stack frames; should never be found when packing for now;
1820          once we support thread migration these have to be covered properly
1821       */
1822       barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1823            closure, info_type(closure));
1824
1825     case RET_BCO:
1826     case RET_SMALL:
1827     case RET_VEC_SMALL:
1828     case RET_BIG:
1829     case RET_VEC_BIG:
1830     case RET_DYN:
1831       /* vectored returns; should never be found when packing; */
1832       barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1833            closure, info_type(closure));
1834
1835     case INVALID_OBJECT:
1836       barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1837            closure, info_type(closure));
1838
1839     default:
1840       /*
1841          Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1842          a specialised version with wired in #ptr/#nptr info; currently
1843          we treat these specialised versions like the generic version)
1844       */
1845     }     /* switch */
1846
1847     /* Otherwise it's not Fixed */
1848
1849     info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1850     will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1851
1852     IF_GRAN_DEBUG(pack,
1853                 belch("**    Info on closure %p (%s): size=%d; ptrs=%d",
1854                       closure, info_type(closure),
1855                       size, ptrs,
1856                       (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1857
1858     // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1859     no_more_thunks_please =
1860       (RtsFlags.GranFlags.ThunksToPack>0) &&
1861       (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1862
1863     /*
1864       should be covered by get_closure_info
1865     if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1866         info->type == BLACKHOLE || info->type == RBH )
1867       size = ptrs = nonptrs = vhs = 0;
1868     */
1869     /* Now peek ahead to see whether the closure has any primitive */
1870     /* array children */
1871     /*
1872        ToDo: fix this code
1873        for (i = 0; i < ptrs; ++i) {
1874        P_ childInfo;
1875        W_ childSize, childPtrs, childNonPtrs, childVhs;
1876
1877        childInfo = get_closure_info(((StgPtrPtr) (closure))[i + _HS + vhs],
1878        &childSize, &childPtrs, &childNonPtrs,
1879        &childVhs, junk_str);
1880        if (IS_BIG_MOTHER(childInfo)) {
1881        reservedPAsize += PACK_GA_SIZE + _HS +
1882        childVhs + childNonPtrs +
1883        childPtrs * PACK_FETCHME_SIZE;
1884        PAsize += PACK_GA_SIZE + _HS + childSize;
1885        PAptrs += childPtrs;
1886        }
1887        }
1888     */
1889     /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1890      * is full and it isn't a primitive array. N.B. Primitive arrays are
1891      * always packed (because their parents index into them directly) */
1892
1893     if (IS_BLACK_HOLE(closure))
1894         /*
1895           ToDo: fix this code
1896           ||
1897           !(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)
1898           || IS_BIG_MOTHER(info)))
1899           */
1900       return;
1901
1902     /* At last! A closure we can actually pack! */
1903
1904     if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1905       belch("ghuH: Replicated a Mutable closure!");
1906
1907     if (RtsFlags.GranFlags.GranSimStats.Global &&
1908         no_more_thunks_please && will_be_rbh) {
1909       globalGranStats.tot_cuts++;
1910       if ( RtsFlags.GranFlags.Debug.pack )
1911         belch("**    PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1912                 RtsFlags.GranFlags.ThunksToPack, closure);
1913     } else if (will_be_rbh || (closure==graph_root) ) {
1914       packed_thunks++;
1915       globalGranStats.tot_thunks++;
1916     }
1917
1918     if (no_more_thunks_please && will_be_rbh)
1919       return; /* don't pack anything */
1920
1921     /* actual PACKING done here --  HWL */
1922     Pack(closure);
1923     for (i = 0; i < ptrs; ++i) {
1924       /* extract i-th pointer from closure */
1925       QueueClosure((StgClosure *)(closure->payload[i]));
1926       IF_GRAN_DEBUG(pack,
1927                     belch("**    [%p (%s) (Queueing closure) ....]",
1928                           closure->payload[i],
1929                           info_type(*stgCast(StgPtr*,((closure)->payload+(i))))));
1930                                   //^^^^^^^^^^^ payloadPtr(closure,i))));
1931     }
1932
1933     /*
1934        for packing words (GUM only) do something like this:
1935
1936        for (i = 0; i < ptrs; ++i) {
1937          Pack(payloadWord(obj,i+j));
1938        }
1939     */
1940     /* Turn thunk into a revertible black hole. */
1941     if (will_be_rbh) {
1942         rbh = convertToRBH(closure);
1943         ASSERT(rbh != NULL);
1944     }
1945 }
1946 # endif  /* PAR */
1947
1948 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1949 //@subsection Low level packing routines
1950
1951 /*
1952    @Pack@ is the basic packing routine.  It just writes a word of data into
1953    the pack buffer and increments the pack location.  */
1954
1955 //@cindex Pack
1956
1957 # if defined(PAR)
1958 static  void
1959 Pack(data)
1960 StgWord data;
1961 {
1962   ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1963   globalPackBuffer->buffer[pack_locn++] = data;
1964 }
1965 #endif
1966
1967 #if defined(GRAN)
1968 static  void
1969 Pack(closure)
1970 StgClosure *closure;
1971 {
1972   StgInfoTable *info;
1973   nat size, ptrs, nonptrs, vhs;
1974   char str[80];
1975
1976   /* This checks the size of the GrAnSim internal pack buffer. The simulated
1977      pack buffer is checked via RoomToPack (as in GUM) */
1978   if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
1979     reallocPackBuffer();
1980
1981   if (closure==(StgClosure*)NULL)
1982     belch("Qagh {Pack}Daq: Trying to pack 0");
1983   globalPackBuffer->buffer[pack_locn++] = closure;
1984   /* ASSERT: Data is a closure in GrAnSim here */
1985   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1986   // ToDo: is check for MIN_UPD_SIZE really needed? */
1987   unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1988                                         MIN_UPD_SIZE :
1989                                         size);
1990 }
1991 # endif  /* GRAN */
1992
1993 /*
1994    If a closure is local, make it global.  Then, divide its weight for
1995    export.  The GA is then packed into the pack buffer.  */
1996
1997 # if defined(PAR)
1998 //@cindex GlobaliseAndPackGA
1999 static void
2000 GlobaliseAndPackGA(closure)
2001 StgClosure *closure;
2002 {
2003   globalAddr *ga;
2004   globalAddr packGA;
2005
2006   if ((ga = LAGAlookup(closure)) == NULL) {
2007     ga = makeGlobal(closure, rtsTrue);
2008
2009     // Global statistics: increase amount of global data by closure-size
2010     if (RtsFlags.ParFlags.ParStats.Global &&
2011         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2012       StgInfoTable *info;
2013       nat size, ptrs, nonptrs, vhs, i, m; // stats only!!
2014       char str[80]; // stats only!!
2015
2016       info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
2017       globalParStats.tot_global += size;
2018     }
2019   }
2020   ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
2021
2022   if(dest_gtid==ga->payload.gc.gtid)
2023   {  packGA.payload = ga->payload;
2024      packGA.weight = 0xFFFFFFFF; // 0,1,2 are used already
2025   }
2026   else
2027   { splitWeight(&packGA, ga);
2028     ASSERT(packGA.weight > 0);
2029   }
2030
2031   IF_PAR_DEBUG(pack,
2032                fprintf(stderr, "*>## %p (%s): Globalising (%s) closure with GA ",
2033                        closure, info_type(closure),
2034                        ( (ga->payload.gc.gtid==dest_gtid)?"returning":
2035                            ( (ga->payload.gc.gtid==mytid)?"creating":"sharing" ) ));
2036                printGA(&packGA);
2037                fputc('\n', stderr));
2038
2039
2040   Pack((StgWord) packGA.weight);
2041   Pack((StgWord) packGA.payload.gc.gtid);
2042   Pack((StgWord) packGA.payload.gc.slot);
2043 }
2044
2045 /*
2046    @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
2047    address follows instead of PE, slot.  */
2048
2049 //@cindex PackPLC
2050
2051 static void
2052 PackPLC(addr)
2053 StgPtr addr;
2054 {
2055   Pack(0L);                     /* weight */
2056   Pack((StgWord) addr);         /* address */
2057 }
2058
2059 /*
2060    @PackOffset@ packs a special GA value that will be interpreted as an
2061    offset to a closure in the pack buffer.  This is used to avoid unfolding
2062    the graph structure into a tree.  */
2063
2064 static void
2065 PackOffset(offset)
2066 int offset;
2067 {
2068   /*
2069   IF_PAR_DEBUG(pack,
2070                belch("** Packing Offset %d at pack location %u",
2071                      offset, pack_locn));
2072   */
2073   Pack(1L);                     /* weight */
2074   Pack(0L);                     /* pe */
2075   Pack(offset);                 /* slot/offset */
2076 }
2077 # endif  /* PAR */
2078
2079 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
2080 //@subsection Unpacking routines
2081
2082 /*
2083   This was formerly in the (now deceased) module Unpack.c
2084
2085   Unpacking closures which have been exported to remote processors
2086
2087   This module defines routines for unpacking closures in the parallel
2088   runtime system (GUM).
2089
2090   In the case of GrAnSim, this module defines routines for *simulating* the
2091   unpacking of closures as it is done in the parallel runtime system.
2092 */
2093
2094 //@node GUM code, GranSim Code, Unpacking routines, Unpacking routines
2095 //@subsubsection GUM code
2096
2097 #if defined(PAR)
2098
2099 //@cindex InitPendingGABuffer
2100 void
2101 InitPendingGABuffer(size)
2102 nat size;
2103 {
2104   if (PendingGABuffer==(globalAddr *)NULL)
2105     PendingGABuffer = (globalAddr *)
2106       stgMallocBytes(size*2*sizeof(globalAddr),
2107                      "InitPendingGABuffer");
2108
2109   /* current location in the buffer */
2110   gaga = PendingGABuffer;
2111 }
2112
2113 /*
2114   @CommonUp@ commons up two closures which we have discovered to be
2115   variants of the same object.  One is made an indirection to the other.  */
2116
2117 //@cindex CommonUp
2118 void
2119 CommonUp(StgClosure *src, StgClosure *dst)
2120 {
2121   StgBlockingQueueElement *bqe;
2122 #if defined(DEBUG)
2123   StgInfoTable *info;
2124   nat size, ptrs, nonptrs, vhs, i;
2125   char str[80];
2126
2127   /* get info about basic layout of the closure */
2128   info = get_closure_info(src, &size, &ptrs, &nonptrs, &vhs, str);
2129 #endif
2130
2131   ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
2132   ASSERT(src != dst);
2133
2134   IF_PAR_DEBUG(pack,
2135                belch("*___  CommonUp %p (%s) --> %p (%s)",
2136                      src, info_type(src), dst, info_type(dst)));
2137
2138   switch (get_itbl(src)->type) {
2139   case BLACKHOLE_BQ:
2140     bqe = ((StgBlockingQueue *)src)->blocking_queue;
2141     break;
2142
2143   case FETCH_ME_BQ:
2144     bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
2145     break;
2146
2147   case RBH:
2148     bqe = ((StgRBH *)src)->blocking_queue;
2149     break;
2150
2151   case BLACKHOLE:
2152   case FETCH_ME:
2153     bqe = END_BQ_QUEUE;
2154     break;
2155
2156     /* These closures are too small to be updated with an indirection!!! */
2157   case CONSTR_1_0:
2158   case CONSTR_0_1:
2159     ASSERT(size<_HS+MIN_UPD_SIZE); // that's why we have to avoid UPD_IND
2160     return;
2161
2162     /* currently we also common up 2 CONSTRs; this should reduce heap
2163      * consumption but also does more work; not sure whether it's worth doing
2164      */
2165   case CONSTR:
2166   case CONSTR_2_0:
2167   case CONSTR_1_1:
2168   case CONSTR_0_2:
2169   case ARR_WORDS:
2170   case MUT_ARR_PTRS:
2171   case MUT_ARR_PTRS_FROZEN:
2172   case MUT_VAR:
2173     break;
2174
2175   default:
2176     /* Don't common up anything else */
2177     return;
2178   }
2179
2180   /* closure must be big enough to permit update with ind */
2181   ASSERT(size>=_HS+MIN_UPD_SIZE);
2182   /* NB: this also awakens the blocking queue for src */
2183   UPD_IND(src, dst);
2184 }
2185
2186 /*
2187  * Common up the new closure with any existing closure having the same
2188  * GA
2189  */
2190 //@cindex SetGAandCommonUp
2191 static StgClosure *
2192 SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
2193 {
2194   StgClosure *existing;
2195   StgInfoTable *ip, *oldip;
2196   globalAddr *newGA;
2197
2198   if (!hasGA)
2199     return closure;
2200
2201   /* should we already have a local copy? */
2202   if (ga->weight==0xFFFFFFFF) {
2203     ASSERT(ga->payload.gc.gtid==mytid); //sanity
2204     ga->weight=0;
2205     /* probably should also ASSERT that a commonUp takes place...*/
2206   }
2207
2208   ip = get_itbl(closure);
2209   if ((existing = GALAlookup(ga)) == NULL) {
2210     /* Just keep the new object */
2211     IF_PAR_DEBUG(pack,
2212                  belch("*<##  New local object for GA ((%x, %d, %x)) is %p (%s)",
2213                        ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2214                        closure, info_type(closure)));
2215
2216     // make an entry binding closure to ga in the RemoteGA table
2217     newGA = setRemoteGA(closure, ga, rtsTrue);
2218     // if local closure is a FETCH_ME etc fill in the global indirection
2219     if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
2220       ((StgFetchMe *)closure)->ga = newGA;
2221   } else {
2222
2223
2224 #ifdef DIST
2225 // ***************************************************************************
2226 // ***************************************************************************
2227 // REMOTE_REF HACK - dual is in PackRemoteRef
2228 // - prevents the weight ever being updated
2229   if (ip->type == REMOTE_REF)
2230     ga->weight=0;
2231 // ***************************************************************************
2232 // ***************************************************************************
2233 #endif /* DIST */
2234
2235     /* Two closures, one global name.  Someone loses */
2236     oldip = get_itbl(existing);
2237     if ((oldip->type == FETCH_ME ||
2238          IS_BLACK_HOLE(existing) ||
2239          /* try to share evaluated closures */
2240          oldip->type == CONSTR ||
2241          oldip->type == CONSTR_1_0 ||
2242          oldip->type == CONSTR_0_1 ||
2243          oldip->type == CONSTR_2_0 ||
2244          oldip->type == CONSTR_1_1 ||
2245          oldip->type == CONSTR_0_2
2246         ) &&
2247         ip->type != FETCH_ME)
2248     {
2249       IF_PAR_DEBUG(pack,
2250                    belch("*<#-  Duplicate local object for GA ((%x, %d, %x)); redirecting %p (%s) -> %p (%s)",
2251                          ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2252                          existing, info_type(existing), closure, info_type(closure)));
2253
2254       /*
2255        * What we had wasn't worth keeping, so make the old closure an
2256        * indirection to the new closure (copying BQs if necessary) and
2257        * make sure that the old entry is not the preferred one for this
2258        * closure.
2259        */
2260       CommonUp(existing, closure);
2261       //GALAdeprecate(ga);
2262 #if defined(DEBUG)
2263       {
2264          StgInfoTable *info;
2265          nat size, ptrs, nonptrs, vhs, i;
2266          char str[80];
2267
2268          /* get info about basic layout of the closure */
2269          info = get_closure_info(GALAlookup(ga), &size, &ptrs, &nonptrs, &vhs, str);
2270
2271          /* now ga indirectly refers to the new closure */
2272          ASSERT(size<_HS+MIN_UPD_SIZE ||
2273                 UNWIND_IND(GALAlookup(ga))==closure);
2274       }
2275 #endif
2276     } else {
2277       /*
2278        * Either we already had something worthwhile by this name or
2279        * the new thing is just another FetchMe.  However, the thing we
2280        * just unpacked has to be left as-is, or the child unpacking
2281        * code will fail.  Remember that the way pointer words are
2282        * filled in depends on the info pointers of the parents being
2283        * the same as when they were packed.
2284        */
2285       IF_PAR_DEBUG(pack,
2286                    belch("*<#@  Duplicate local object for GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
2287                          ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2288                          existing, info_type(existing), closure, info_type(closure)));
2289
2290       /* overwrite 2nd word; indicates that the closure is garbage */
2291       IF_DEBUG(sanity,
2292                ((StgFetchMe*)closure)->ga = (globalAddr*)GARBAGE_MARKER;
2293                IF_PAR_DEBUG(pack,
2294                             belch("++++  unpacked closure %p (%s) is garbage: %p",
2295                                   closure, info_type(closure), *(closure+1))));
2296
2297       closure = existing;
2298 #if 0
2299       // HACK
2300       ty = get_itbl(closure)->type;
2301       if (ty == CONSTR ||
2302           ty == CONSTR_1_0 ||
2303           ty == CONSTR_0_1 ||
2304           ty == CONSTR_2_0 ||
2305           ty == CONSTR_1_1 ||
2306           ty == CONSTR_0_2)
2307         CommonUp(closure, graph);
2308 #endif
2309     }
2310     /* We don't use this GA after all, so give back the weight */
2311     (void) addWeight(ga);
2312   }
2313
2314   /* if we have unpacked a FETCH_ME, we have a GA, too */
2315   ASSERT(get_itbl(closure)->type!=FETCH_ME ||
2316          looks_like_ga(((StgFetchMe*)closure)->ga));
2317
2318   /* Sort out the global address mapping */
2319   if (ip_THUNK(ip)){
2320     // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
2321     //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
2322     /* Make up new GAs for single-copy closures */
2323     globalAddr *newGA = makeGlobal(closure, rtsTrue);
2324
2325     // It's a new GA and therefore has the full weight
2326     ASSERT(newGA->weight==0);
2327
2328     /* Create an old GA to new GA mapping */
2329     *gaga++ = *ga;
2330     splitWeight(gaga, newGA);
2331     /* inlined splitWeight; we know that newGALA has full weight
2332     newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
2333     gaga->payload = newGA->payload;
2334     */
2335     ASSERT(gaga->weight == 1U << (BITS_IN(unsigned) - 1));
2336     gaga++;
2337   }
2338   return closure;
2339 }
2340
2341 /*
2342   Copies a segment of the buffer, starting at @bufptr@, representing a closure
2343   into the heap at @graph@.
2344  */
2345 //@cindex FillInClosure
2346 static nat
2347 FillInClosure(StgWord ***bufptrP, StgClosure *graph)
2348 {
2349   StgInfoTable *ip;
2350   StgWord **bufptr = *bufptrP;
2351   nat ptrs, nonptrs, vhs, i, size;
2352   char str[80];
2353
2354   ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
2355
2356   /*
2357    * Close your eyes.  You don't want to see where we're looking. You
2358    * can't get closure info until you've unpacked the variable header,
2359    * but you don't know how big it is until you've got closure info.
2360    * So...we trust that the closure in the buffer is organized the
2361    * same way as they will be in the heap...at least up through the
2362    * end of the variable header.
2363    */
2364   ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2365
2366   /* Make sure that nothing sans the fixed header is filled in
2367      The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
2368   if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
2369     ASSERT(size>=_HS+MIN_UPD_SIZE);    // size of the FM in the heap
2370     ptrs = nonptrs = vhs = 0;      // i.e. only unpack FH from buffer
2371   }
2372   /* ToDo: check whether this is really needed */
2373   if (ip->type == ARR_WORDS) {
2374     UnpackArray(bufptrP, graph);
2375     return arr_words_sizeW((StgArrWords *)bufptr);
2376   }
2377
2378   if (ip->type == PAP || ip->type == AP_UPD) {
2379     return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
2380   }
2381
2382   /*
2383      Remember, the generic closure layout is as follows:
2384      +-------------------------------------------------+
2385      | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2386      +-------------------------------------------------+
2387   */
2388   /* Fill in the fixed header */
2389   for (i = 0; i < _HS; i++)
2390     ((StgPtr)graph)[i] = (StgWord)*bufptr++;
2391
2392   /* Fill in the packed variable header */
2393   for (i = 0; i < vhs; i++)
2394     ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
2395
2396   /* Pointers will be filled in later */
2397
2398   /* Fill in the packed non-pointers */
2399   for (i = 0; i < nonptrs; i++)
2400     ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
2401
2402   /* Indirections are never packed */
2403   // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2404   // return bufptr;
2405    *bufptrP = bufptr;
2406    ASSERT(((ip->type==FETCH_ME || ip->type==REMOTE_REF)&& sizeofW(StgFetchMe)==size) ||
2407           _HS+vhs+ptrs+nonptrs == size);
2408    return size;
2409 }
2410
2411 /*
2412   Find the next pointer field in the parent closure.
2413   If the current parent has been completely unpacked already, get the
2414   next closure from the global closure queue.
2415 */
2416 //@cindex LocateNextParent
2417 static void
2418 LocateNextParent(parentP, pptrP, pptrsP, sizeP)
2419 StgClosure **parentP;
2420 nat *pptrP, *pptrsP, *sizeP;
2421 {
2422   StgInfoTable *ip; // debugging
2423   nat nonptrs, pvhs;
2424   char str[80];
2425
2426   /* pptr as an index into the current parent; find the next pointer field
2427      in the parent by increasing pptr; if that takes us off the closure
2428      (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
2429   */
2430   (*pptrP)++;
2431   while (*pptrP + 1 > *pptrsP) {
2432     /* *parentP has been constructed (all pointer set); so check it now */
2433     IF_DEBUG(sanity,
2434              if ((*parentP!=(StgClosure*)NULL) &&         // not root
2435                  (*((StgPtr)(*parentP)+1)!=GARBAGE_MARKER) && // not commoned up
2436                  (get_itbl(*parentP)->type != FETCH_ME))
2437                checkClosure(*parentP));
2438
2439     *parentP = DeQueueClosure();
2440
2441     if (*parentP == NULL)
2442       break;
2443     else {
2444       ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
2445                             &pvhs, str);
2446       *pptrP = 0;
2447     }
2448   }
2449   /* *parentP points to the new (or old) parent; */
2450   /* *pptr, *pptrs and *size have been updated referring to the new parent */
2451 }
2452
2453 /*
2454    UnpackClosure is the heart of the unpacking routine. It is called for
2455    every closure found in the packBuffer. Any prefix such as GA, PLC marker
2456    etc has been unpacked into the *ga structure.
2457    UnpackClosure does the following:
2458      - check for the kind of the closure (PLC, Offset, std closure)
2459      - copy the contents of the closure from the buffer into the heap
2460      - update LAGA tables (in particular if we end up with 2 closures
2461        having the same GA, we make one an indirection to the other)
2462      - set the GAGA map in order to send back an ACK message
2463
2464    At the end of this function *graphP has been updated to point to the
2465    next free word in the heap for unpacking the rest of the graph and
2466    *bufptrP points to the next word in the pack buffer to be unpacked.
2467 */
2468
2469 static  StgClosure*
2470 UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
2471   StgClosure *closure;
2472   nat size;
2473   rtsBool hasGA = rtsFalse, unglobalised = rtsFalse;
2474
2475   /* Now unpack the closure body, if there is one; three cases:
2476      - PLC: closure is just a pointer to a static closure
2477      - Offset: closure has been unpacked already
2478      - else: copy data from packet into closure
2479   */
2480   if (isFixed(ga)) {
2481     closure = UnpackPLC(ga);
2482   } else if (isOffset(ga)) {
2483     closure = UnpackOffset(ga);
2484   } else {
2485     /* if not PLC or Offset it must be a GA and then the closure */
2486     ASSERT(RtsFlags.ParFlags.globalising!=0 || LOOKS_LIKE_GA(ga));
2487     /* check whether this is an unglobalised closure */
2488     unglobalised = isUnglobalised(ga);
2489     /* Now we have to build something. */
2490     hasGA = !isConstr(ga);
2491     /* the new closure will be built here */
2492     closure = *graphP;
2493
2494     /* fill in the closure from the buffer */
2495     size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
2496     /* if it is unglobalised, it may not be a thunk!! */
2497     ASSERT(!unglobalised || !closure_THUNK(closure));
2498
2499    /* Add to queue for processing */
2500     QueueClosure(closure);
2501
2502     /* common up with other graph if necessary */
2503     if (!unglobalised)
2504       closure = SetGAandCommonUp(ga, closure, hasGA);
2505
2506     /* if we unpacked a THUNK, check that it is large enough to update */
2507     ASSERT(!closure_THUNK(closure) || size>=_HS+MIN_UPD_SIZE);
2508     /* graph shall point to next free word in the heap */
2509     *graphP += size;
2510     //*graphP += (size < _HS+MIN_UPD_SIZE) ? _HS+MIN_UPD_SIZE : size; // see ASSERT
2511   }
2512   return closure;
2513 }
2514
2515 /*
2516   @UnpackGraph@ unpacks the graph contained in a message buffer.  It
2517   returns a pointer to the new graph.  The @gamap@ parameter is set to
2518   point to an array of (oldGA,newGA) pairs which were created as a result
2519   of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
2520   were created.
2521
2522   The format of graph in the pack buffer is as defined in @Pack.lc@.  */
2523
2524 //@cindex UnpackGraph
2525 StgClosure *
2526 UnpackGraph(packBuffer, gamap, nGAs)
2527 rtsPackBuffer *packBuffer;
2528 globalAddr **gamap;
2529 nat *nGAs;
2530 {
2531   StgWord **bufptr, **slotptr;
2532   globalAddr gaS;
2533   StgClosure *closure, *graphroot, *graph, *parent;
2534   nat size, heapsize, bufsize,
2535       pptr = 0, pptrs = 0, pvhs = 0;
2536   nat unpacked_closures = 0, unpacked_thunks = 0; // stats only
2537
2538   IF_PAR_DEBUG(resume,
2539                graphFingerPrint[0] = '\0');
2540
2541   ASSERT(_HS==1);  // HWL HACK; compile time constant
2542
2543 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2544   PAR_TICKY_UNPACK_GRAPH_START();
2545 #endif
2546
2547   /* Initialisation */
2548   InitPacking(rtsTrue);      // same as in PackNearbyGraph
2549   globalUnpackBuffer = packBuffer;
2550
2551   IF_DEBUG(sanity, // do a sanity check on the incoming packet
2552            checkPacket(packBuffer));
2553
2554   ASSERT(gaga==PendingGABuffer);
2555   graphroot = (StgClosure *)NULL;
2556
2557   /* Unpack the header */
2558   bufsize = packBuffer->size;
2559   heapsize = packBuffer->unpacked_size;
2560   bufptr = packBuffer->buffer;
2561
2562   /* allocate heap */
2563   if (heapsize > 0) {
2564     graph = (StgClosure *)allocate(heapsize);
2565     ASSERT(graph != NULL);
2566     // parallel global statistics: increase amount of global data
2567     if (RtsFlags.ParFlags.ParStats.Global &&
2568         RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2569       globalParStats.tot_global += heapsize;
2570     }
2571   }
2572
2573   /* iterate over the buffer contents and unpack all closures */
2574   parent = (StgClosure *)NULL;
2575   do {
2576     /* check that we aren't at the end of the buffer, yet */
2577     IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
2578
2579     /* This is where we will ultimately save the closure's address */
2580     slotptr = bufptr;
2581
2582     /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
2583     bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
2584
2585     /* this allocates heap space, updates LAGA tables etc */
2586     closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
2587     unpacked_closures++; // stats only; doesn't count FMs in PAP!!!
2588     unpacked_thunks += (closure_THUNK(closure)) ? 1 : 0; // stats only
2589
2590     /*
2591      * Set parent pointer to point to chosen closure.  If we're at the top of
2592      * the graph (our parent is NULL), then we want to arrange to return the
2593      * chosen closure to our caller (possibly in place of the allocated graph
2594      * root.)
2595      */
2596     if (parent == NULL)
2597       graphroot = closure;
2598     else
2599       ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
2600
2601     /* Save closure pointer for resolving offsets */
2602     *slotptr = (StgWord*) closure;
2603
2604     /* Locate next parent pointer */
2605     LocateNextParent(&parent, &pptr, &pptrs, &size);
2606
2607     IF_DEBUG(sanity,
2608              gaS.weight          = 0xdeadffff;
2609              gaS.payload.gc.gtid = 0xdead;
2610              gaS.payload.gc.slot = 0xdeadbeef;);
2611   } while (parent != NULL);
2612
2613   IF_PAR_DEBUG(resume,
2614                GraphFingerPrint(graphroot, graphFingerPrint);
2615                ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
2616                belch(">>> Fingerprint of graph rooted at %p (after unpacking <<%d>>:\n    {%s}",
2617                      graphroot, packBuffer->id, graphFingerPrint));
2618
2619   /* we unpacked exactly as many words as there are in the buffer */
2620   ASSERT(bufsize == (nat) (bufptr-(packBuffer->buffer)));
2621   /* we filled no more heap closure than we allocated at the beginning;
2622      ideally this should be a ==;
2623      NB: test is only valid if we unpacked anything at all (graphroot might
2624          end up to be a PLC!), therfore the strange test for HEAP_ALLOCED
2625   */
2626
2627   /*
2628   {
2629    StgInfoTable *info = get_itbl(graphroot);
2630    ASSERT(!HEAP_ALLOCED(graphroot) || heapsize >= (nat) (graph-graphroot) ||
2631           // ToDo: check whether CAFs are really a special case here!!
2632           info->type==CAF_BLACKHOLE || info->type==FETCH_ME || info->type==FETCH_ME_BQ);
2633   }
2634   */
2635
2636   /* check for magic end-of-buffer word */
2637   IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
2638
2639   *gamap = PendingGABuffer;
2640   *nGAs = (gaga - PendingGABuffer) / 2;
2641
2642   IF_PAR_DEBUG(tables,
2643                belch("**   LAGA table after unpacking closure %p:",
2644                      graphroot);
2645                printLAGAtable());
2646
2647   /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
2648   ASSERT(graphroot!=NULL);
2649
2650   IF_DEBUG(sanity,
2651            {
2652              StgPtr p;
2653
2654              /* check the unpacked graph */
2655              //checkHeapChunk(graphroot,graph-sizeof(StgWord));
2656
2657              // if we do sanity checks, then wipe the pack buffer after unpacking
2658              for (p=(StgPtr)packBuffer->buffer; p<(StgPtr)(packBuffer->buffer)+(packBuffer->size); )
2659                *p++ = 0xdeadbeef;
2660             });
2661
2662   /* reset the global variable */
2663   globalUnpackBuffer = (rtsPackBuffer*)NULL;
2664
2665 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2666   PAR_TICKY_UNPACK_GRAPH_END(unpacked_closures, unpacked_thunks);
2667 #endif
2668
2669   return (graphroot);
2670 }
2671
2672 //@cindex UnpackGA
2673 static  StgWord **
2674 UnpackGA(StgWord **bufptr, globalAddr *ga)
2675 {
2676   /* First, unpack the next GA or PLC */
2677   ga->weight = (rtsWeight) *bufptr++;
2678
2679   if (ga->weight == 2) {  // unglobalised closure to follow
2680     // nothing to do; closure starts at *bufptr
2681   } else if (ga->weight > 0) { // fill in GA
2682     ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
2683     ga->payload.gc.slot = (int) *bufptr++;
2684   } else {
2685     ga->payload.plc = (StgPtr) *bufptr++;
2686   }
2687   return bufptr;
2688 }
2689
2690 //@cindex UnpackPLC
2691 static  StgClosure *
2692 UnpackPLC(globalAddr *ga)
2693 {
2694   /* No more to unpack; just set closure to local address */
2695   IF_PAR_DEBUG(pack,
2696                belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
2697   return (StgClosure*)ga->payload.plc;
2698 }
2699
2700 //@cindex UnpackOffset
2701 static  StgClosure *
2702 UnpackOffset(globalAddr *ga)
2703 {
2704   /* globalUnpackBuffer is a global var init in UnpackGraph */
2705   ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
2706   /* No more to unpack; just set closure to cached address */
2707   IF_PAR_DEBUG(pack,
2708                belch("*<__ Unpacked indirection to %p (was OFFSET %d)",
2709                      (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
2710                      ga->payload.gc.slot));
2711   return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
2712 }
2713
2714 /*
2715   Input: *bufptrP, *graphP  ... ptrs to the pack buffer and into the heap.
2716
2717   *bufptrP points to something that should be unpacked as a FETCH_ME:
2718     |
2719     v
2720     +-------------------------------
2721     |    GA    | FH of FM
2722     +-------------------------------
2723
2724   The first 3 words starting at *bufptrP are the GA address; the next
2725   word is the generic FM info ptr followed by the remaining FH (if any)
2726   The result after unpacking will be a FETCH_ME closure, pointed to by
2727   *graphP at the start of the fct;
2728     |
2729     v
2730     +------------------------+
2731     | FH of FM | ptr to a GA |
2732     +------------------------+
2733
2734    The ptr field points into the RemoteGA table, which holds the actual GA.
2735    *bufptrP has been updated to point to the next word in the buffer.
2736    *graphP has been updated to point to the first free word at the end.
2737 */
2738
2739 static StgClosure*
2740 UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
2741   StgClosure *closure, *foo;
2742   globalAddr gaS;
2743
2744   /* This fct relies on size of FM < size of FM in pack buffer */
2745   ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
2746
2747   /* fill in gaS from buffer */
2748   *bufptrP = UnpackGA(*bufptrP, &gaS);
2749   /* might be an offset to a closure in the pack buffer */
2750   if (isOffset(&gaS)) {
2751     belch("*<   UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
2752                   gaS.payload.gc.slot, *bufptrP);
2753
2754     closure = UnpackOffset(&gaS);
2755     /* return address of previously unpacked closure; leaves *graphP unchanged */
2756     return closure;
2757   }
2758
2759   /* we have a proper GA at hand */
2760   ASSERT(LOOKS_LIKE_GA(&gaS));
2761
2762   IF_DEBUG(sanity,
2763            if (isFixed(&gaS))
2764            barf("*<   UnpackFetchMe: found PLC where FM was expected %p (%s)",
2765                 *bufptrP, info_type((StgClosure*)*bufptrP)));
2766
2767   IF_PAR_DEBUG(pack,
2768                belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
2769                      *graphP);
2770                printGA(&gaS);
2771                fputc('\n', stderr));
2772
2773   /* the next thing must be the IP to a FETCH_ME closure */
2774   ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
2775
2776   closure = *graphP;
2777   /* fill in the closure from the buffer */
2778   FillInClosure(bufptrP, closure);
2779
2780   /* the newly built closure is a FETCH_ME */
2781   ASSERT(get_itbl(closure)->type == FETCH_ME);
2782
2783   /* common up with other graph if necessary
2784      this also assigns the contents of gaS to the ga field of the FM closure */
2785   foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
2786
2787   ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
2788
2789   IF_PAR_DEBUG(pack,
2790                if (foo==closure) {  // only if not commoned up
2791                  belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
2792                        *graphP, *graphP+sizeofW(StgFetchMe), closure);
2793                  printClosure(closure);
2794                });
2795   *graphP += sizeofW(StgFetchMe);
2796   return foo;
2797 }
2798
2799 /*
2800   Unpack an array of words.
2801   Could use generic unpack most of the time, but cleaner to separate it.
2802   ToDo: implement packing of MUT_ARRAYs
2803 */
2804
2805 //@cindex UnackArray
2806 static void
2807 UnpackArray(StgWord ***bufptrP, StgClosure *graph)
2808 {
2809   StgInfoTable *info;
2810   StgWord **bufptr=*bufptrP;
2811   nat size, ptrs, nonptrs, vhs, i, n;
2812   char str[80];
2813
2814   /* yes, I know I am paranoid; but who's asking !? */
2815   IF_DEBUG(sanity,
2816            info = get_closure_info((StgClosure*)bufptr,
2817                                    &size, &ptrs, &nonptrs, &vhs, str);
2818            ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
2819                   info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
2820
2821   n = ((StgArrWords *)bufptr)->words;
2822   // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
2823
2824   IF_PAR_DEBUG(pack,
2825                if (n<100)
2826                  belch("*<== unpacking an array of %d words %p (%s) (size=%d) |%s|\n",
2827                      n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2828                      arr_words_sizeW((StgArrWords *)bufptr),
2829                        /* print array (string?) */
2830                      ((StgArrWords *)graph)->payload);
2831                else
2832                  belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
2833                      n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2834                      arr_words_sizeW((StgArrWords *)bufptr)));
2835
2836   /* Unpack the header (2 words: info ptr and the number of words to follow) */
2837   ((StgArrWords *)graph)->header.info = (StgInfoTable*)*bufptr++;  // assumes _HS==1; yuck!
2838   ((StgArrWords *)graph)->words = (StgWord)*bufptr++;
2839
2840   /* unpack the payload of the closure (all non-ptrs) */
2841   for (i=0; i<n; i++)
2842     ((StgArrWords *)graph)->payload[i] = (StgWord)*bufptr++;
2843
2844   ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
2845   *bufptrP = bufptr;
2846 }
2847
2848 /*
2849    Unpack a PAP in the buffer into a heap closure.
2850    For each FETCHME we find in the packed PAP we have to unpack a separate
2851    FETCHME closure and insert a pointer to this closure into the PAP.
2852    We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
2853    Note that the size of a FETCHME in the buffer is exactly the same as
2854    the size of an unpacked FETCHME plus 1 word for the pointer to it.
2855    Therefore, we just allocate packed_size words in the heap for the unpacking.
2856    After this routine the heap starting from *graph looks like this:
2857
2858    graph
2859      |
2860      v             PAP closure                 |   FM area        |
2861      +------------------------------------------------------------+
2862      | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
2863      +------------------------------------------------------------+
2864
2865    where payload contains pointers to each of the unpacked FM_1, FM_2 ...
2866    The size of the PAP closure plus all FMs is _HS+2+packed_size.
2867 */
2868
2869 //@cindex UnpackPAP
2870 static nat
2871 UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
2872 {
2873   nat n, i, j, packed_size = 0;
2874   StgPtr p, q, end, payload_start, p_FMs;
2875   const StgInfoTable* info;
2876   StgWord bitmap;
2877   StgWord **bufptr = *bufptrP;
2878 #if defined(DEBUG)
2879   nat FMs_in_PAP=0;
2880   void checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end);
2881 #endif
2882
2883   IF_PAR_DEBUG(pack,
2884                belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
2885                          *bufptr, *(bufptr+1), graph));
2886
2887   /* Unpack the PAP header (both fixed and variable) */
2888   ((StgPAP *)graph)->header.info = (StgInfoTable*)*bufptr++;
2889   n = ((StgPAP *)graph)->n_args = (StgWord)*bufptr++;
2890   ((StgPAP *)graph)->fun = (StgClosure*)*bufptr++;
2891   packed_size = (nat)*bufptr++;
2892
2893   IF_PAR_DEBUG(pack,
2894                belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
2895                      ((StgPAP *)graph)->header.info,
2896                      ((StgPAP *)graph)->n_args,
2897                      ((StgPAP *)graph)->fun,
2898                      packed_size));
2899
2900   payload_start = (StgPtr)bufptr;
2901   /* p points to the current word in the heap */
2902   p = (StgPtr)((StgPAP *)graph)->payload;      // payload of PAP will be unpacked here
2903   p_FMs = (StgPtr)graph+pap_sizeW((StgPAP*)graph);  // FMs will be unpacked here
2904   end = (StgPtr) payload_start+packed_size;
2905   /*
2906     The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
2907     FM area for unpacking all FETCHMEs encountered during unpacking.
2908   */
2909   while ((StgPtr)bufptr<end) {
2910     /* be sure that we don't write more than we allocated for this closure */
2911     ASSERT(p_FMs <= (StgPtr)(graph+_HS+2+packed_size));
2912     /* be sure that the unpacked PAP doesn't run into the FM area */
2913     ASSERT(p < (StgPtr)(graph+pap_sizeW((StgPAP*)graph)));
2914     /* the loop body has been borrowed from scavenge_stack */
2915     q = *bufptr; // let q be the contents of the current pointer into the buffer
2916
2917     /* Test whether the next thing is a FETCH_ME.
2918        In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
2919     */
2920     if (q==(StgPtr)(ARGTAG_MAX+1)) {
2921       IF_PAR_DEBUG(pack,
2922                    belch("*<** UnpackPAP @ %p: unpacking FM; filling in ptr to FM area: %p",
2923                          p, p_FMs));
2924       bufptr++;         // skip ARGTAG_MAX+1 marker
2925       // Unpack a FM into the FM area after the PAP proper and insert pointer
2926       *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
2927       IF_DEBUG(sanity, FMs_in_PAP++);
2928       continue;
2929     }
2930
2931     /* Test whether it is a PLC */
2932     if (q==(StgPtr)0) { // same as isFixed(q)
2933       IF_PAR_DEBUG(pack,
2934                    belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
2935                          p, *(bufptr+1)));
2936       bufptr++;          // skip 0 marker
2937       *p++ = (StgWord)*bufptr++;
2938       continue;
2939     }
2940
2941     /* If we've got a tag, pack all words in that block */
2942     if (IS_ARG_TAG((W_)q)) {   // q stands for the no. of non-ptrs to follow
2943       nat m = ARG_SIZE(q);     // first word after this block
2944       IF_PAR_DEBUG(pack,
2945                    belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
2946                          p, m, p));
2947       for (i=0; i<m+1; i++)
2948         *p++ = (StgWord)*bufptr++;
2949       continue;
2950     }
2951
2952     /*
2953      * Otherwise, q must be the info pointer of an activation
2954      * record.  All activation records have 'bitmap' style layout
2955      * info.
2956      */
2957     info  = get_itbl((StgClosure *)q);
2958     switch (info->type) {
2959
2960       /* Dynamic bitmap: the mask is stored on the stack */
2961     case RET_DYN:
2962       IF_PAR_DEBUG(pack,
2963                    belch("*<** UnpackPAP @ %p: RET_DYN",
2964                          p));
2965
2966       /* Pack the header as is */
2967       ((StgRetDyn *)p)->info     = (StgWord)*bufptr++;
2968       ((StgRetDyn *)p)->liveness = (StgWord)*bufptr++;
2969       ((StgRetDyn *)p)->ret_addr = (StgWord)*bufptr++;
2970       p += 3;
2971
2972       //bitmap = ((StgRetDyn *)p)->liveness;
2973       //p      = (P_)&((StgRetDyn *)p)->payload[0];
2974       goto small_bitmap;
2975
2976       /* probably a slow-entry point return address: */
2977     case FUN:
2978     case FUN_STATIC:
2979       {
2980       IF_PAR_DEBUG(pack,
2981                    belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
2982                          p));
2983
2984       ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr;
2985       p++;
2986
2987       goto follow_srt; //??
2988       }
2989
2990       /* Using generic code here; could inline as in scavenge_stack */
2991     case UPDATE_FRAME:
2992       {
2993         StgUpdateFrame *frame = (StgUpdateFrame *)p;
2994         //nat type = get_itbl(frame->updatee)->type;
2995
2996         //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
2997
2998         IF_PAR_DEBUG(pack,
2999                      belch("*<** UnackPAP @ %p: UPDATE_FRAME",
3000                            p));
3001
3002         ((StgUpdateFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3003         ((StgUpdateFrame *)p)->link        = (StgUpdateFrame*)*bufptr++;     // ToDo: fix intra-stack pointer
3004         ((StgUpdateFrame *)p)->updatee     = (StgClosure*)*bufptr++;   // ToDo: follow link
3005
3006         p += 3;
3007       }
3008
3009       /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
3010     case STOP_FRAME:
3011       {
3012         IF_PAR_DEBUG(pack,
3013                      belch("*<** UnpackPAP @ %p: STOP_FRAME",
3014                            p));
3015         ((StgStopFrame *)p)->header.info = (StgInfoTable*)*bufptr;
3016         p++;
3017       }
3018
3019     case CATCH_FRAME:
3020       {
3021         IF_PAR_DEBUG(pack,
3022                      belch("*<** UnpackPAP @ %p: CATCH_FRAME",
3023                            p));
3024
3025         ((StgCatchFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3026         ((StgCatchFrame *)p)->link        = (StgUpdateFrame*)*bufptr++;
3027         ((StgCatchFrame *)p)->exceptions_blocked = (StgInt)*bufptr++;
3028         ((StgCatchFrame *)p)->handler     = (StgClosure*)*bufptr++;
3029         p += 4;
3030       }
3031
3032     case SEQ_FRAME:
3033       {
3034         IF_PAR_DEBUG(pack,
3035                      belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
3036                            p));
3037
3038         ((StgSeqFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3039         ((StgSeqFrame *)p)->link        = (StgUpdateFrame*)*bufptr++;
3040
3041         // ToDo: handle bitmap
3042         bitmap = info->layout.bitmap;
3043
3044         p = (StgPtr)&(((StgClosure *)p)->payload);
3045         goto small_bitmap;
3046       }
3047     case RET_BCO:
3048     case RET_SMALL:
3049     case RET_VEC_SMALL:
3050       IF_PAR_DEBUG(pack,
3051                    belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
3052                          p));
3053
3054
3055       ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3056       p++;
3057       // ToDo: handle bitmap
3058       bitmap = info->layout.bitmap;
3059       /* this assumes that the payload starts immediately after the info-ptr */
3060
3061     small_bitmap:
3062       while (bitmap != 0) {
3063         if ((bitmap & 1) == 0) {
3064           *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3065           IF_DEBUG(sanity, FMs_in_PAP++);
3066         } else {
3067           *p++ = (StgWord)*bufptr++;
3068         }
3069         bitmap = bitmap >> 1;
3070       }
3071
3072     follow_srt:
3073       belch("*<-- UnpackPAP: nothing to do for follow_srt");
3074       continue;
3075
3076       /* large bitmap (> 32 entries) */
3077     case RET_BIG:
3078     case RET_VEC_BIG:
3079       {
3080         StgPtr q;
3081         StgLargeBitmap *large_bitmap;
3082
3083         IF_PAR_DEBUG(pack,
3084                      belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
3085                            p, info->layout.large_bitmap));
3086
3087
3088         ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3089         p++;
3090
3091         large_bitmap = info->layout.large_bitmap;
3092
3093         for (j=0; j<large_bitmap->size; j++) {
3094           bitmap = large_bitmap->bitmap[j];
3095           q = p + BITS_IN(W_);
3096           while (bitmap != 0) {
3097             if ((bitmap & 1) == 0) {
3098               *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3099               IF_DEBUG(sanity, FMs_in_PAP++);
3100             } else {
3101               *p++ = (StgWord)*bufptr;
3102             }
3103             bitmap = bitmap >> 1;
3104           }
3105           if (j+1 < large_bitmap->size) {
3106             while (p < q) {
3107               *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3108               IF_DEBUG(sanity, FMs_in_PAP++);
3109             }
3110           }
3111         }
3112
3113         /* and don't forget to follow the SRT */
3114         goto follow_srt;
3115       }
3116
3117     default:
3118       barf("UnpackPAP: weird activation record found on stack: %d",
3119            (int)(info->type));
3120     }
3121   }
3122   IF_PAR_DEBUG(pack,
3123                belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
3124                      (StgClosure *)graph);
3125                printClosure((StgClosure *)graph));
3126
3127   IF_DEBUG(sanity,               /* check sanity of unpacked PAP */
3128            checkClosure(graph));
3129
3130   *bufptrP = bufptr;
3131   /*
3132      Now p points to the first word after the PAP proper and p_FMs points
3133      to the next free word in the heap; everything between p and p_FMs are
3134      FETCHMEs
3135   */
3136   IF_DEBUG(sanity,
3137            checkPAPSanity(graph, p, p_FMs));
3138
3139   /* we have to return the size of PAP + FMs as size of the unpacked thing */
3140   ASSERT(graph+pap_sizeW((StgPAP*)graph)==p);
3141   return (nat)((StgClosure*)p_FMs-graph);
3142 }
3143
3144 #if defined(DEBUG)
3145 /*
3146    Check sanity of a PAP after unpacking the PAP.
3147    This means that there is slice of heap after the PAP containing FETCHMEs
3148 */
3149 void
3150 checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end)
3151 {
3152   StgPtr xx;
3153
3154   /* check that the main unpacked closure is a PAP */
3155   ASSERT(graph->header.info = &stg_PAP_info);
3156   checkClosure(graph);
3157   /* check that all of the closures in the FM-area are FETCHMEs */
3158   for (xx=p_FM_begin; xx<p_FM_end; xx += sizeofW(StgFetchMe)) {
3159     /* must be a FETCHME closure */
3160     ASSERT(((StgClosure*)xx)->header.info == &stg_FETCH_ME_info);
3161     /* it might have been commoned up (=> marked as garbage);
3162        otherwise it points to a GA */
3163     ASSERT((((StgFetchMe*)xx)->ga)==GARBAGE_MARKER ||
3164            LOOKS_LIKE_GA(((StgFetchMe*)xx)->ga));
3165   }
3166   /* traverse the payload of the PAP */
3167   for (xx=graph->payload; xx-(StgPtr)(graph->payload)<graph->n_args; xx++) {
3168     /* if the current elem is a pointer into the FM area, check that
3169        the GA field is ok */
3170     ASSERT(!(p_FM_begin<(StgPtr)*xx && (StgPtr)*xx<p_FM_end) ||
3171            LOOKS_LIKE_GA(((StgFetchMe*)*xx)->ga));
3172   }
3173 }
3174 #endif  /* DEBUG */
3175 #endif  /* PAR */
3176
3177 //@node GranSim Code,  , GUM code, Unpacking routines
3178 //@subsubsection GranSim Code
3179
3180 /*
3181    For GrAnSim: No actual unpacking should be necessary. We just
3182    have to walk over the graph and set the bitmasks appropriately.
3183    Since we use RBHs similarly to GUM but without an ACK message/event
3184    we have to revert the RBH from within the UnpackGraph routine (good luck!)
3185    -- HWL
3186 */
3187
3188 #if defined(GRAN)
3189 void
3190 CommonUp(StgClosure *src, StgClosure *dst)
3191 {
3192   barf("CommonUp: should never be entered in a GranSim setup");
3193 }
3194
3195 StgClosure*
3196 UnpackGraph(buffer)
3197 rtsPackBuffer* buffer;
3198 {
3199   nat size, ptrs, nonptrs, vhs,
3200       bufptr = 0;
3201   StgClosure *closure, *graphroot, *graph;
3202   StgInfoTable *ip;
3203   StgWord bufsize, unpackedsize,
3204           pptr = 0, pptrs = 0, pvhs;
3205   StgTSO* tso;
3206   char str[240], str1[80];
3207   int i;
3208
3209   bufptr = 0;
3210   graphroot = buffer->buffer[0];
3211
3212   tso = buffer->tso;
3213
3214   /* Unpack the header */
3215   unpackedsize = buffer->unpacked_size;
3216   bufsize = buffer->size;
3217
3218   IF_GRAN_DEBUG(pack,
3219                 belch("<<< Unpacking <<%d>> (buffer @ %p):\n    (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
3220                       buffer->id, buffer, graphroot, where_is(graphroot),
3221                       bufsize, tso->id, tso,
3222                       where_is((StgClosure *)tso)));
3223
3224   do {
3225     closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
3226
3227     /* Actually only ip is needed; rest is useful for TESTING -- HWL */
3228     ip = get_closure_info(closure,
3229                           &size, &ptrs, &nonptrs, &vhs, str);
3230
3231     IF_GRAN_DEBUG(pack,
3232                   sprintf(str, "**    (%p): Changing bitmask[%s]: 0x%x ",
3233                           closure, (closure_HNF(closure) ? "NF" : "__"),
3234                           PROCS(closure)));
3235
3236     if (get_itbl(closure)->type == RBH) {
3237       /* if it's an RBH, we have to revert it into a normal closure, thereby
3238          awakening the blocking queue; not that this is code currently not
3239          needed in GUM, but it should be added with the new features in
3240          GdH (and the implementation of an NACK message)
3241       */
3242       // closure->header.gran.procs = PE_NUMBER(CurrentProc);
3243       SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc));    /* Move node */
3244
3245       IF_GRAN_DEBUG(pack,
3246                     strcat(str, " (converting RBH) "));
3247
3248       convertFromRBH(closure);   /* In GUM that's done by convertToFetchMe */
3249
3250       IF_GRAN_DEBUG(pack,
3251                     belch("::  closure %p (%s) is a RBH; after reverting: IP=%p",
3252                           closure, info_type(closure), get_itbl(closure)));
3253     } else if (IS_BLACK_HOLE(closure)) {
3254       IF_GRAN_DEBUG(pack,
3255                     belch("::  closure %p (%s) is a BH; copying node to %d",
3256                           closure, info_type(closure), CurrentProc));
3257       closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3258     } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
3259       if (closure_HNF(closure)) {
3260         IF_GRAN_DEBUG(pack,
3261                       belch("::  closure %p (%s) is a HNF; copying node to %d",
3262                             closure, info_type(closure), CurrentProc));
3263         closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3264       } else {
3265         IF_GRAN_DEBUG(pack,
3266                       belch("::  closure %p (%s) is no (R)BH or HNF; moving node to %d",
3267                             closure, info_type(closure), CurrentProc));
3268         closure->header.gran.procs = PE_NUMBER(CurrentProc);  /* Move node */
3269       }
3270     }
3271
3272     IF_GRAN_DEBUG(pack,
3273                   sprintf(str1, "0x%x",   PROCS(closure)); strcat(str, str1));
3274     IF_GRAN_DEBUG(pack, belch(str));
3275
3276   } while (bufptr<buffer->size) ;   /*  (parent != NULL);  */
3277
3278   /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
3279   free(buffer->buffer);
3280   free(buffer);
3281
3282   IF_GRAN_DEBUG(pack,
3283                 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
3284
3285   return (graphroot);
3286 }
3287 #endif  /* GRAN */
3288
3289 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
3290 //@subsection Aux fcts for packing
3291
3292 //@menu
3293 //* Offset table::
3294 //* Packet size::
3295 //* Types of Global Addresses::
3296 //* Closure Info::
3297 //@end menu
3298
3299 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
3300 //@subsubsection Offset table
3301
3302 /*
3303    DonePacking is called when we've finished packing.  It releases memory
3304    etc.  */
3305
3306 //@cindex DonePacking
3307
3308 # if defined(PAR)
3309
3310 static void
3311 DonePacking(void)
3312 {
3313   freeHashTable(offsetTable, NULL);
3314   offsetTable = NULL;
3315 }
3316
3317 /*
3318    AmPacking records that the closure is being packed.  Note the abuse of
3319    the data field in the hash table -- this saves calling @malloc@!  */
3320
3321 //@cindex AmPacking
3322
3323 static void
3324 AmPacking(closure)
3325 StgClosure *closure;
3326 {
3327   insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
3328 }
3329
3330 /*
3331    OffsetFor returns an offset for a closure which is already being packed.  */
3332
3333 //@cindex OffsetFor
3334
3335 static int
3336 OffsetFor(closure)
3337 StgClosure *closure;
3338 {
3339   return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
3340 }
3341
3342 /*
3343    NotYetPacking determines whether the closure's already being packed.
3344    Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.  */
3345
3346 //@cindex NotYetPacking
3347
3348 static rtsBool
3349 NotYetPacking(offset)
3350 int offset;
3351 {
3352   return(offset == 0); // ToDo: what if root is found again?? FIX
3353 }
3354
3355 # else  /* GRAN */
3356
3357 static void
3358 DonePacking(void)
3359 {
3360   /* nothing */
3361 }
3362
3363 /*
3364    NotYetPacking searches through the whole pack buffer for closure.  */
3365
3366 static rtsBool
3367 NotYetPacking(closure)
3368 StgClosure *closure;
3369 { nat i;
3370   rtsBool found = rtsFalse;
3371
3372   for (i=0; (i<pack_locn) && !found; i++)
3373     found = globalPackBuffer->buffer[i]==closure;
3374
3375   return (!found);
3376 }
3377 # endif
3378
3379 //@node Packet size, Closure Info, Offset table, Aux fcts for packing
3380 //@subsubsection Packet size
3381
3382 /*
3383    The size needed if all currently queued closures are packed as FETCH_ME
3384    closures. This represents the headroom we must have when packing the
3385    buffer in order to maintain all links in the graphs.
3386 */
3387 // ToDo: check and merge cases
3388 #if defined(PAR)
3389 static nat
3390 QueuedClosuresMinSize (nat ptrs) {
3391   return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3392 }
3393 #else /* GRAN */
3394 static nat
3395 QueuedClosuresMinSize (nat ptrs) {
3396   return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3397 }
3398 #endif
3399
3400 /*
3401   RoomToPack determines whether there's room to pack the closure into
3402   the pack buffer based on
3403
3404   o how full the buffer is already,
3405   o the closures' size and number of pointers (which must be packed as GAs),
3406   o the size and number of pointers held by any primitive arrays that it
3407     points to
3408
3409     It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
3410     to rtsFalse.
3411 */
3412
3413 //@cindex RoomToPack
3414 static rtsBool
3415 RoomToPack(size, ptrs)
3416 nat size, ptrs;
3417 {
3418 # if defined(PAR)
3419   if (roomInBuffer &&
3420       (pack_locn +                 // where we are in the buffer right now
3421        size +                      // space needed for the current closure
3422        QueuedClosuresMinSize(ptrs) // space for queued closures as FETCH_MEs
3423        + 1                         // headroom (DEBUGGING only)
3424        >=
3425        RTS_PACK_BUFFER_SIZE))
3426     {
3427       roomInBuffer = rtsFalse;
3428     }
3429 # else   /* GRAN */
3430   if (roomInBuffer &&
3431       (unpacked_size +
3432        size +
3433        QueuedClosuresMinSize(ptrs)
3434        >=
3435        RTS_PACK_BUFFER_SIZE))
3436     {
3437       roomInBuffer = rtsFalse;
3438     }
3439 # endif
3440   return (roomInBuffer);
3441 }
3442
3443 //@node Closure Info,  , Packet size, Aux fcts for packing
3444 //@subsubsection Closure Info
3445
3446 /*
3447    Closure Info
3448
3449    @get_closure_info@ determines the size, number of pointers etc. for this
3450    type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
3451
3452 [Can someone please keep this function up to date.  I keep needing it
3453  (or something similar) for interpretive code, and it keeps
3454  bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95] */
3455
3456 #if 0
3457
3458 // {Parallel.h}Daq ngoqvam vIroQpu'
3459
3460 # if defined(GRAN) || defined(PAR)
3461 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
3462 //@cindex get_closure_info
3463 StgInfoTable*
3464 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
3465 StgClosure* node;
3466 nat *size, *ptrs, *nonptrs, *vhs;
3467 char *info_hdr_ty;
3468 {
3469   StgInfoTable *info;
3470
3471   info = get_itbl(node);
3472   /* the switch shouldn't be necessary, really; just use default case */
3473   switch (info->type) {
3474 #if 0
3475    case CONSTR_1_0:
3476    case THUNK_1_0:
3477    case FUN_1_0:
3478      *size = sizeW_fromITBL(info);
3479      *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3480      *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3481      *vhs = (nat) 0; // unknown
3482      info_hdr_type(node, info_hdr_ty);
3483      return info;
3484
3485   case CONSTR_0_1:
3486   case THUNK_0_1:
3487   case FUN_0_1:
3488      *size = sizeW_fromITBL(info);
3489      *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3490      *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3491      *vhs = (nat) 0; // unknown
3492      info_hdr_type(node, info_hdr_ty);
3493      return info;
3494
3495   case CONSTR_2_0:
3496   case THUNK_2_0:
3497   case FUN_2_0:
3498      *size = sizeW_fromITBL(info);
3499      *ptrs = (nat) 2; // (info->layout.payload.ptrs);
3500      *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3501      *vhs = (nat) 0; // unknown
3502      info_hdr_type(node, info_hdr_ty);
3503      return info;
3504
3505   case CONSTR_1_1:
3506   case THUNK_1_1:
3507   case FUN_1_1:
3508      *size = sizeW_fromITBL(info);
3509      *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3510      *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3511      *vhs = (nat) 0; // unknown
3512      info_hdr_type(node, info_hdr_ty);
3513      return info;
3514
3515   case CONSTR_0_2:
3516   case THUNK_0_2:
3517   case FUN_0_2:
3518      *size = sizeW_fromITBL(info);
3519      *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3520      *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
3521      *vhs = (nat) 0; // unknown
3522      info_hdr_type(node, info_hdr_ty);
3523      return info;
3524 #endif
3525   case RBH:
3526     {
3527       StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
3528       *size = sizeW_fromITBL(rip);
3529       *ptrs = (nat) (rip->layout.payload.ptrs);
3530       *nonptrs = (nat) (rip->layout.payload.nptrs);
3531       *vhs = (nat) 0; // unknown
3532       info_hdr_type(node, info_hdr_ty);
3533       return rip;  // NB: we return the reverted info ptr for a RBH!!!!!!
3534     }
3535
3536   default:
3537     *size = sizeW_fromITBL(info);
3538     *ptrs = (nat) (info->layout.payload.ptrs);
3539     *nonptrs = (nat) (info->layout.payload.nptrs);
3540     *vhs = (nat) 0; // unknown
3541     info_hdr_type(node, info_hdr_ty);
3542     return info;
3543   }
3544 }
3545
3546 //@cindex IS_BLACK_HOLE
3547 rtsBool
3548 IS_BLACK_HOLE(StgClosure* node)
3549 {
3550   StgInfoTable *info;
3551   info = get_itbl(node);
3552   return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
3553 }
3554
3555 //@cindex IS_INDIRECTION
3556 StgClosure *
3557 IS_INDIRECTION(StgClosure* node)
3558 {
3559   StgInfoTable *info;
3560   info = get_itbl(node);
3561   switch (info->type) {
3562     case IND:
3563     case IND_OLDGEN:
3564     case IND_PERM:
3565     case IND_OLDGEN_PERM:
3566     case IND_STATIC:
3567       /* relies on indirectee being at same place for all these closure types */
3568       return (((StgInd*)node) -> indirectee);
3569     default:
3570       return NULL;
3571   }
3572 }
3573
3574 /*
3575 rtsBool
3576 IS_THUNK(StgClosure* node)
3577 {
3578   StgInfoTable *info;
3579   info = get_itbl(node);
3580   return ((info->type == THUNK ||
3581            info->type == THUNK_STATIC ||
3582            info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
3583 }
3584 */
3585
3586 # endif /* GRAN */
3587 #endif /* 0 */
3588
3589 # if 0
3590 /* ngoq ngo' */
3591
3592 P_
3593 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
3594 P_ closure;
3595 W_ *size, *ptrs, *nonptrs, *vhs;
3596 char *type;
3597 {
3598    P_ ip = (P_) INFO_PTR(closure);
3599
3600    if (closure==NULL) {
3601      fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
3602      *size = *ptrs = *nonptrs = *vhs = 0;
3603      strcpy(type,"ERROR in get_closure_info");
3604      return;
3605    } else if (closure==PrelBase_Z91Z93_closure) {
3606      /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
3607      *size = *ptrs = *nonptrs = *vhs = 0;
3608      strcpy(type,"PrelBase_Z91Z93_closure");
3609      return;
3610    };
3611
3612     ip = (P_) INFO_PTR(closure);
3613
3614     switch (INFO_TYPE(ip)) {
3615     case INFO_SPEC_U_TYPE:
3616     case INFO_SPEC_S_TYPE:
3617     case INFO_SPEC_N_TYPE:
3618         *size = SPEC_CLOSURE_SIZE(closure);
3619         *ptrs = SPEC_CLOSURE_NoPTRS(closure);
3620         *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
3621         *vhs = 0 /*SPEC_VHS*/;
3622         strcpy(type,"SPEC");
3623         break;
3624
3625     case INFO_GEN_U_TYPE:
3626     case INFO_GEN_S_TYPE:
3627     case INFO_GEN_N_TYPE:
3628         *size = GEN_CLOSURE_SIZE(closure);
3629         *ptrs = GEN_CLOSURE_NoPTRS(closure);
3630         *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
3631         *vhs = GEN_VHS;
3632         strcpy(type,"GEN");
3633         break;
3634
3635     case INFO_DYN_TYPE:
3636         *size = DYN_CLOSURE_SIZE(closure);
3637         *ptrs = DYN_CLOSURE_NoPTRS(closure);
3638         *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
3639         *vhs = DYN_VHS;
3640         strcpy(type,"DYN");
3641         break;
3642
3643     case INFO_TUPLE_TYPE:
3644         *size = TUPLE_CLOSURE_SIZE(closure);
3645         *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
3646         *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
3647         *vhs = TUPLE_VHS;
3648         strcpy(type,"TUPLE");
3649         break;
3650
3651     case INFO_DATA_TYPE:
3652         *size = DATA_CLOSURE_SIZE(closure);
3653         *ptrs = DATA_CLOSURE_NoPTRS(closure);
3654         *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
3655         *vhs = DATA_VHS;
3656         strcpy(type,"DATA");
3657         break;
3658
3659     case INFO_IMMUTUPLE_TYPE:
3660     case INFO_MUTUPLE_TYPE:
3661         *size = MUTUPLE_CLOSURE_SIZE(closure);
3662         *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
3663         *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
3664         *vhs = MUTUPLE_VHS;
3665         strcpy(type,"(IM)MUTUPLE");
3666         break;
3667
3668     case INFO_STATIC_TYPE:
3669         *size = STATIC_CLOSURE_SIZE(closure);
3670         *ptrs = STATIC_CLOSURE_NoPTRS(closure);
3671         *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
3672         *vhs = STATIC_VHS;
3673         strcpy(type,"STATIC");
3674         break;
3675
3676     case INFO_CAF_TYPE:
3677     case INFO_IND_TYPE:
3678         *size = IND_CLOSURE_SIZE(closure);
3679         *ptrs = IND_CLOSURE_NoPTRS(closure);
3680         *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
3681         *vhs = IND_VHS;
3682         strcpy(type,"CAF|IND");
3683         break;
3684
3685     case INFO_CONST_TYPE:
3686         *size = CONST_CLOSURE_SIZE(closure);
3687         *ptrs = CONST_CLOSURE_NoPTRS(closure);
3688         *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
3689         *vhs = CONST_VHS;
3690         strcpy(type,"CONST");
3691         break;
3692
3693     case INFO_SPEC_RBH_TYPE:
3694         *size = SPEC_RBH_CLOSURE_SIZE(closure);
3695         *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
3696         *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
3697         if (*ptrs <= 2) {
3698             *nonptrs -= (2 - *ptrs);
3699             *ptrs = 1;
3700         } else
3701             *ptrs -= 1;
3702         *vhs = SPEC_RBH_VHS;
3703         strcpy(type,"SPEC_RBH");
3704         break;
3705
3706     case INFO_GEN_RBH_TYPE:
3707         *size = GEN_RBH_CLOSURE_SIZE(closure);
3708         *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
3709         *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
3710         if (*ptrs <= 2) {
3711             *nonptrs -= (2 - *ptrs);
3712             *ptrs = 1;
3713         } else
3714             *ptrs -= 1;
3715         *vhs = GEN_RBH_VHS;
3716         strcpy(type,"GEN_RBH");
3717         break;
3718
3719     case INFO_CHARLIKE_TYPE:
3720         *size = CHARLIKE_CLOSURE_SIZE(closure);
3721         *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
3722         *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
3723         *vhs = CHARLIKE_VHS;
3724         strcpy(type,"CHARLIKE");
3725         break;
3726
3727     case INFO_INTLIKE_TYPE:
3728         *size = INTLIKE_CLOSURE_SIZE(closure);
3729         *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
3730         *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
3731         *vhs = INTLIKE_VHS;
3732         strcpy(type,"INTLIKE");
3733         break;
3734
3735 #  if !defined(GRAN)
3736     case INFO_FETCHME_TYPE:
3737         *size = FETCHME_CLOSURE_SIZE(closure);
3738         *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
3739         *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
3740         *vhs = FETCHME_VHS;
3741         strcpy(type,"FETCHME");
3742         break;
3743
3744     case INFO_FMBQ_TYPE:
3745         *size = FMBQ_CLOSURE_SIZE(closure);
3746         *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
3747         *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
3748         *vhs = FMBQ_VHS;
3749         strcpy(type,"FMBQ");
3750         break;
3751 #  endif
3752
3753     case INFO_BQ_TYPE:
3754         *size = BQ_CLOSURE_SIZE(closure);
3755         *ptrs = BQ_CLOSURE_NoPTRS(closure);
3756         *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
3757         *vhs = BQ_VHS;
3758         strcpy(type,"BQ");
3759         break;
3760
3761     case INFO_BH_TYPE:
3762         *size = BH_CLOSURE_SIZE(closure);
3763         *ptrs = BH_CLOSURE_NoPTRS(closure);
3764         *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
3765         *vhs = BH_VHS;
3766         strcpy(type,"BH");
3767         break;
3768
3769     case INFO_TSO_TYPE:
3770         *size = 0; /* TSO_CLOSURE_SIZE(closure); */
3771         *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
3772         *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
3773         *vhs = TSO_VHS;
3774         strcpy(type,"TSO");
3775         break;
3776
3777     case INFO_STKO_TYPE:
3778         *size = 0;
3779         *ptrs = 0;
3780         *nonptrs = 0;
3781         *vhs = STKO_VHS;
3782         strcpy(type,"STKO");
3783         break;
3784
3785     default:
3786         fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
3787           INFO_TYPE(ip), (StgWord) closure);
3788         EXIT(EXIT_FAILURE);
3789     }
3790
3791     return ip;
3792 }
3793 # endif
3794
3795 # if 0
3796 // Use allocate in Storage.c instead
3797 /*
3798    @AllocateHeap@ will bump the heap pointer by @size@ words if the space
3799    is available, but it will not perform garbage collection.
3800    ToDo: check whether we can use an existing STG allocation routine -- HWL
3801 */
3802
3803
3804 //@cindex AllocateHeap
3805 StgPtr
3806 AllocateHeap(size)
3807 nat size;
3808 {
3809   StgPtr newClosure;
3810
3811   /* Allocate a new closure */
3812   if (Hp + size > HpLim)
3813     return NULL;
3814
3815   newClosure = Hp + 1;
3816   Hp += size;
3817
3818   return newClosure;
3819 }
3820 # endif
3821
3822 # if defined(PAR)
3823
3824 //@cindex doGlobalGC
3825 void
3826 doGlobalGC(void)
3827 {
3828   fprintf(stderr,"Splat -- we just hit global GC!\n");
3829   stg_exit(EXIT_FAILURE);
3830   //fishing = rtsFalse;
3831   outstandingFishes--;
3832 }
3833
3834 # endif /* PAR */
3835
3836 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
3837 //@subsection Printing Packet Contents
3838 /*
3839   Printing Packet Contents
3840   */
3841
3842 #if defined(DEBUG) || defined(GRAN_CHECK)
3843
3844 //@cindex PrintPacket
3845
3846 #if defined(PAR)
3847 void
3848 PrintPacket(packBuffer)
3849 rtsPackBuffer *packBuffer;
3850 {
3851   StgClosure *parent, *graphroot, *closure_start;
3852   const StgInfoTable *ip;
3853   globalAddr ga;
3854   StgWord **bufptr, **slotptr;
3855
3856   nat bufsize;
3857   nat pptr = 0, pptrs = 0, pvhs;
3858   nat locn = 0;
3859   nat i;
3860   nat size, ptrs, nonptrs, vhs;
3861   char str[80];
3862
3863   /* disable printing if a non-std globalisation scheme is used; ToDo: FIX */
3864   if (RtsFlags.ParFlags.globalising != 0)
3865     return;
3866
3867   /* NB: this whole routine is more or less a copy of UnpackGraph with all
3868      unpacking components replaced by printing fcts
3869      Long live higher-order fcts!
3870   */
3871   /* Initialisation */
3872   //InitPackBuffer();                  /* in case it isn't already init'd */
3873   InitClosureQueue();
3874   // ASSERT(gaga==PendingGABuffer);
3875   graphroot = (StgClosure *)NULL;
3876
3877   /* Unpack the header */
3878   bufsize = packBuffer->size;
3879   bufptr = packBuffer->buffer;
3880
3881   fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
3882           packBuffer->id, packBuffer);
3883   fprintf(stderr, "*.   size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
3884           packBuffer->size, packBuffer->unpacked_size,
3885           packBuffer->tso, packBuffer->buffer);
3886
3887   parent = (StgClosure *)NULL;
3888
3889   do {
3890     /* This is where we will ultimately save the closure's address */
3891     slotptr = bufptr;
3892     locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3893
3894     /* First, unpack the next GA or PLC */
3895     ga.weight = (rtsWeight) *bufptr++;
3896
3897     if (ga.weight == 2) {  // unglobalised closure to follow
3898       // nothing to do; closure starts at *bufptr
3899     } else if (ga.weight > 0) { // fill in GA
3900       ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3901       ga.payload.gc.slot = (int) *bufptr++;
3902     } else
3903       ga.payload.plc = (StgPtr) *bufptr++;
3904
3905     /* Now unpack the closure body, if there is one */
3906     if (isFixed(&ga)) {
3907       fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
3908       // closure = ga.payload.plc;
3909     } else if (isOffset(&ga)) {
3910       fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
3911       // closure = (StgClosure *) buffer[ga.payload.gc.slot];
3912     } else {
3913       /* Print normal closures */
3914
3915       ASSERT(bufsize > 0);
3916
3917       fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
3918               ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
3919
3920       closure_start = (StgClosure*)bufptr;
3921       ip = get_closure_info((StgClosure *)bufptr,
3922                             &size, &ptrs, &nonptrs, &vhs, str);
3923
3924       /* ToDo: check whether this is really needed */
3925       if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
3926         size = _HS;
3927         ptrs = nonptrs = vhs = 0;
3928       }
3929       /* ToDo: check whether this is really needed */
3930       if (ip->type == ARR_WORDS) {
3931         ptrs = vhs = 0;
3932         nonptrs = ((StgArrWords *)bufptr)->words;
3933         size = arr_words_sizeW((StgArrWords *)bufptr);
3934       }
3935
3936       /* special code for printing a PAP in a buffer */
3937       if (ip->type == PAP || ip->type == AP_UPD) {
3938         vhs = 3;
3939         ptrs = 0;
3940         nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
3941         size = _HS+vhs+ptrs+nonptrs;
3942       }
3943
3944       /*
3945          Remember, the generic closure layout is as follows:
3946          +-------------------------------------------------+
3947          | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
3948          +-------------------------------------------------+
3949       */
3950       /* Print fixed header */
3951       fprintf(stderr, "FH [");
3952       for (i = 0; i < _HS; i++)
3953         fprintf(stderr, " %p", *bufptr++);
3954
3955       if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
3956         size = ptrs = nonptrs = vhs = 0;
3957
3958       // VH is always empty in the new RTS
3959       ASSERT(vhs==0 ||
3960              ip->type == PAP || ip->type == AP_UPD);
3961       /* Print variable header */
3962       fprintf(stderr, "] VH [");
3963       for (i = 0; i < vhs; i++)
3964         fprintf(stderr, " %p", *bufptr++);
3965
3966       //fprintf(stderr, "] %d PTRS [", ptrs);
3967       /* Pointers will be filled in later */
3968
3969       fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
3970       /* Print non-pointers */
3971       for (i = 0; i < nonptrs; i++)
3972         fprintf(stderr, " %p", *bufptr++);
3973
3974       fprintf(stderr, "] (%s)\n", str);
3975
3976       /* Indirections are never packed */
3977       // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
3978
3979       /* Add to queue for processing
3980          When just printing the packet we do not have an unpacked closure
3981          in hand, so we feed it the packet entry;
3982          again, this assumes that at least the fixed header of the closure
3983          has the same layout in the packet; also we may not overwrite entries
3984          in the packet (done in Unpack), but for printing that's a bad idea
3985          anyway */
3986       QueueClosure((StgClosure *)closure_start);
3987
3988       /* No Common up needed for printing */
3989
3990       /* No Sort out the global address mapping for printing */
3991
3992     } /* normal closure case */
3993
3994     /* Locate next parent pointer */
3995     pptr++;
3996     while (pptr + 1 > pptrs) {
3997       parent = DeQueueClosure();
3998
3999       if (parent == NULL)
4000         break;
4001       else {
4002         (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4003                                         &pvhs, str);
4004         pptr = 0;
4005       }
4006     }
4007   } while (parent != NULL);
4008   fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
4009           packBuffer->id, packBuffer->size, size);
4010
4011 }
4012
4013 /*
4014   Doing a sanity check on a packet.
4015   This does a full iteration over the packet, as in PrintPacket.
4016 */
4017 //@cindex checkPacket
4018 void
4019 checkPacket(packBuffer)
4020 rtsPackBuffer *packBuffer;
4021 {
4022   StgClosure *parent, *graphroot, *closure_start;
4023   const StgInfoTable *ip;
4024   globalAddr ga;
4025   StgWord **bufptr, **slotptr;
4026
4027   nat bufsize;
4028   nat pptr = 0, pptrs = 0, pvhs;
4029   nat locn = 0;
4030   nat size, ptrs, nonptrs, vhs;
4031   char str[80];
4032
4033   /* NB: this whole routine is more or less a copy of UnpackGraph with all
4034      unpacking components replaced by printing fcts
4035      Long live higher-order fcts!
4036   */
4037   /* Initialisation */
4038   //InitPackBuffer();                  /* in case it isn't already init'd */
4039   InitClosureQueue();
4040   // ASSERT(gaga==PendingGABuffer);
4041   graphroot = (StgClosure *)NULL;
4042
4043   /* Unpack the header */
4044   bufsize = packBuffer->size;
4045   bufptr = packBuffer->buffer;
4046   parent = (StgClosure *)NULL;
4047   ASSERT(bufsize > 0);
4048   do {
4049     /* check that we are not at the end of the buffer, yet */
4050     IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
4051
4052     /* This is where we will ultimately save the closure's address */
4053     slotptr = bufptr;
4054     locn = slotptr-(packBuffer->buffer); // index of closure in buffer
4055     ASSERT(locn<=bufsize);
4056
4057     /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
4058     ga.weight = (rtsWeight) *bufptr++;
4059
4060     if (ga.weight == 2) {  // unglobalised closure to follow
4061       // nothing to do; closure starts at *bufptr
4062     } else if (ga.weight > 0) { // fill in GA
4063       ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
4064       ga.payload.gc.slot = (int) *bufptr++;
4065     } else
4066       ga.payload.plc = (StgPtr) *bufptr++;
4067
4068     /* Now unpack the closure body, if there is one */
4069     if (isFixed(&ga)) {
4070       /* It's a PLC */
4071       ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
4072     } else if (isOffset(&ga)) {
4073       ASSERT(ga.payload.gc.slot<=(int)bufsize);
4074     } else {
4075       /* normal closure */
4076       ASSERT(!RtsFlags.ParFlags.globalising==0 || LOOKS_LIKE_GA(&ga));
4077
4078       closure_start = (StgClosure*)bufptr;
4079       ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
4080       ip = get_closure_info((StgClosure *)bufptr,
4081                             &size, &ptrs, &nonptrs, &vhs, str);
4082
4083       /* ToDo: check whether this is really needed */
4084       if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
4085         size = _HS;
4086         ptrs = nonptrs = vhs = 0;
4087       }
4088       /* ToDo: check whether this is really needed */
4089       if (ip->type == ARR_WORDS) {
4090         ptrs = vhs = 0;
4091         nonptrs = ((StgArrWords *)bufptr)->words+1; // payload+words
4092         size = arr_words_sizeW((StgArrWords *)bufptr);
4093         ASSERT(size==_HS+vhs+nonptrs);
4094       }
4095       /* special code for printing a PAP in a buffer */
4096       if (ip->type == PAP || ip->type == AP_UPD) {
4097         vhs = 3;
4098         ptrs = 0;
4099         nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
4100         size = _HS+vhs+ptrs+nonptrs;
4101       }
4102
4103       /* no checks on contents of closure (pointers aren't packed anyway) */
4104       ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
4105       bufptr += _HS+vhs+nonptrs;
4106
4107       /* Add to queue for processing */
4108       QueueClosure((StgClosure *)closure_start);
4109
4110       /* No Common up needed for checking */
4111
4112       /* No Sort out the global address mapping for checking */
4113
4114     } /* normal closure case */
4115
4116     /* Locate next parent pointer */
4117     pptr++;
4118     while (pptr + 1 > pptrs) {
4119       parent = DeQueueClosure();
4120
4121       if (parent == NULL)
4122         break;
4123       else {
4124         //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
4125         (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4126                                         &pvhs, str);
4127         pptr = 0;
4128       }
4129     }
4130   } while (parent != NULL);
4131   /* we unpacked exactly as many words as there are in the buffer */
4132   ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
4133   /* check for magic end-of-buffer word */
4134   IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
4135 }
4136 #else  /* GRAN */
4137 void
4138 PrintPacket(buffer)
4139 rtsPackBuffer *buffer;
4140 {
4141     // extern char *info_hdr_type(P_ infoptr);  /* defined in Threads.lc */
4142     // extern char *display_info_type(P_ infoptr);      /* defined in Threads.lc */
4143
4144     StgInfoTable *info;
4145     nat size, ptrs, nonptrs, vhs;
4146     char info_hdr_ty[80];
4147     char str1[80], str2[80], junk_str[80];
4148
4149     /* globalAddr ga; */
4150
4151     nat bufsize, unpacked_size ;
4152     StgClosure *parent;
4153     nat pptr = 0, pptrs = 0, pvhs;
4154
4155     nat unpack_locn = 0;
4156     nat gastart = unpack_locn;
4157     nat closurestart = unpack_locn;
4158
4159     StgTSO *tso;
4160     StgClosure *closure, *p;
4161
4162     nat i;
4163
4164     fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
4165     fprintf(stderr, "  size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
4166             buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
4167     fputs("  contents: ", stderr);
4168     for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
4169       closure = buffer->buffer[unpack_locn];
4170       fprintf(stderr, ", %p (%s)",
4171               closure, info_type(closure));
4172     }
4173     fputc('\n', stderr);
4174
4175 #if 0
4176     /* traverse all elements of the graph; omitted for now, but might be usefule */
4177     InitClosureQueue();
4178
4179     tso = buffer->tso;
4180
4181     /* Unpack the header */
4182     unpacked_size = buffer->unpacked_size;
4183     bufsize = buffer->size;
4184
4185     fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
4186                     buffer, bufsize, unpacked_size,
4187                     tso->id, tso, where_is((StgClosure*)tso));
4188
4189     do {
4190         closurestart = unpack_locn;
4191         closure = buffer->buffer[unpack_locn++];
4192
4193         fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
4194
4195         info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
4196         strcpy(str2, str1);
4197         fprintf(stderr, "(%s|%s) ", str1, str2);
4198
4199         if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
4200             IS_BLACK_HOLE(closure))
4201           size = ptrs = nonptrs = vhs = 0;
4202
4203         if (closure_THUNK(closure)) {
4204                 if (closure_UNPOINTED(closure))
4205                     fputs("UNPOINTED ", stderr);
4206                 else
4207                     fputs("POINTED ", stderr);
4208         }
4209         if (IS_BLACK_HOLE(closure)) {
4210                 fputs("BLACK HOLE\n", stderr);
4211         } else {
4212                 /* Fixed header */
4213                 fprintf(stderr, "FH [");
4214                 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
4215                     fprintf(stderr, " %p", *p);
4216
4217                 /* Variable header
4218                 if (vhs > 0) {
4219                     fprintf(stderr, "] VH [%p", closure->payload[_HS]);
4220
4221                     for (i = 1; i < vhs; i++)
4222                         fprintf(stderr, " %p", closure->payload[_HS+i]);
4223                 }
4224                 */
4225                 fprintf(stderr, "] PTRS %u", ptrs);
4226
4227                 /* Non-pointers */
4228                 if (nonptrs > 0) {
4229                     fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
4230
4231                     for (i = 1; i < nonptrs; i++)
4232                         fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
4233
4234                     putc(']', stderr);
4235                 }
4236                 putc('\n', stderr);
4237         }
4238     } while (unpack_locn<bufsize) ;  /* (parent != NULL); */
4239
4240     fprintf(stderr, "--- End ---\n\n");
4241 #endif /* 0 */
4242 }
4243 #endif /* PAR */
4244 #endif /* DEBUG || GRAN_CHECK */
4245
4246 #endif /* PAR  || GRAN  -- whole file */
4247
4248 //@node End of file,  , Printing Packet Contents, Graph packing
4249 //@subsection End of file
4250
4251 //@index
4252 //* AllocateHeap::  @cindex\s-+AllocateHeap
4253 //* AmPacking::  @cindex\s-+AmPacking
4254 //* CommonUp::  @cindex\s-+CommonUp
4255 //* DeQueueClosure::  @cindex\s-+DeQueueClosure
4256 //* DeQueueClosure::  @cindex\s-+DeQueueClosure
4257 //* DonePacking::  @cindex\s-+DonePacking
4258 //* FillInClosure::  @cindex\s-+FillInClosure
4259 //* IS_BLACK_HOLE::  @cindex\s-+IS_BLACK_HOLE
4260 //* IS_INDIRECTION::  @cindex\s-+IS_INDIRECTION
4261 //* InitClosureQueue::  @cindex\s-+InitClosureQueue
4262 //* InitPendingGABuffer::  @cindex\s-+InitPendingGABuffer
4263 //* LocateNextParent::  @cindex\s-+LocateNextParent
4264 //* NotYetPacking::  @cindex\s-+NotYetPacking
4265 //* OffsetFor::  @cindex\s-+OffsetFor
4266 //* Pack::  @cindex\s-+Pack
4267 //* PackArray::  @cindex\s-+PackArray
4268 //* PackClosure::  @cindex\s-+PackClosure
4269 //* PackFetchMe::  @cindex\s-+PackFetchMe
4270 //* PackGeneric::  @cindex\s-+PackGeneric
4271 //* PackNearbyGraph::  @cindex\s-+PackNearbyGraph
4272 //* PackOneNode::  @cindex\s-+PackOneNode
4273 //* PackPAP::  @cindex\s-+PackPAP
4274 //* PackPLC::  @cindex\s-+PackPLC
4275 //* PackStkO::  @cindex\s-+PackStkO
4276 //* PackTSO::  @cindex\s-+PackTSO
4277 //* PendingGABuffer::  @cindex\s-+PendingGABuffer
4278 //* PrintPacket::  @cindex\s-+PrintPacket
4279 //* QueueClosure::  @cindex\s-+QueueClosure
4280 //* QueueEmpty::  @cindex\s-+QueueEmpty
4281 //* RoomToPack::  @cindex\s-+RoomToPack
4282 //* SetGAandCommonUp::  @cindex\s-+SetGAandCommonUp
4283 //* UnpackGA::  @cindex\s-+UnpackGA
4284 //* UnpackGraph::  @cindex\s-+UnpackGraph
4285 //* UnpackOffset::  @cindex\s-+UnpackOffset
4286 //* UnpackPLC::  @cindex\s-+UnpackPLC
4287 //* doGlobalGC::  @cindex\s-+doGlobalGC
4288 //* get_closure_info::  @cindex\s-+get_closure_info
4289 //* InitPackBuffer::  @cindex\s-+initPackBuffer
4290 //* isFixed::  @cindex\s-+isFixed
4291 //* isOffset::  @cindex\s-+isOffset
4292 //* offsetTable::  @cindex\s-+offsetTable
4293 //@end index
4294