rts/parallel/Pack.c

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