ghc/rts/parallel/Pack.c

   1 /*
   2    Time-stamp: <Thu Dec 16 1999 18:21:17 Stardate: [-30]4058.61 software>
   3    $Id: Pack.c,v 1.2 2000/01/13 14:34:08 hwloidl Exp $
   4
   5    Graph packing and unpacking code for sending it to another processor
   6    and retrieving the original graph structure from the packet.
   7    In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
   8    Used in GUM and GrAnSim.
   9
  10    The GrAnSim version of the code defines routines for *simulating* the
  11    packing of closures in the same way it is done in the parallel runtime
  12    system. Basically GrAnSim only puts the addresses of the closures to be
  13    transferred into a buffer. This buffer will then be associated with the
  14    event of transferring the graph. When this event is scheduled, the
  15    @UnpackGraph@ routine is called and the buffer can be discarded
  16    afterwards.
  17
  18    Note that in GranSim we need many buffers, not just one per PE.  */
  19
  20 //@node Graph packing, , ,
  21 //@section Graph packing
  22
  23 #if defined(PAR) || defined(GRAN)   /* whole file */
  24
  25 #define _HS (sizeofW(StgHeader))
  26
  27 //@menu
  28 //* Includes::
  29 //* Prototypes::
  30 //* Global variables::
  31 //* ADT of Closure Queues::
  32 //* Initialisation for packing::
  33 //* Packing Functions::
  34 //* Low level packing routines::
  35 //* Unpacking routines::
  36 //* Aux fcts for packing::
  37 //* Printing Packet Contents::
  38 //* End of file::
  39 //@end menu
  40 //*/
  41
  42 //@node Includes, Prototypes, Graph packing, Graph packing
  43 //@subsection Includes
  44
  45 #include "Rts.h"
  46 #include "RtsFlags.h"
  47 #include "RtsUtils.h"
  48 #include "ClosureTypes.h"
  49 #include "Storage.h"
  50 #include "Hash.h"
  51 #include "Parallel.h"
  52 #include "GranSimRts.h"
  53 #include "ParallelRts.h"
  54 # if defined(DEBUG)
  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        AllocClosureQueue(nat size);
  76 static inline void        InitClosureQueue(void);
  77 static inline rtsBool     QueueEmpty(void);
  78 static inline void        QueueClosure(StgClosure *closure);
  79 static inline StgClosure *DeQueueClosure(void);
  80
  81 //@node Init for packing, Packing routines, ADT of closure queues, Prototypes
  82 //@subsubsection Init for packing
  83
  84 static void     initPacking(void);
  85 # if defined(PAR)
  86 rtsBool         initPackBuffer(void);
  87 # elif defined(GRAN)
  88 rtsPackBuffer  *InstantiatePackBuffer (void);
  89 static void     reallocPackBuffer (void);
  90 # endif
  91
  92 //@node Packing routines, Low level packing fcts, Init for packing, Prototypes
  93 //@subsubsection Packing routines
  94
  95 static void    PackClosure (StgClosure *closure);
  96
  97 //@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
  98 //@subsubsection Low level packing fcts
  99
 100 # if defined(GRAN)
 101 static inline void    Pack (StgClosure *data);
 102 # else
 103 static inline void    Pack (StgWord data);
 104
 105 static void    PackPLC (StgPtr addr);
 106 static void    PackOffset (int offset);
 107 static void    GlobaliseAndPackGA (StgClosure *closure);
 108 # endif
 109
 110 //@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
 111 //@subsubsection Unpacking routines
 112
 113 # if defined(PAR)
 114 void        InitPendingGABuffer(nat size);
 115 void        CommonUp(StgClosure *src, StgClosure *dst);
 116 StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
 117                         globalAddr **gamap,
 118                         nat *nGAs);
 119 # elif defined(GRAN)
 120 void        CommonUp(StgClosure *src, StgClosure *dst);
 121 StgClosure *UnpackGraph(rtsPackBuffer* buffer);
 122 #endif
 123
 124 //@node Aux fcts for packing,  , Unpacking routines, Prototypes
 125 //@subsubsection Aux fcts for packing
 126
 127 # if defined(PAR)
 128 static void     DonePacking(void);
 129 static void     AmPacking(StgClosure *closure);
 130 static int      OffsetFor(StgClosure *closure);
 131 static rtsBool  NotYetPacking(int offset);
 132 static rtsBool  RoomToPack (nat size, nat ptrs);
 133        rtsBool  isOffset(globalAddr *ga);
 134        rtsBool  isFixed(globalAddr *ga);
 135 # elif defined(GRAN)
 136 static void     DonePacking(void);
 137 static rtsBool  NotYetPacking(StgClosure *closure);
 138 # endif
 139
 140 //@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
 141 //@subsection Global variables
 142 /*
 143   Static data declarations
 144 */
 145
 146 static nat     pack_locn,           /* ptr to first free loc in pack buffer */
 147                clq_size, clq_pos,
 148                buf_id = 1;          /* identifier for buffer */
 149 static nat     unpacked_size;
 150 static nat     reservedPAsize;        /* Space reserved for primitive arrays */
 151 static rtsBool RoomInBuffer;
 152
 153 # if defined(GRAN)
 154 /*
 155    The pack buffer
 156    To be pedantic: in GrAnSim we're packing *addresses* of closures,
 157    not the closures themselves.
 158 */
 159 static rtsPackBuffer *Bonzo = NULL;                /* size: can be set via option */
 160 # else
 161 static rtsPackBuffer *Bonzo = NULL;                /* size: can be set via option */
 162 # endif
 163
 164 /*
 165   Bit of a hack for testing if a closure is the root of the graph. This is
 166   set in @PackNearbyGraph@ and tested in @PackClosure@.
 167 */
 168
 169 static nat          packed_thunks = 0;
 170 static StgClosure  *graph_root;
 171
 172 # if defined(PAR)
 173 /*
 174   The offset hash table is used during packing to record the location in
 175   the pack buffer of each closure which is packed.
 176 */
 177 //@cindex offsetTable
 178 static HashTable *offsetTable;
 179
 180 //@cindex PendingGABuffer
 181 static globalAddr *PendingGABuffer;
 182 /* is initialised in main; */
 183 # endif /* PAR */
 184
 185 //@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
 186 //@subsection ADT of Closure Queues
 187
 188 //@menu
 189 //* Closure Queues::
 190 //* Init routines::
 191 //* Basic routines::
 192 //@end menu
 193
 194 //@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
 195 //@subsubsection Closure Queues
 196 /*
 197   Closure Queues
 198
 199   These routines manage the closure queue.
 200 */
 201
 202 static nat clq_pos, clq_size;
 203
 204 static StgClosure **ClosureQueue = NULL;   /* HWL: init in main */
 205
 206 //@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
 207 //@subsubsection Init routines
 208
 209 /* @InitClosureQueue@ initialises the closure queue. */
 210
 211 //@cindex AllocClosureQueue
 212 static inline void
 213 AllocClosureQueue(size)
 214 nat size;
 215 {
 216   ASSERT(ClosureQueue == NULL);
 217   ClosureQueue = (StgClosure**) stgMallocWords(size, "AllocClosureQueue");
 218 }
 219
 220 //@cindex InitClosureQueue
 221 static inline void
 222 InitClosureQueue(void)
 223 {
 224   clq_pos = clq_size = 0;
 225
 226   if ( ClosureQueue == NULL )
 227      AllocClosureQueue(RTS_PACK_BUFFER_SIZE);
 228 }
 229
 230 //@node Basic routines,  , Init routines, ADT of Closure Queues
 231 //@subsubsection Basic routines
 232
 233 /*
 234   QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
 235 */
 236
 237 //@cindex QueueEmpty
 238 static inline rtsBool
 239 QueueEmpty(void)
 240 {
 241   return(clq_pos >= clq_size);
 242 }
 243
 244 /* QueueClosure adds its argument to the closure queue. */
 245
 246 //@cindex QueueClosure
 247 static inline void
 248 QueueClosure(closure)
 249 StgClosure *closure;
 250 {
 251   if(clq_size < RTS_PACK_BUFFER_SIZE )
 252     ClosureQueue[clq_size++] = closure;
 253   else
 254     barf("Closure Queue Overflow (EnQueueing %p (%s))",
 255          closure, info_type(closure));
 256 }
 257
 258 /* DeQueueClosure returns the head of the closure queue. */
 259
 260 //@cindex DeQueueClosure
 261 static inline StgClosure *
 262 DeQueueClosure(void)
 263 {
 264   if(!QueueEmpty())
 265     return(ClosureQueue[clq_pos++]);
 266   else
 267     return((StgClosure*)NULL);
 268 }
 269
 270 //@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
 271 //@subsection Initialisation for packing
 272 /*
 273   Simple Packing Routines
 274
 275   About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
 276   gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
 277   words.  In the simulated PackBuffer we only keep the addresses of the
 278   closures that would be packed in the parallel system (see Pack). To
 279   decide if a packet overflow occurs pack_buffer_size must be compared
 280   versus unpacked_size (see RoomToPack).  Currently, there is no multi
 281   packet strategy implemented, so in the case of an overflow we just stop
 282   adding closures to the closure queue.  If an overflow of the simulated
 283   packet occurs, we just realloc some more space for it and carry on as
 284   usual.  -- HWL */
 285
 286 # if defined(GRAN)
 287 rtsPackBuffer *
 288 InstantiatePackBuffer (void) {
 289   extern rtsPackBuffer *Bonzo;
 290
 291   Bonzo = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
 292                          "InstantiatePackBuffer: failed to alloc packBuffer");
 293   Bonzo->size = RtsFlags.GranFlags.packBufferSize_internal;
 294   Bonzo->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
 295                                  "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
 296   /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
 297   /* stgMallocWords is now simple allocate in Storage.c */
 298
 299   return (Bonzo);
 300 }
 301
 302 /*
 303    Reallocate the GranSim internal pack buffer to make room for more closure
 304    pointers. This is independent of the check for packet overflow as in GUM
 305 */
 306 static void
 307 reallocPackBuffer (void) {
 308
 309   ASSERT(pack_locn >= (int)Bonzo->size+sizeofW(rtsPackBuffer));
 310
 311   IF_GRAN_DEBUG(packBuffer,
 312                 belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
 313                       Bonzo, Bonzo->size+REALLOC_SZ,
 314                       CurrentProc, CurrentTime[CurrentProc]));
 315
 316   Bonzo = (rtsPackBuffer*)realloc(Bonzo,
 317                                   sizeof(StgClosure*)*(REALLOC_SZ +
 318                                                        (int)Bonzo->size +
 319                                                        sizeofW(rtsPackBuffer))) ;
 320   if (Bonzo==(rtsPackBuffer*)NULL)
 321     barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n",
 322          REALLOC_SZ, Bonzo, CurrentProc, CurrentTime[CurrentProc]);
 323
 324   Bonzo->size += REALLOC_SZ;
 325
 326   ASSERT(pack_locn < Bonzo->size+sizeofW(rtsPackBuffer));
 327 }
 328 # endif
 329
 330 # if defined(PAR)
 331 /* @initPacking@ initialises the packing buffer etc. */
 332 //@cindex initPackBuffer
 333 rtsBool
 334 initPackBuffer(void)
 335 {
 336   if (Bonzo == NULL) { /* not yet allocated */
 337
 338       if ((Bonzo = (rtsPackBuffer *)
 339                      stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize,
 340                                                "initPackBuffer")) == NULL)
 341         return rtsFalse;
 342
 343       InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
 344       AllocClosureQueue(RtsFlags.ParFlags.packBufferSize);
 345   }
 346   return rtsTrue;
 347 }
 348 # endif
 349
 350 static void
 351 initPacking(void)
 352 {
 353 # if defined(GRAN)
 354   Bonzo = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
 355                                        /* NB: free in UnpackGraph */
 356 # endif
 357
 358   Bonzo->id = buf_id++;  /* buffer id are only used for debugging! */
 359   pack_locn = 0;         /* the index into the actual pack buffer */
 360   unpacked_size = 0;     /* the size of the whole graph when unpacked */
 361   reservedPAsize = 0;
 362   RoomInBuffer = rtsTrue;
 363   InitClosureQueue();
 364   packed_thunks = 0;   /* total number of thunks packed so far */
 365 # if defined(PAR)
 366   offsetTable = allocHashTable();
 367 # endif
 368 }
 369
 370 //@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
 371 //@subsection Packing Functions
 372
 373 //@menu
 374 //* Packing Sections of Nearby Graph::
 375 //* Packing Closures::
 376 //@end menu
 377
 378 //@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
 379 //@subsubsection Packing Sections of Nearby Graph
 380 /*
 381   Packing Sections of Nearby Graph
 382
 383   @PackNearbyGraph@ packs a closure and associated graph into a static
 384   buffer (@PackBuffer@).  It returns the address of this buffer and the
 385   size of the data packed into the buffer (in its second parameter,
 386   @packBufferSize@).  The associated graph is packed in a depth first
 387   manner, hence it uses an explicit queue of closures to be packed rather
 388   than simply using a recursive algorithm.  Once the packet is full,
 389   closures (other than primitive arrays) are packed as FetchMes, and their
 390   children are not queued for packing.  */
 391
 392 //@cindex PackNearbyGraph
 393
 394 /* NB: this code is shared between GranSim and GUM;
 395        tso only used in GranSim */
 396 rtsPackBuffer *
 397 PackNearbyGraph(closure, tso, packBufferSize)
 398 StgClosure* closure;
 399 StgTSO* tso;
 400 nat *packBufferSize;
 401 {
 402   extern rtsPackBuffer *Bonzo;
 403   /* Ensure enough heap for all possible RBH_Save closures */
 404
 405   ASSERT(RTS_PACK_BUFFER_SIZE > 0);
 406
 407   /* ToDo: check that we have enough heap for the packet
 408      ngoq ngo'
 409      if (Hp + PACK_HEAP_REQUIRED > HpLim)
 410      return NULL;
 411   */
 412
 413   initPacking();
 414 # if defined(GRAN)
 415   graph_root = closure;
 416 # endif
 417
 418   IF_GRAN_DEBUG(pack,
 419                 belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n    demanded by TSO %d (%p) [PE %u]",
 420                       Bonzo->id, Bonzo, closure, where_is(closure),
 421                       tso->id, tso, where_is((StgClosure*)tso)));
 422
 423   IF_GRAN_DEBUG(pack,
 424                 belch("** PrintGraph of %p is:", closure);
 425                 PrintGraph(closure,0));
 426
 427   IF_PAR_DEBUG(pack,
 428                belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n    demanded by TSO %d (%p)",
 429                      Bonzo->id, Bonzo, closure, mytid,
 430                      tso->id, tso));
 431
 432   IF_PAR_DEBUG(pack,
 433                belch("** PrintGraph of %p is:", closure);
 434                belch("** pack_locn=%d", pack_locn);
 435                PrintGraph(closure,0));
 436
 437   QueueClosure(closure);
 438   do {
 439     PackClosure(DeQueueClosure());
 440   } while (!QueueEmpty());
 441
 442 # if defined(PAR)
 443
 444   /* Record how much space is needed to unpack the graph */
 445   Bonzo->tso = tso; // ToDo: check: used in GUM or only for debugging?
 446   Bonzo->unpacked_size = unpacked_size;
 447   Bonzo->size = pack_locn;
 448
 449   /* Set the size parameter */
 450   ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize);
 451   *packBufferSize = pack_locn;
 452
 453 # else  /* GRAN */
 454
 455   /* Record how much space is needed to unpack the graph */
 456   // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;  for testing
 457   Bonzo->tso = tso;
 458   Bonzo->unpacked_size = unpacked_size;
 459
 460   // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
 461   /* ToDo: Print an earlier, more meaningful message */
 462   if (pack_locn==0)   /* i.e. packet is empty */
 463     barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
 464          closure);
 465   Bonzo->size = pack_locn;
 466   *packBufferSize = pack_locn;
 467
 468 # endif
 469
 470   DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */
 471
 472 # if defined(GRAN)
 473   IF_GRAN_DEBUG(pack ,
 474                 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
 475                       Bonzo->id, closure, Bonzo->size, packed_thunks, Bonzo->unpacked_size));
 476   if (RtsFlags.GranFlags.GranSimStats.Global) {
 477     globalGranStats.tot_packets++;
 478     globalGranStats.tot_packet_size += pack_locn;
 479   }
 480
 481   IF_GRAN_DEBUG(pack, PrintPacket(Bonzo));
 482 # elif defined(PAR)
 483   IF_GRAN_DEBUG(pack ,
 484                 belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
 485                       Bonzo->id, closure, Bonzo->size, packed_thunks, Bonzo->unpacked_size);
 486                 PrintPacket(Bonzo));
 487 # endif   /* GRAN */
 488
 489   return (Bonzo);
 490 }
 491
 492 //@cindex PackOneNode
 493
 494 # if defined(GRAN)
 495 /* This version is used when the node is already local */
 496
 497 rtsPackBuffer *
 498 PackOneNode(closure, tso, packBufferSize)
 499 StgClosure* closure;
 500 StgTSO* tso;
 501 nat *packBufferSize;
 502 {
 503   extern rtsPackBuffer *Bonzo;
 504   int i, clpack_locn;
 505
 506   initPacking();
 507
 508   IF_GRAN_DEBUG(pack,
 509                 belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
 510                       closure, info_type(closure),
 511                       where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
 512
 513   Pack(closure);
 514
 515   /* Record how much space is needed to unpack the graph */
 516   Bonzo->tso = tso;
 517   Bonzo->unpacked_size = unpacked_size;
 518
 519   /* Set the size parameter */
 520   ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
 521   Bonzo->size =  pack_locn;
 522   *packBufferSize = pack_locn;
 523
 524   if (RtsFlags.GranFlags.GranSimStats.Global) {
 525     globalGranStats.tot_packets++;
 526     globalGranStats.tot_packet_size += pack_locn;
 527   }
 528   IF_GRAN_DEBUG(pack,
 529     PrintPacket(Bonzo));
 530
 531   return (Bonzo);
 532 }
 533 # endif  /* GRAN */
 534
 535 #if defined(GRAN)
 536
 537 /*
 538    PackTSO and PackStkO are entry points for two special kinds of closure
 539    which are used in the parallel RTS.  Compared with other closures they
 540    are rather awkward to pack because they don't follow the normal closure
 541    layout (where all pointers occur before all non-pointers).  Luckily,
 542    they're only needed when migrating threads between processors.  */
 543
 544 //@cindex PackTSO
 545 rtsPackBuffer*
 546 PackTSO(tso, packBufferSize)
 547 StgTSO *tso;
 548 nat *packBufferSize;
 549 {
 550   extern rtsPackBuffer *Bonzo;
 551   IF_GRAN_DEBUG(pack,
 552                 belch("** Packing TSO %d (%p)", tso->id, tso));
 553   *packBufferSize = 0;
 554   // PackBuffer[0] = PackBuffer[1] = 0; ???
 555   return(Bonzo);
 556 }
 557
 558 //@cindex PackStkO
 559 rtsPackBuffer*
 560 PackStkO(stko, packBufferSize)
 561 StgPtr stko;
 562 nat *packBufferSize;
 563 {
 564   extern rtsPackBuffer *Bonzo;
 565   IF_GRAN_DEBUG(pack,
 566                 belch("** Packing STKO %p", stko));
 567   *packBufferSize = 0;
 568   // PackBuffer[0] = PackBuffer[1] = 0;
 569   return(Bonzo);
 570 }
 571
 572 void
 573 PackFetchMe(StgClosure *closure)
 574 {
 575   barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
 576 }
 577
 578 #elif defined(PAR)
 579
 580 rtsPackBuffer*
 581 PackTSO(tso, packBufferSize)
 582 StgTSO *tso;
 583 nat *packBufferSize;
 584 {
 585   barf("{PackTSO}Daq Qagh: trying to pack a TSO; thread migrations not supported, yet");
 586 }
 587
 588 rtsPackBuffer*
 589 PackStkO(stko, packBufferSize)
 590 StgPtr stko;
 591 nat *packBufferSize;
 592 {
 593   barf("{PackStkO}Daq Qagh: trying to pack a STKO; thread migrations not supported, yet");
 594 }
 595
 596 //@cindex PackFetchMe
 597 void
 598 PackFetchMe(StgClosure *closure)
 599 {
 600   StgInfoTable *ip;
 601   nat i;
 602
 603 #if defined(GRAN)
 604   barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
 605 #else
 606   /* Pack a FetchMe closure instead of closure */
 607   ip = &FETCH_ME_info;
 608   /* this assumes that the info ptr is always the first word in a closure*/
 609   Pack((StgWord)ip);
 610   for (i = 1; i < _HS; ++i)               // pack rest of fixed header
 611     Pack((StgWord)*(((StgPtr)closure)+i));
 612
 613   unpacked_size += _HS; // ToDo: check
 614 #endif
 615 }
 616
 617 #endif
 618
 619 //@node Packing Closures,  , Packing Sections of Nearby Graph, Packing Functions
 620 //@subsubsection Packing Closures
 621 /*
 622   Packing Closures
 623
 624   @PackClosure@ is the heart of the normal packing code.  It packs a single
 625   closure into the pack buffer, skipping over any indirections and
 626   globalising it as necessary, queues any child pointers for further
 627   packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
 628   locally if it was a thunk.  Before the actual closure is packed, a
 629   suitable global address (GA) is inserted in the pack buffer.  There is
 630   always room to pack a fetch-me to the closure (guaranteed by the
 631   RoomToPack calculation), and this is packed if there is no room for the
 632   entire closure.
 633
 634   Space is allocated for any primitive array children of a closure, and
 635   hence a primitive array can always be packed along with it's parent
 636   closure.  */
 637
 638 //@cindex PackClosure
 639
 640 # if defined(PAR)
 641
 642 void
 643 PackClosure(closure)
 644 StgClosure *closure;
 645 {
 646   StgInfoTable *info;
 647   StgClosure *indirectee, *rbh;
 648   nat size, ptrs, nonptrs, vhs, i, clpack_locn;
 649   rtsBool is_CONSTR = rtsFalse;
 650   char str[80];
 651
 652   ASSERT(closure!=NULL);
 653   indirectee = closure;
 654   do {
 655     /* Don't pack indirection closures */
 656     closure =  indirectee;
 657     indirectee = IS_INDIRECTION(closure);
 658     IF_PAR_DEBUG(pack,
 659                  if (indirectee)
 660                    belch("** Shorted an indirection (%s) at %p (-> %p)",
 661                          info_type(closure), closure, indirectee));
 662   } while (indirectee);
 663
 664   clpack_locn = OffsetFor(closure);
 665
 666   /* If the closure has been packed already, just pack an indirection to it
 667      to guarantee that the graph doesn't become a tree when unpacked */
 668   if (!NotYetPacking(clpack_locn)) {
 669     StgInfoTable *info;
 670
 671     PackOffset(clpack_locn);
 672     return;
 673   }
 674
 675   /*
 676    * PLCs reside on all of the PEs already. Just pack the
 677    * address as a GA (a bit of a kludge, since an address may
 678    * not fit in *any* of the individual GA fields). Const,
 679    * charlike and small intlike closures are converted into
 680    * PLCs.
 681    */
 682   switch (get_itbl(closure)->type) {
 683
 684 #  ifdef DEBUG
 685     // check error cases only in a debugging setup
 686   case RET_BCO:
 687   case RET_SMALL:
 688   case RET_VEC_SMALL:
 689   case RET_BIG:
 690   case RET_VEC_BIG:
 691   case RET_DYN:
 692     barf("** {Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
 693          closure, info_type(closure));
 694     /* never reached */
 695
 696   case UPDATE_FRAME:
 697   case STOP_FRAME:
 698   case CATCH_FRAME:
 699   case SEQ_FRAME:
 700     barf("** {Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
 701          closure, info_type(closure));
 702     /* never reached */
 703
 704   case TSO:
 705   case BLOCKED_FETCH:
 706   case EVACUATED:
 707     /* something's very wrong */
 708     barf("** {Pack}Daq Qagh: found %s (%p) when packing",
 709          info_type(closure), closure);
 710     /* never reached */
 711 #  endif
 712
 713   case CONSTR_CHARLIKE:
 714     IF_PAR_DEBUG(pack,
 715                  belch("** Packing a charlike closure %d",
 716                        ((StgIntCharlikeClosure*)closure)->data));
 717
 718     PackPLC(CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
 719     return;
 720
 721   case CONSTR_INTLIKE:
 722     {
 723       StgInt val = ((StgIntCharlikeClosure*)closure)->data;
 724
 725       if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
 726         IF_PAR_DEBUG(pack,
 727                      belch("** Packing a small intlike %d as a PLC", val));
 728         PackPLC(INTLIKE_CLOSURE(val));
 729         return;
 730       } else {
 731         IF_PAR_DEBUG(pack,
 732                      belch("** Packing a big intlike %d as a normal closure",
 733                            val));
 734         break;
 735       }
 736     }
 737
 738   case CONSTR:
 739   case CONSTR_1_0:
 740   case CONSTR_0_1:
 741   case CONSTR_2_0:
 742   case CONSTR_1_1:
 743   case CONSTR_0_2:
 744     /* it's a constructor (i.e. plain data) but we don't know
 745        how many ptrs, non-ptrs there are => use generic code */
 746     IF_PAR_DEBUG(pack,
 747                  belch("** Packing a CONSTR %p (%s) using generic packing with GA",
 748                        closure, info_type(closure)));
 749     // is_CONSTR = rtsTrue;
 750     break;
 751     /* fall through to generic packing code */
 752
 753   case CONSTR_STATIC:
 754   case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
 755                            // evaluated on each PE if needed
 756     IF_PAR_DEBUG(pack,
 757       belch("** Packing a %p (%s) as a PLC",
 758             closure, info_type(closure)));
 759
 760     PackPLC(closure);
 761     return;
 762
 763   case MVAR:
 764     /* MVARs may not be copied; they are sticky objects in the new RTS */
 765     /* therefore we treat them just as RBHs etc (what a great system!) */
 766     IF_PAR_DEBUG(pack,
 767                  belch("** Found an MVar at %p (%s)",
 768                        closure, info_type(closure)));
 769     /* fall through !! */
 770
 771   case THUNK_SELECTOR: // ToDo: fix packing of this strange beast
 772     IF_PAR_DEBUG(pack,
 773                  belch("** Found an THUNK_SELECTORE at %p (%s)",
 774                        closure, info_type(closure)));
 775     /* fall through !! */
 776
 777   case CAF_BLACKHOLE:
 778   case SE_CAF_BLACKHOLE:
 779   case SE_BLACKHOLE:
 780   case BLACKHOLE:
 781   case RBH:
 782   case FETCH_ME:
 783   case FETCH_ME_BQ:
 784
 785     /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
 786     //ASSERT(pack_locn > PACK_HDR_SIZE);
 787
 788     IF_PAR_DEBUG(pack,
 789                  belch("** Packing a BH or FM at %p (%s) of (fixed size %d)",
 790                        closure, info_type(closure), _HS));
 791
 792     /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
 793     GlobaliseAndPackGA(closure);
 794
 795     PackFetchMe(closure);
 796     return;
 797
 798   default:
 799 /*      IF_PAR_DEBUG(pack, */
 800 /*               belch("** Not a PLC or BH ... ")); */
 801   } /* switch */
 802
 803   /* get info about basic layout of the closure */
 804   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
 805
 806   ASSERT(!IS_BLACK_HOLE(closure));
 807
 808   IF_PAR_DEBUG(pack,
 809                fprintf(stderr, "** packing %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
 810                        closure, info_type(closure), size, ptrs, nonptrs));
 811
 812   /*
 813    * Now peek ahead to see whether the closure has any primitive array
 814    * children
 815    */
 816   /*
 817       ToDo: fix this code -- HWL
 818     for (i = 0; i < ptrs; ++i) {
 819       StgInfoTable * childInfo;
 820       nat childSize, childPtrs, childNonPtrs, childVhs;
 821
 822       // extract i-th pointer out of closure
 823       childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
 824                                    &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
 825       if (IS_BIG_MOTHER(childInfo)) {
 826         reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
 827           + childPtrs * PACK_FETCHME_SIZE;
 828       }
 829     }
 830     */
 831   /* Record the location of the GA */
 832   AmPacking(closure);
 833
 834   /* Pack the global address */
 835   if (!is_CONSTR) {
 836     GlobaliseAndPackGA(closure);
 837   } else {
 838     IF_PAR_DEBUG(pack,
 839                  belch("** No GA allocated for CONSTR %p (%s)",
 840                        closure, info_type(closure)));
 841   }
 842
 843   /*
 844    * Pack a fetchme to the closure if it's a black hole, or the buffer is full
 845    * and it isn't a primitive array. N.B. Primitive arrays are always packed
 846    * (because their parents index into them directly)
 847    */
 848
 849   // ToDo: pack FMs if no more room available in packet (see below)
 850   if (!(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)))
 851     barf("** Qagh: Pack: not enough room in packet to pack closure %p (%s)",
 852          closure, info_type(closure));
 853
 854   /*
 855     Has been moved into the switch statement
 856
 857     if (IS_BLACK_HOLE(closure))
 858     !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
 859     || IS_BIG_MOTHER(info)))
 860     {
 861
 862       ASSERT(pack_locn > PACK_HDR_SIZE);
 863
 864       info = FetchMe_info;
 865       for (i = 0; i < FIXED_HS; ++i) {
 866         if (i == INFO_HDR_POSN)
 867           Pack((StgWord) FetchMe_info);
 868         else
 869           Pack(closure[i]);
 870       }
 871
 872       unpacked_size += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
 873
 874     } else {
 875   */
 876   if (info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
 877       info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR)
 878     belch("** ghuH: found %s; packing of primitive arrays not yet implemented",
 879           info_type(closure));
 880
 881   /* At last! A closure we can actually pack! */
 882   if (ip_MUTABLE(info) && (info->type != FETCH_ME))
 883     fprintf(stderr, "** ghuH: Replicated a Mutable closure!\n");
 884
 885   /*
 886      Remember, the generic closure layout is as follows:
 887         +-------------------------------------------------+
 888         | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
 889         +-------------------------------------------------+
 890   */
 891   /* pack fixed and variable header */
 892   for (i = 0; i < _HS + vhs; ++i)
 893     Pack((StgWord)*(((StgPtr)closure)+i));
 894
 895   /* register all ptrs for further packing */
 896   for (i = 0; i < ptrs; ++i)
 897     QueueClosure(((StgClosure *) *(((StgPtr)closure)+(i+_HS+vhs))));
 898
 899   /* pack non-ptrs */
 900   for (i = 0; i < nonptrs; ++i)
 901     Pack((StgWord)*(((StgPtr)closure)+(i+_HS+vhs+ptrs)));
 902
 903   unpacked_size += _HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
 904
 905   /*
 906    * Record that this is a revertable black hole so that we can fill in
 907    * its address from the fetch reply.  Problem: unshared thunks may cause
 908    * space leaks this way, their GAs should be deallocated following an
 909    * ACK.
 910    */
 911
 912   // IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) !? HWL
 913   if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
 914     rbh = convertToRBH(closure);
 915     ASSERT(rbh == closure); // rbh at the same position (minced version)
 916     packed_thunks++;
 917   }
 918 }
 919
 920 # else  /* GRAN */
 921
 922 /* Fake the packing of a closure */
 923
 924 void
 925 PackClosure(closure)
 926 StgClosure *closure;
 927 {
 928   StgInfoTable *info, *childInfo;
 929   nat size, ptrs, nonptrs, vhs;
 930   char info_hdr_ty[80];
 931   nat i;
 932   StgClosure *indirectee, *rbh;
 933   char str[80];
 934   rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
 935
 936   is_mutable = rtsFalse;
 937
 938   /* In GranSim we don't pack and unpack closures -- we just simulate
 939      packing by updating the bitmask. So, the graph structure is unchanged
 940      i.e. we don't short out indirections here. -- HWL */
 941
 942   /* Nothing to do with packing but good place to (sanity) check closure;
 943      if the closure is a thunk, it must be unique; otherwise we have copied
 944      work at some point before that which violates one of our main global
 945      assertions in GranSim/GUM */
 946   ASSERT(!closure_THUNK(closure) || is_unique(closure));
 947
 948   IF_GRAN_DEBUG(pack,
 949                 belch("**  Packing closure %p (%s)",
 950                       closure, info_type(closure)));
 951
 952   if (where_is(closure) != where_is(graph_root)) {
 953     IF_GRAN_DEBUG(pack,
 954                   belch("**   faking a FETCHME [current PE: %d, closure's PE: %d]",
 955                         where_is(graph_root), where_is(closure)));
 956
 957     /* GUM would pack a FETCHME here; simulate that by increasing the */
 958     /* unpacked size accordingly but don't pack anything -- HWL */
 959     unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
 960     return;
 961   }
 962
 963   /* If the closure's not already being packed */
 964   if (!NotYetPacking(closure))
 965     /* Don't have to do anything in GrAnSim if closure is already */
 966     /* packed -- HWL */
 967     {
 968       IF_GRAN_DEBUG(pack,
 969                     belch("**    Closure %p is already packed and omitted now!",
 970                             closure));
 971       return;
 972     }
 973
 974   switch (get_itbl(closure)->type) {
 975     /* ToDo: check for sticky bit here? */
 976     /* BH-like closures which must not be moved to another PE */
 977     case CAF_BLACKHOLE:       /* # of ptrs, nptrs: 0,2 */
 978     case SE_BLACKHOLE:        /* # of ptrs, nptrs: 0,2 */
 979     case SE_CAF_BLACKHOLE:    /* # of ptrs, nptrs: 0,2 */
 980     case BLACKHOLE:           /* # of ptrs, nptrs: 0,2 */
 981     case BLACKHOLE_BQ:        /* # of ptrs, nptrs: 1,1 */
 982     case RBH:                 /* # of ptrs, nptrs: 1,1 */
 983       /* same for these parallel specific closures */
 984     case BLOCKED_FETCH:
 985     case FETCH_ME:
 986     case FETCH_ME_BQ:
 987       IF_GRAN_DEBUG(pack,
 988         belch("**    Avoid packing BH-like closures (%p, %s)!",
 989               closure, info_type(closure)));
 990       /* Just ignore RBHs i.e. they stay where they are */
 991       return;
 992
 993     case THUNK_SELECTOR:
 994       {
 995         StgClosure *sel = ((StgSelector *)closure)->selectee;
 996
 997         IF_GRAN_DEBUG(pack,
 998                       belch("**    Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
 999                             closure, info_type(closure), sel, info_type(sel)));
1000         QueueClosure(sel);
1001         IF_GRAN_DEBUG(pack,
1002                       belch("**    [%p (%s) (Queueing closure) ....]",
1003                             sel, info_type(sel)));
1004       }
1005       return;
1006
1007     case CONSTR_STATIC:
1008     case CONSTR_NOCAF_STATIC:
1009                                   /* For now we ship indirections to CAFs:
1010                                    * They are evaluated on each PE if needed */
1011       IF_GRAN_DEBUG(pack,
1012         belch("**    Nothing to pack for %p (%s)!",
1013               closure, info_type(closure)));
1014       // Pack(closure); GUM only
1015       return;
1016
1017     case CONSTR_CHARLIKE:
1018     case CONSTR_INTLIKE:
1019       IF_GRAN_DEBUG(pack,
1020         belch("**    Nothing to pack for %s (%p)!",
1021               closure, info_type(closure)));
1022       // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1023       return;
1024
1025     case AP_UPD:
1026     case PAP:
1027       /* partial applications; special treatment necessary? */
1028       break;
1029
1030     case CAF_UNENTERED:    /* # of ptrs, nptrs: 1,3 */
1031     case CAF_ENTERED:      /* # of ptrs, nptrs: 0,4  (allegedly bogus!!) */
1032       /* CAFs; special treatment necessary? */
1033       break;
1034
1035     case MVAR:
1036       barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1037            closure, info_type(closure));
1038
1039     case ARR_WORDS:
1040     case MUT_VAR:
1041     case MUT_ARR_PTRS:
1042     case MUT_ARR_PTRS_FROZEN:
1043       /* Mutable objects; require special treatment to ship all data */
1044       is_mutable = rtsTrue;
1045       break;
1046
1047     case WEAK:
1048     case FOREIGN:
1049     case STABLE_NAME:
1050           /* weak pointers and other FFI objects */
1051       barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1052            closure, info_type(closure));
1053
1054     case TSO:
1055       /* parallel objects */
1056       barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1057            closure, info_type(closure));
1058
1059     case BCO:
1060       /* Hugs objects (i.e. closures used by the interpreter) */
1061       barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1062            closure, info_type(closure));
1063
1064     case IND:              /* # of ptrs, nptrs: 1,0 */
1065     case IND_STATIC:       /* # of ptrs, nptrs: 1,0 */
1066     case IND_PERM:         /* # of ptrs, nptrs: 1,1 */
1067     case IND_OLDGEN:       /* # of ptrs, nptrs: 1,1 */
1068     case IND_OLDGEN_PERM:  /* # of ptrs, nptrs: 1,1 */
1069       /* we shouldn't find an indirection here, because we have shorted them
1070          out at the beginning of this functions already.
1071       */
1072       break;
1073       /* should be:
1074       barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1075            closure, info_type(closure));
1076       */
1077
1078     case UPDATE_FRAME:
1079     case CATCH_FRAME:
1080     case SEQ_FRAME:
1081     case STOP_FRAME:
1082       /* stack frames; should never be found when packing for now;
1083          once we support thread migration these have to be covered properly
1084       */
1085       barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1086            closure, info_type(closure));
1087
1088     case RET_BCO:
1089     case RET_SMALL:
1090     case RET_VEC_SMALL:
1091     case RET_BIG:
1092     case RET_VEC_BIG:
1093     case RET_DYN:
1094       /* vectored returns; should never be found when packing; */
1095       barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1096            closure, info_type(closure));
1097
1098     case INVALID_OBJECT:
1099       barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1100            closure, info_type(closure));
1101
1102     default:
1103       /*
1104          Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1105          a specialised version with wired in #ptr/#nptr info; currently
1106          we treat these specialised versions like the generic version)
1107       */
1108     }     /* switch */
1109
1110     /* Otherwise it's not Fixed */
1111
1112     info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1113     will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1114
1115     IF_GRAN_DEBUG(pack,
1116                 belch("**    Info on closure %p (%s): size=%d; ptrs=%d",
1117                       closure, info_type(closure),
1118                       size, ptrs,
1119                       (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1120
1121     // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1122     no_more_thunks_please =
1123       (RtsFlags.GranFlags.ThunksToPack>0) &&
1124       (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1125
1126     /*
1127       should be covered by get_closure_info
1128     if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1129         info->type == BLACKHOLE || info->type == RBH )
1130       size = ptrs = nonptrs = vhs = 0;
1131     */
1132     /* Now peek ahead to see whether the closure has any primitive */
1133     /* array children */
1134     /*
1135        ToDo: fix this code
1136        for (i = 0; i < ptrs; ++i) {
1137        P_ childInfo;
1138        W_ childSize, childPtrs, childNonPtrs, childVhs;
1139
1140        childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
1141        &childSize, &childPtrs, &childNonPtrs,
1142        &childVhs, junk_str);
1143        if (IS_BIG_MOTHER(childInfo)) {
1144        reservedPAsize += PACK_GA_SIZE + FIXED_HS +
1145        childVhs + childNonPtrs +
1146        childPtrs * PACK_FETCHME_SIZE;
1147        PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
1148        PAptrs += childPtrs;
1149        }
1150        }
1151     */
1152     /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1153      * is full and it isn't a primitive array. N.B. Primitive arrays are
1154      * always packed (because their parents index into them directly) */
1155
1156     if (IS_BLACK_HOLE(closure))
1157         /*
1158           ToDo: fix this code
1159           ||
1160           !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
1161           || IS_BIG_MOTHER(info)))
1162           */
1163       return;
1164
1165     /* At last! A closure we can actually pack! */
1166
1167     if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1168       belch("ghuH: Replicated a Mutable closure!");
1169
1170     if (RtsFlags.GranFlags.GranSimStats.Global &&
1171         no_more_thunks_please && will_be_rbh) {
1172       globalGranStats.tot_cuts++;
1173       if ( RtsFlags.GranFlags.Debug.pack )
1174         belch("**    PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1175                 RtsFlags.GranFlags.ThunksToPack, closure);
1176     } else if (will_be_rbh || (closure==graph_root) ) {
1177       packed_thunks++;
1178       globalGranStats.tot_thunks++;
1179     }
1180
1181     if (no_more_thunks_please && will_be_rbh)
1182       return; /* don't pack anything */
1183
1184     /* actual PACKING done here --  HWL */
1185     Pack(closure);
1186     for (i = 0; i < ptrs; ++i) {
1187       /* extract i-th pointer from closure */
1188       QueueClosure((StgClosure *)payloadPtr(closure,i));
1189       IF_GRAN_DEBUG(pack,
1190                     belch("**    [%p (%s) (Queueing closure) ....]",
1191                           payloadPtr(closure,i), info_type(payloadPtr(closure,i))));
1192     }
1193
1194     /*
1195        for packing words (GUM only) do something like this:
1196
1197        for (i = 0; i < ptrs; ++i) {
1198          Pack(payloadWord(obj,i+j));
1199        }
1200     */
1201     /* Turn thunk into a revertible black hole. */
1202     if (will_be_rbh) {
1203         rbh = convertToRBH(closure);
1204         ASSERT(rbh != NULL);
1205     }
1206 }
1207 # endif  /* PAR */
1208
1209 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1210 //@subsection Low level packing routines
1211
1212 /*
1213    @Pack@ is the basic packing routine.  It just writes a word of data into
1214    the pack buffer and increments the pack location.  */
1215
1216 //@cindex Pack
1217
1218 # if defined(PAR)
1219 static inline void
1220 Pack(data)
1221 StgWord data;
1222 {
1223   ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1224   Bonzo->buffer[pack_locn++] = data;
1225 }
1226 #endif
1227
1228 #if defined(GRAN)
1229 static inline void
1230 Pack(closure)
1231 StgClosure *closure;
1232 {
1233   StgInfoTable *info;
1234   nat size, ptrs, nonptrs, vhs;
1235   char str[80];
1236
1237   /* This checks the size of the GrAnSim internal pack buffer. The simulated
1238      pack buffer is checked via RoomToPack (as in GUM) */
1239   if (pack_locn >= (int)Bonzo->size+sizeofW(rtsPackBuffer))
1240     reallocPackBuffer();
1241
1242   if (closure==(StgClosure*)NULL)
1243     belch("Qagh {Pack}Daq: Trying to pack 0");
1244   Bonzo->buffer[pack_locn++] = closure;
1245   /* ASSERT: Data is a closure in GrAnSim here */
1246   info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1247   unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1248                                         MIN_UPD_SIZE :
1249                                         size);
1250 }
1251 # endif  /* GRAN */
1252
1253 /*
1254    If a closure is local, make it global.  Then, divide its weight for
1255    export.  The GA is then packed into the pack buffer.  */
1256
1257 # if defined(PAR)
1258
1259 static void
1260 GlobaliseAndPackGA(closure)
1261 StgClosure *closure;
1262 {
1263   globalAddr *ga;
1264   globalAddr packGA;
1265
1266   if ((ga = LAGAlookup(closure)) == NULL)
1267     ga = makeGlobal(closure, rtsTrue);
1268   splitWeight(&packGA, ga);
1269   ASSERT(packGA.weight > 0);
1270
1271   IF_PAR_DEBUG(pack,
1272                fprintf(stderr, "** Globalising closure %p (%s) with GA",
1273                        closure, info_type(closure));
1274                printGA(&packGA);
1275                fputc('\n', stderr));
1276
1277
1278   Pack((StgWord) packGA.weight);
1279   Pack((StgWord) packGA.payload.gc.gtid);
1280   Pack((StgWord) packGA.payload.gc.slot);
1281 }
1282
1283 /*
1284    @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
1285    address follows instead of PE, slot.  */
1286
1287 //@cindex PackPLC
1288
1289 static void
1290 PackPLC(addr)
1291 StgPtr addr;
1292 {
1293   Pack(0L);                     /* weight */
1294   Pack((StgWord) addr);         /* address */
1295 }
1296
1297 /*
1298    @PackOffset@ packs a special GA value that will be interpreted as an
1299    offset to a closure in the pack buffer.  This is used to avoid unfolding
1300    the graph structure into a tree.  */
1301
1302 static void
1303 PackOffset(offset)
1304 int offset;
1305 {
1306   IF_PAR_DEBUG(pack,
1307                belch("** Packing Offset %d at pack location %u",
1308                      offset, pack_locn));
1309   Pack(1L);                     /* weight */
1310   Pack(0L);                     /* pe */
1311   Pack(offset);                 /* slot/offset */
1312 }
1313 # endif  /* PAR */
1314
1315 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
1316 //@subsection Unpacking routines
1317
1318 /*
1319   This was formerly in the (now deceased) module Unpack.c
1320
1321   Unpacking closures which have been exported to remote processors
1322
1323   This module defines routines for unpacking closures in the parallel
1324   runtime system (GUM).
1325
1326   In the case of GrAnSim, this module defines routines for *simulating* the
1327   unpacking of closures as it is done in the parallel runtime system.
1328 */
1329
1330 //@node GUM code, Local Definitions, Unpacking routines, Unpacking routines
1331 //@subsubsection GUM code
1332
1333 #if defined(PAR)
1334
1335 //@cindex InitPendingGABuffer
1336 void
1337 InitPendingGABuffer(size)
1338 nat size;
1339 {
1340   PendingGABuffer = (globalAddr *)
1341                       stgMallocBytes(size*2*sizeof(globalAddr),
1342                                      "InitPendingGABuffer");
1343 }
1344
1345 /*
1346   @CommonUp@ commons up two closures which we have discovered to be
1347   variants of the same object.  One is made an indirection to the other.  */
1348
1349 //@cindex CommonUp
1350 void
1351 CommonUp(StgClosure *src, StgClosure *dst)
1352 {
1353   StgBlockingQueueElement *bqe;
1354
1355   ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
1356   ASSERT(src != dst);
1357
1358   IF_PAR_DEBUG(verbose,
1359                belch("__ CommonUp %p (%s) with %p (%s)",
1360                      src, info_type(src), dst, info_type(dst)));
1361
1362   switch (get_itbl(src)->type) {
1363   case BLACKHOLE_BQ:
1364     bqe = ((StgBlockingQueue *)src)->blocking_queue;
1365     break;
1366
1367   case FETCH_ME_BQ:
1368     bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
1369     break;
1370
1371   case RBH:
1372     bqe = ((StgRBH *)src)->blocking_queue;
1373     break;
1374
1375   case BLACKHOLE:
1376   case FETCH_ME:
1377     bqe = END_BQ_QUEUE;
1378     break;
1379
1380   default:
1381     /* Don't common up anything else */
1382     return;
1383   }
1384   /* NB: this also awakens the blocking queue for src */
1385   UPD_IND(src, dst);
1386   // updateWithIndirection(src, dst);
1387   /*
1388     ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
1389     if (bqe != END_BQ_QUEUE)
1390     awaken_blocked_queue(bqe, src);
1391   */
1392 }
1393
1394 /*
1395   @UnpackGraph@ unpacks the graph contained in a message buffer.  It
1396   returns a pointer to the new graph.  The @gamap@ parameter is set to
1397   point to an array of (oldGA,newGA) pairs which were created as a result
1398   of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
1399   were created.
1400
1401   The format of graph in the pack buffer is as defined in @Pack.lc@.  */
1402
1403 //@cindex UnpackGraph
1404 StgClosure *
1405 UnpackGraph(packBuffer, gamap, nGAs)
1406 rtsPackBuffer *packBuffer;
1407 globalAddr **gamap;
1408 nat *nGAs;
1409 {
1410   nat size, ptrs, nonptrs, vhs;
1411   StgWord **buffer, **bufptr, **slotptr;
1412   globalAddr ga, *gaga;
1413   StgClosure *closure, *existing,
1414              *graphroot, *graph, *parent;
1415   StgInfoTable *ip, *oldip;
1416   nat bufsize, i,
1417       pptr = 0, pptrs = 0, pvhs;
1418   rtsBool hasGA;
1419   char str[80];
1420
1421   initPackBuffer();                  /* in case it isn't already init'd */
1422   graphroot = (StgClosure *)NULL;
1423
1424   gaga = PendingGABuffer;
1425
1426   InitClosureQueue();
1427
1428   /* Unpack the header */
1429   bufsize = packBuffer->size;
1430   buffer = packBuffer->buffer;
1431   bufptr = buffer;
1432
1433   /* allocate heap */
1434   if (bufsize > 0) {
1435     graph = allocate(bufsize);
1436     ASSERT(graph != NULL);
1437   }
1438
1439   parent = (StgClosure *)NULL;
1440
1441   do {
1442     /* This is where we will ultimately save the closure's address */
1443     slotptr = bufptr;
1444
1445     /* First, unpack the next GA or PLC */
1446     ga.weight = (rtsWeight) *bufptr++;
1447
1448     if (ga.weight > 0) {
1449       ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
1450       ga.payload.gc.slot = (int) *bufptr++;
1451     } else {
1452       ga.payload.plc = (StgPtr) *bufptr++;
1453     }
1454
1455     /* Now unpack the closure body, if there is one */
1456     if (isFixed(&ga)) {
1457       /* No more to unpack; just set closure to local address */
1458       IF_PAR_DEBUG(pack,
1459                    belch("_* Unpacked PLC at %x", ga.payload.plc));
1460       hasGA = rtsFalse;
1461       closure = ga.payload.plc;
1462     } else if (isOffset(&ga)) {
1463       /* No more to unpack; just set closure to cached address */
1464       IF_PAR_DEBUG(pack,
1465                    belch("_* Unpacked indirection to %p (was offset %x)",
1466                          (StgClosure *) buffer[ga.payload.gc.slot],
1467                          ga.payload.gc.slot));
1468       ASSERT(parent != (StgClosure *)NULL);
1469       hasGA = rtsFalse;
1470       closure = (StgClosure *) buffer[ga.payload.gc.slot];
1471     } else {
1472       /* Now we have to build something. */
1473       hasGA = rtsTrue;
1474
1475       ASSERT(bufsize > 0);
1476
1477       /*
1478        * Close your eyes.  You don't want to see where we're looking. You
1479        * can't get closure info until you've unpacked the variable header,
1480        * but you don't know how big it is until you've got closure info.
1481        * So...we trust that the closure in the buffer is organized the
1482        * same way as they will be in the heap...at least up through the
1483        * end of the variable header.
1484        */
1485       ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
1486
1487       /*
1488          Remember, the generic closure layout is as follows:
1489          +-------------------------------------------------+
1490          | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1491          +-------------------------------------------------+
1492       */
1493       /* Fill in the fixed header */
1494       for (i = 0; i < _HS; i++)
1495         ((StgPtr)graph)[i] = (StgWord)*bufptr++;
1496
1497       if (ip->type == FETCH_ME)
1498         size = ptrs = nonptrs = vhs = 0;
1499
1500       /* Fill in the packed variable header */
1501       for (i = 0; i < vhs; i++)
1502         ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
1503
1504       /* Pointers will be filled in later */
1505
1506       /* Fill in the packed non-pointers */
1507       for (i = 0; i < nonptrs; i++)
1508         ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
1509
1510       /* Indirections are never packed */
1511       // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
1512
1513       /* Add to queue for processing */
1514       QueueClosure(graph);
1515
1516       /*
1517        * Common up the new closure with any existing closure having the same
1518        * GA
1519        */
1520
1521       if ((existing = GALAlookup(&ga)) == NULL) {
1522         globalAddr *newGA;
1523         /* Just keep the new object */
1524         IF_PAR_DEBUG(pack,
1525                      belch("_* Unpacking new GA ((%x, %d, %x))",
1526                            ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight));
1527
1528         closure = graph;
1529         newGA = setRemoteGA(graph, &ga, rtsTrue);
1530         if (ip->type == FETCH_ME)
1531           // FETCHME_GA(closure) = newGA;
1532           ((StgFetchMe *)closure)->ga = newGA;
1533       } else {
1534         /* Two closures, one global name.  Someone loses */
1535         oldip = get_itbl(existing);
1536
1537         if ((oldip->type == FETCH_ME ||
1538              // ToDo: don't pack a GA for these in the first place
1539              oldip->type == CONSTR ||
1540              oldip->type == CONSTR_1_0 ||
1541              oldip->type == CONSTR_0_1 ||
1542              oldip->type == CONSTR_2_0 ||
1543              oldip->type == CONSTR_1_1 ||
1544              oldip->type == CONSTR_0_2 ||
1545              IS_BLACK_HOLE(existing)) &&
1546             ip->type != FETCH_ME) {
1547
1548           /* What we had wasn't worth keeping */
1549           closure = graph;
1550           CommonUp(existing, graph);
1551         } else {
1552           StgWord ty;
1553
1554           /*
1555            * Either we already had something worthwhile by this name or
1556            * the new thing is just another FetchMe.  However, the thing we
1557            * just unpacked has to be left as-is, or the child unpacking
1558            * code will fail.  Remember that the way pointer words are
1559            * filled in depends on the info pointers of the parents being
1560            * the same as when they were packed.
1561            */
1562           IF_PAR_DEBUG(pack,
1563                        belch("_* Unpacking old GA ((%x, %d, %x)), keeping %#lx",
1564                              ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight,
1565                              existing));
1566
1567           closure = existing;
1568           // HACK
1569           ty = get_itbl(closure)->type;
1570           if (ty == CONSTR ||
1571               ty == CONSTR_1_0 ||
1572               ty == CONSTR_0_1 ||
1573               ty == CONSTR_2_0 ||
1574               ty == CONSTR_1_1 ||
1575               ty == CONSTR_0_2)
1576             CommonUp(closure, graph);
1577
1578         }
1579         /* Pool the total weight in the stored ga */
1580         (void) addWeight(&ga);
1581       }
1582
1583       /* Sort out the global address mapping */
1584       if (hasGA || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
1585           (ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
1586         /* Make up new GAs for single-copy closures */
1587         globalAddr *newGA = makeGlobal(closure, rtsTrue);
1588
1589         // keep this assertion!
1590         // ASSERT(closure == graph);
1591
1592         /* Create an old GA to new GA mapping */
1593         *gaga++ = ga;
1594         splitWeight(gaga, newGA);
1595         ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
1596         gaga++;
1597       }
1598       graph += _HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
1599     }
1600
1601     /*
1602      * Set parent pointer to point to chosen closure.  If we're at the top of
1603      * the graph (our parent is NULL), then we want to arrange to return the
1604      * chosen closure to our caller (possibly in place of the allocated graph
1605      * root.)
1606      */
1607     if (parent == NULL)
1608       graphroot = closure;
1609     else
1610       ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
1611
1612     /* Save closure pointer for resolving offsets */
1613     *slotptr = (StgWord) closure;
1614
1615     /* Locate next parent pointer */
1616     pptr++;
1617     while (pptr + 1 > pptrs) {
1618       parent = DeQueueClosure();
1619
1620       if (parent == NULL)
1621         break;
1622       else {
1623         (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
1624                                         &pvhs, str);
1625         pptr = 0;
1626       }
1627     }
1628   } while (parent != NULL);
1629
1630   //ASSERT(bufsize == 0 || graph - 1 <= SAVE_Hp);
1631
1632   *gamap = PendingGABuffer;
1633   *nGAs = (gaga - PendingGABuffer) / 2;
1634
1635   /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
1636   ASSERT(graphroot!=NULL);
1637   return (graphroot);
1638 }
1639 #endif  /* PAR */
1640
1641 //@node GranSim Code,  , Local Definitions, Unpacking routines
1642 //@subsubsection GranSim Code
1643
1644 /*
1645    For GrAnSim: No actual unpacking should be necessary. We just
1646    have to walk over the graph and set the bitmasks appropriately.
1647    Since we use RBHs similarly to GUM but without an ACK message/event
1648    we have to revert the RBH from within the UnpackGraph routine (good luck!)
1649    -- HWL
1650 */
1651
1652 #if defined(GRAN)
1653 void
1654 CommonUp(StgClosure *src, StgClosure *dst)
1655 {
1656   barf("CommonUp: should never be entered in a GranSim setup");
1657 }
1658
1659 StgClosure*
1660 UnpackGraph(buffer)
1661 rtsPackBuffer* buffer;
1662 {
1663   nat size, ptrs, nonptrs, vhs,
1664       bufptr = 0;
1665   StgClosure *closure, *graphroot, *graph;
1666   StgInfoTable *ip;
1667   StgWord bufsize, unpackedsize,
1668           pptr = 0, pptrs = 0, pvhs;
1669   StgTSO* tso;
1670   char str[240], str1[80];
1671   int i;
1672
1673   bufptr = 0;
1674   graphroot = buffer->buffer[0];
1675
1676   tso = buffer->tso;
1677
1678   /* Unpack the header */
1679   unpackedsize = buffer->unpacked_size;
1680   bufsize = buffer->size;
1681
1682   IF_GRAN_DEBUG(pack,
1683                 belch("<<< Unpacking <<%d>> (buffer @ %p):\n    (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
1684                       buffer->id, buffer, graphroot, where_is(graphroot),
1685                       bufsize, tso->id, tso,
1686                       where_is((StgClosure *)tso)));
1687
1688   do {
1689     closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
1690
1691     /* Actually only ip is needed; rest is useful for TESTING -- HWL */
1692     ip = get_closure_info(closure,
1693                           &size, &ptrs, &nonptrs, &vhs, str);
1694
1695     IF_GRAN_DEBUG(pack,
1696                   sprintf(str, "**    (%p): Changing bitmask[%s]: 0x%x ",
1697                           closure, (closure_HNF(closure) ? "NF" : "__"),
1698                           PROCS(closure)));
1699
1700     if (get_itbl(closure)->type == RBH) {
1701       /* if it's an RBH, we have to revert it into a normal closure, thereby
1702          awakening the blocking queue; not that this is code currently not
1703          needed in GUM, but it should be added with the new features in
1704          GdH (and the implementation of an NACK message)
1705       */
1706       // closure->header.gran.procs = PE_NUMBER(CurrentProc);
1707       SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc));    /* Move node */
1708
1709       IF_GRAN_DEBUG(pack,
1710                     strcat(str, " (converting RBH) "));
1711
1712       convertFromRBH(closure);   /* In GUM that's done by convertToFetchMe */
1713
1714       IF_GRAN_DEBUG(pack,
1715                     belch("::  closure %p (%s) is a RBH; after reverting: IP=%p",
1716                           closure, info_type(closure), get_itbl(closure)));
1717     } else if (IS_BLACK_HOLE(closure)) {
1718       IF_GRAN_DEBUG(pack,
1719                     belch("::  closure %p (%s) is a BH; copying node to %d",
1720                           closure, info_type(closure), CurrentProc));
1721       closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
1722     } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
1723       if (closure_HNF(closure)) {
1724         IF_GRAN_DEBUG(pack,
1725                       belch("::  closure %p (%s) is a HNF; copying node to %d",
1726                             closure, info_type(closure), CurrentProc));
1727         closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
1728       } else {
1729         IF_GRAN_DEBUG(pack,
1730                       belch("::  closure %p (%s) is no (R)BH or HNF; moving node to %d",
1731                             closure, info_type(closure), CurrentProc));
1732         closure->header.gran.procs = PE_NUMBER(CurrentProc);  /* Move node */
1733       }
1734     }
1735
1736     IF_GRAN_DEBUG(pack,
1737                   sprintf(str1, "0x%x",   PROCS(closure)); strcat(str, str1));
1738     IF_GRAN_DEBUG(pack, belch(str));
1739
1740   } while (bufptr<buffer->size) ;   /*  (parent != NULL);  */
1741
1742   /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
1743   free(buffer->buffer);
1744   free(buffer);
1745
1746   IF_GRAN_DEBUG(pack,
1747                 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
1748
1749   return (graphroot);
1750 }
1751 #endif  /* GRAN */
1752
1753 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
1754 //@subsection Aux fcts for packing
1755
1756 //@menu
1757 //* Offset table::
1758 //* Packet size::
1759 //* Types of Global Addresses::
1760 //* Closure Info::
1761 //@end menu
1762
1763 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
1764 //@subsubsection Offset table
1765
1766 /*
1767    DonePacking is called when we've finished packing.  It releases memory
1768    etc.  */
1769
1770 //@cindex DonePacking
1771
1772 # if defined(PAR)
1773
1774 static void
1775 DonePacking(void)
1776 {
1777   freeHashTable(offsetTable, NULL);
1778   offsetTable = NULL;
1779 }
1780
1781 /*
1782    AmPacking records that the closure is being packed.  Note the abuse of
1783    the data field in the hash table -- this saves calling @malloc@!  */
1784
1785 //@cindex AmPacking
1786
1787 static void
1788 AmPacking(closure)
1789 StgClosure *closure;
1790 {
1791 /*    IF_PAR_DEBUG(pack, */
1792 /*             fprintf(stderr, "** AmPacking %p (%s)(IP %p) at %u\n",  */
1793 /*                     closure, info_type(closure), get_itbl(closure), pack_locn)); */
1794
1795   insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
1796 }
1797
1798 /*
1799    OffsetFor returns an offset for a closure which is already being packed.  */
1800
1801 //@cindex OffsetFor
1802
1803 static int
1804 OffsetFor(closure)
1805 StgClosure *closure;
1806 {
1807   return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
1808 }
1809
1810 /*
1811    NotYetPacking determines whether the closure's already being packed.
1812    Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.  */
1813
1814 //@cindex NotYetPacking
1815
1816 static rtsBool
1817 NotYetPacking(offset)
1818 int offset;
1819 {
1820   return(offset == 0); // ToDo: what if root is found again?? FIX
1821 }
1822
1823 # else  /* GRAN */
1824
1825 static void
1826 DonePacking(void)
1827 {
1828   /* nothing */
1829 }
1830
1831 /*
1832    NotYetPacking searches through the whole pack buffer for closure.  */
1833
1834 static rtsBool
1835 NotYetPacking(closure)
1836 StgClosure *closure;
1837 { nat i;
1838   rtsBool found = rtsFalse;
1839
1840   for (i=0; (i<pack_locn) && !found; i++)
1841     found = Bonzo->buffer[i]==closure;
1842
1843   return (!found);
1844 }
1845 # endif
1846
1847 //@node Packet size, Types of Global Addresses, Offset table, Aux fcts for packing
1848 //@subsubsection Packet size
1849
1850 /*
1851   RoomToPack determines whether there's room to pack the closure into
1852   the pack buffer based on
1853
1854   o how full the buffer is already,
1855   o the closures' size and number of pointers (which must be packed as GAs),
1856   o the size and number of pointers held by any primitive arrays that it
1857     points to
1858
1859     It has a *side-effect* (naughty, naughty) in assigning RoomInBuffer
1860     to rtsFalse.
1861 */
1862
1863 //@cindex RoomToPack
1864 static rtsBool
1865 RoomToPack(size, ptrs)
1866 nat size, ptrs;
1867 {
1868 # if defined(PAR)
1869   if (RoomInBuffer &&
1870       (pack_locn + reservedPAsize + size +
1871        ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
1872     {
1873       IF_PAR_DEBUG(pack,
1874                    fprintf(stderr, "Buffer full\n"));
1875
1876       RoomInBuffer = rtsFalse;
1877     }
1878 # else   /* GRAN */
1879   if (RoomInBuffer &&
1880       (unpacked_size + reservedPAsize + size +
1881        ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
1882     {
1883       IF_GRAN_DEBUG(packBuffer,
1884                     fprintf(stderr, "Buffer full\n"));
1885       RoomInBuffer = rtsFalse;
1886     }
1887 # endif
1888   return (RoomInBuffer);
1889 }
1890
1891 //@node Types of Global Addresses, Closure Info, Packet size, Aux fcts for packing
1892 //@subsubsection Types of Global Addresses
1893
1894 /*
1895   Types of Global Addresses
1896
1897   These routines determine whether a GA is one of a number of special types
1898   of GA.
1899 */
1900
1901 # if defined(PAR)
1902 //@cindex isOffset
1903 rtsBool
1904 isOffset(ga)
1905 globalAddr *ga;
1906 {
1907     return (ga->weight == 1 && ga->payload.gc.gtid == 0);
1908 }
1909
1910 //@cindex isFixed
1911 rtsBool
1912 isFixed(ga)
1913 globalAddr *ga;
1914 {
1915     return (ga->weight == 0);
1916 }
1917 # endif
1918
1919 //@node Closure Info,  , Types of Global Addresses, Aux fcts for packing
1920 //@subsubsection Closure Info
1921
1922 /*
1923    Closure Info
1924
1925    @get_closure_info@ determines the size, number of pointers etc. for this
1926    type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
1927
1928 [Can someone please keep this function up to date.  I keep needing it
1929  (or something similar) for interpretive code, and it keeps
1930  bit-rotting.  {\em It really belongs somewhere else too}.  KH @@ 17/2/95] */
1931
1932 #if 0
1933
1934 // {Parallel.h}Daq ngoqvam vIroQpu'
1935
1936 # if defined(GRAN) || defined(PAR)
1937 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
1938 //@cindex get_closure_info
1939 StgInfoTable*
1940 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
1941 StgClosure* node;
1942 nat *size, *ptrs, *nonptrs, *vhs;
1943 char *info_hdr_ty;
1944 {
1945   StgInfoTable *info;
1946
1947   info = get_itbl(node);
1948   /* the switch shouldn't be necessary, really; just use default case */
1949   switch (info->type) {
1950 #if 0
1951    case CONSTR_1_0:
1952    case THUNK_1_0:
1953    case FUN_1_0:
1954      *size = sizeW_fromITBL(info);
1955      *ptrs = (nat) 1; // (info->layout.payload.ptrs);
1956      *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
1957      *vhs = (nat) 0; // unknown
1958      info_hdr_type(node, info_hdr_ty);
1959      return info;
1960
1961   case CONSTR_0_1:
1962   case THUNK_0_1:
1963   case FUN_0_1:
1964      *size = sizeW_fromITBL(info);
1965      *ptrs = (nat) 0; // (info->layout.payload.ptrs);
1966      *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
1967      *vhs = (nat) 0; // unknown
1968      info_hdr_type(node, info_hdr_ty);
1969      return info;
1970
1971   case CONSTR_2_0:
1972   case THUNK_2_0:
1973   case FUN_2_0:
1974      *size = sizeW_fromITBL(info);
1975      *ptrs = (nat) 2; // (info->layout.payload.ptrs);
1976      *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
1977      *vhs = (nat) 0; // unknown
1978      info_hdr_type(node, info_hdr_ty);
1979      return info;
1980
1981   case CONSTR_1_1:
1982   case THUNK_1_1:
1983   case FUN_1_1:
1984      *size = sizeW_fromITBL(info);
1985      *ptrs = (nat) 1; // (info->layout.payload.ptrs);
1986      *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
1987      *vhs = (nat) 0; // unknown
1988      info_hdr_type(node, info_hdr_ty);
1989      return info;
1990
1991   case CONSTR_0_2:
1992   case THUNK_0_2:
1993   case FUN_0_2:
1994      *size = sizeW_fromITBL(info);
1995      *ptrs = (nat) 0; // (info->layout.payload.ptrs);
1996      *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
1997      *vhs = (nat) 0; // unknown
1998      info_hdr_type(node, info_hdr_ty);
1999      return info;
2000 #endif
2001   case RBH:
2002     {
2003       StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
2004       *size = sizeW_fromITBL(rip);
2005       *ptrs = (nat) (rip->layout.payload.ptrs);
2006       *nonptrs = (nat) (rip->layout.payload.nptrs);
2007       *vhs = (nat) 0; // unknown
2008       info_hdr_type(node, info_hdr_ty);
2009       return rip;  // NB: we return the reverted info ptr for a RBH!!!!!!
2010     }
2011
2012   default:
2013     *size = sizeW_fromITBL(info);
2014     *ptrs = (nat) (info->layout.payload.ptrs);
2015     *nonptrs = (nat) (info->layout.payload.nptrs);
2016     *vhs = (nat) 0; // unknown
2017     info_hdr_type(node, info_hdr_ty);
2018     return info;
2019   }
2020 }
2021
2022 //@cindex IS_BLACK_HOLE
2023 rtsBool
2024 IS_BLACK_HOLE(StgClosure* node)
2025 {
2026   StgInfoTable *info;
2027   info = get_itbl(node);
2028   return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
2029 }
2030
2031 //@cindex IS_INDIRECTION
2032 StgClosure *
2033 IS_INDIRECTION(StgClosure* node)
2034 {
2035   StgInfoTable *info;
2036   info = get_itbl(node);
2037   switch (info->type) {
2038     case IND:
2039     case IND_OLDGEN:
2040     case IND_PERM:
2041     case IND_OLDGEN_PERM:
2042     case IND_STATIC:
2043       /* relies on indirectee being at same place for all these closure types */
2044       return (((StgInd*)node) -> indirectee);
2045     default:
2046       return NULL;
2047   }
2048 }
2049
2050 /*
2051 rtsBool
2052 IS_THUNK(StgClosure* node)
2053 {
2054   StgInfoTable *info;
2055   info = get_itbl(node);
2056   return ((info->type == THUNK ||
2057            info->type == THUNK_STATIC ||
2058            info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
2059 }
2060 */
2061
2062 # endif /* GRAN */
2063 #endif /* 0 */
2064
2065 # if 0
2066 /* ngoq ngo' */
2067
2068 P_
2069 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
2070 P_ closure;
2071 W_ *size, *ptrs, *nonptrs, *vhs;
2072 char *type;
2073 {
2074    P_ ip = (P_) INFO_PTR(closure);
2075
2076    if (closure==NULL) {
2077      fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
2078      *size = *ptrs = *nonptrs = *vhs = 0;
2079      strcpy(type,"ERROR in get_closure_info");
2080      return;
2081    } else if (closure==PrelBase_Z91Z93_closure) {
2082      /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
2083      *size = *ptrs = *nonptrs = *vhs = 0;
2084      strcpy(type,"PrelBase_Z91Z93_closure");
2085      return;
2086    };
2087
2088     ip = (P_) INFO_PTR(closure);
2089
2090     switch (INFO_TYPE(ip)) {
2091     case INFO_SPEC_U_TYPE:
2092     case INFO_SPEC_S_TYPE:
2093     case INFO_SPEC_N_TYPE:
2094         *size = SPEC_CLOSURE_SIZE(closure);
2095         *ptrs = SPEC_CLOSURE_NoPTRS(closure);
2096         *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
2097         *vhs = 0 /*SPEC_VHS*/;
2098         strcpy(type,"SPEC");
2099         break;
2100
2101     case INFO_GEN_U_TYPE:
2102     case INFO_GEN_S_TYPE:
2103     case INFO_GEN_N_TYPE:
2104         *size = GEN_CLOSURE_SIZE(closure);
2105         *ptrs = GEN_CLOSURE_NoPTRS(closure);
2106         *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
2107         *vhs = GEN_VHS;
2108         strcpy(type,"GEN");
2109         break;
2110
2111     case INFO_DYN_TYPE:
2112         *size = DYN_CLOSURE_SIZE(closure);
2113         *ptrs = DYN_CLOSURE_NoPTRS(closure);
2114         *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
2115         *vhs = DYN_VHS;
2116         strcpy(type,"DYN");
2117         break;
2118
2119     case INFO_TUPLE_TYPE:
2120         *size = TUPLE_CLOSURE_SIZE(closure);
2121         *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
2122         *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
2123         *vhs = TUPLE_VHS;
2124         strcpy(type,"TUPLE");
2125         break;
2126
2127     case INFO_DATA_TYPE:
2128         *size = DATA_CLOSURE_SIZE(closure);
2129         *ptrs = DATA_CLOSURE_NoPTRS(closure);
2130         *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
2131         *vhs = DATA_VHS;
2132         strcpy(type,"DATA");
2133         break;
2134
2135     case INFO_IMMUTUPLE_TYPE:
2136     case INFO_MUTUPLE_TYPE:
2137         *size = MUTUPLE_CLOSURE_SIZE(closure);
2138         *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
2139         *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
2140         *vhs = MUTUPLE_VHS;
2141         strcpy(type,"(IM)MUTUPLE");
2142         break;
2143
2144     case INFO_STATIC_TYPE:
2145         *size = STATIC_CLOSURE_SIZE(closure);
2146         *ptrs = STATIC_CLOSURE_NoPTRS(closure);
2147         *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
2148         *vhs = STATIC_VHS;
2149         strcpy(type,"STATIC");
2150         break;
2151
2152     case INFO_CAF_TYPE:
2153     case INFO_IND_TYPE:
2154         *size = IND_CLOSURE_SIZE(closure);
2155         *ptrs = IND_CLOSURE_NoPTRS(closure);
2156         *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
2157         *vhs = IND_VHS;
2158         strcpy(type,"CAF|IND");
2159         break;
2160
2161     case INFO_CONST_TYPE:
2162         *size = CONST_CLOSURE_SIZE(closure);
2163         *ptrs = CONST_CLOSURE_NoPTRS(closure);
2164         *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
2165         *vhs = CONST_VHS;
2166         strcpy(type,"CONST");
2167         break;
2168
2169     case INFO_SPEC_RBH_TYPE:
2170         *size = SPEC_RBH_CLOSURE_SIZE(closure);
2171         *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
2172         *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
2173         if (*ptrs <= 2) {
2174             *nonptrs -= (2 - *ptrs);
2175             *ptrs = 1;
2176         } else
2177             *ptrs -= 1;
2178         *vhs = SPEC_RBH_VHS;
2179         strcpy(type,"SPEC_RBH");
2180         break;
2181
2182     case INFO_GEN_RBH_TYPE:
2183         *size = GEN_RBH_CLOSURE_SIZE(closure);
2184         *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
2185         *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
2186         if (*ptrs <= 2) {
2187             *nonptrs -= (2 - *ptrs);
2188             *ptrs = 1;
2189         } else
2190             *ptrs -= 1;
2191         *vhs = GEN_RBH_VHS;
2192         strcpy(type,"GEN_RBH");
2193         break;
2194
2195     case INFO_CHARLIKE_TYPE:
2196         *size = CHARLIKE_CLOSURE_SIZE(closure);
2197         *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
2198         *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
2199         *vhs = CHARLIKE_VHS;
2200         strcpy(type,"CHARLIKE");
2201         break;
2202
2203     case INFO_INTLIKE_TYPE:
2204         *size = INTLIKE_CLOSURE_SIZE(closure);
2205         *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
2206         *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
2207         *vhs = INTLIKE_VHS;
2208         strcpy(type,"INTLIKE");
2209         break;
2210
2211 #  if !defined(GRAN)
2212     case INFO_FETCHME_TYPE:
2213         *size = FETCHME_CLOSURE_SIZE(closure);
2214         *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
2215         *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
2216         *vhs = FETCHME_VHS;
2217         strcpy(type,"FETCHME");
2218         break;
2219
2220     case INFO_FMBQ_TYPE:
2221         *size = FMBQ_CLOSURE_SIZE(closure);
2222         *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
2223         *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
2224         *vhs = FMBQ_VHS;
2225         strcpy(type,"FMBQ");
2226         break;
2227 #  endif
2228
2229     case INFO_BQ_TYPE:
2230         *size = BQ_CLOSURE_SIZE(closure);
2231         *ptrs = BQ_CLOSURE_NoPTRS(closure);
2232         *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
2233         *vhs = BQ_VHS;
2234         strcpy(type,"BQ");
2235         break;
2236
2237     case INFO_BH_TYPE:
2238         *size = BH_CLOSURE_SIZE(closure);
2239         *ptrs = BH_CLOSURE_NoPTRS(closure);
2240         *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
2241         *vhs = BH_VHS;
2242         strcpy(type,"BH");
2243         break;
2244
2245     case INFO_TSO_TYPE:
2246         *size = 0; /* TSO_CLOSURE_SIZE(closure); */
2247         *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
2248         *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
2249         *vhs = TSO_VHS;
2250         strcpy(type,"TSO");
2251         break;
2252
2253     case INFO_STKO_TYPE:
2254         *size = 0;
2255         *ptrs = 0;
2256         *nonptrs = 0;
2257         *vhs = STKO_VHS;
2258         strcpy(type,"STKO");
2259         break;
2260
2261     default:
2262         fprintf(stderr, "get_closure_info:  Unexpected closure type (%lu), closure %lx\n",
2263           INFO_TYPE(ip), (StgWord) closure);
2264         EXIT(EXIT_FAILURE);
2265     }
2266
2267     return ip;
2268 }
2269 # endif
2270
2271 # if 0
2272 // Use allocate in Storage.c instead
2273 /*
2274    @AllocateHeap@ will bump the heap pointer by @size@ words if the space
2275    is available, but it will not perform garbage collection.
2276    ToDo: check whether we can use an existing STG allocation routine -- HWL
2277 */
2278
2279
2280 //@cindex AllocateHeap
2281 StgPtr
2282 AllocateHeap(size)
2283 nat size;
2284 {
2285   StgPtr newClosure;
2286
2287   /* Allocate a new closure */
2288   if (Hp + size > HpLim)
2289     return NULL;
2290
2291   newClosure = Hp + 1;
2292   Hp += size;
2293
2294   return newClosure;
2295 }
2296 # endif
2297
2298 # if defined(PAR)
2299
2300 //@cindex doGlobalGC
2301 void
2302 doGlobalGC(void)
2303 {
2304   fprintf(stderr,"Splat -- we just hit global GC!\n");
2305   stg_exit(EXIT_FAILURE);
2306   //fishing = rtsFalse;
2307   outstandingFishes--;
2308 }
2309
2310 # endif /* PAR */
2311
2312 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
2313 //@subsection Printing Packet Contents
2314 /*
2315   Printing Packet Contents
2316   */
2317
2318 #if defined(DEBUG) || defined(GRAN_CHECK)
2319
2320 //@cindex PrintPacket
2321
2322 #if defined(PAR)
2323 void
2324 PrintPacket(packBuffer)
2325 rtsPackBuffer *packBuffer;
2326 {
2327   StgClosure *parent, *graphroot, *closure_start;
2328   StgInfoTable *ip, *oldip;
2329   globalAddr ga;
2330   StgWord **buffer, **bufptr, **slotptr;
2331
2332   nat bufsize;
2333   nat pptr = 0, pptrs = 0, pvhs;
2334   nat unpack_locn = 0;
2335   nat gastart = unpack_locn;
2336   nat closurestart = unpack_locn;
2337   nat i;
2338   nat size, ptrs, nonptrs, vhs;
2339   char str[80];
2340
2341   /* NB: this whole routine is more or less a copy of UnpackGraph with all
2342      unpacking components replaced by printing fcts
2343      Long live higher-order fcts!
2344   */
2345   initPackBuffer();                  /* in case it isn't already init'd */
2346   graphroot = (StgClosure *)NULL;
2347
2348   // gaga = PendingGABuffer;
2349
2350   InitClosureQueue();
2351
2352   /* Unpack the header */
2353   bufsize = packBuffer->size;
2354   buffer = packBuffer->buffer;
2355   bufptr = buffer;
2356
2357   /* allocate heap
2358   if (bufsize > 0) {
2359     graph = allocate(bufsize);
2360     ASSERT(graph != NULL);
2361   }
2362   */
2363
2364   fprintf(stderr, ".* Printing <<%d>> (buffer @ %p):\n",
2365           packBuffer->id, packBuffer);
2366   fprintf(stderr, ".*   size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
2367           packBuffer->size, packBuffer->unpacked_size,
2368           packBuffer->tso, packBuffer->buffer);
2369
2370   parent = (StgClosure *)NULL;
2371
2372   do {
2373     /* This is where we will ultimately save the closure's address */
2374     slotptr = bufptr;
2375
2376     /* First, unpack the next GA or PLC */
2377     ga.weight = (rtsWeight) *bufptr++;
2378
2379     if (ga.weight > 0) {
2380       ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
2381       ga.payload.gc.slot = (int) *bufptr++;
2382     } else
2383       ga.payload.plc = (StgPtr) *bufptr++;
2384
2385     /* Now unpack the closure body, if there is one */
2386     if (isFixed(&ga)) {
2387       fprintf(stderr, ".* [%u]: PLC @ %p\n", gastart, ga.payload.plc);
2388       // closure = ga.payload.plc;
2389     } else if (isOffset(&ga)) {
2390       fprintf(stderr, ".* [%u]: OFFSET TO [%d]\n", gastart, ga.payload.gc.slot);
2391       // closure = (StgClosure *) buffer[ga.payload.gc.slot];
2392     } else {
2393       /* Print normal closures */
2394
2395       ASSERT(bufsize > 0);
2396
2397       fprintf(stderr, ".* [%u]: ((%x, %d, %x)) ", gastart,
2398               ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
2399
2400       closure_start = bufptr;
2401       ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2402
2403       /*
2404          Remember, the generic closure layout is as follows:
2405          +-------------------------------------------------+
2406          | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2407          +-------------------------------------------------+
2408       */
2409       /* Print fixed header */
2410       fprintf(stderr, "FH [");
2411       for (i = 0; i < _HS; i++)
2412         fprintf(stderr, " %p", *bufptr++);
2413
2414       if (ip->type == FETCH_ME)
2415         size = ptrs = nonptrs = vhs = 0;
2416
2417       /* Print variable header */
2418       fprintf(stderr, "] VH [");
2419       for (i = 0; i < vhs; i++)
2420         fprintf(stderr, " %p", *bufptr++);
2421
2422       fprintf(stderr, "] %d PTRS [", ptrs);
2423
2424       /* Pointers will be filled in later */
2425
2426       fprintf(stderr, " ] %d NON-PTRS [", nonptrs);
2427       /* Print non-pointers */
2428       for (i = 0; i < nonptrs; i++)
2429         fprintf(stderr, " %p", *bufptr++);
2430
2431       fprintf(stderr, "] (%s)\n", str);
2432
2433       /* Indirections are never packed */
2434       // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2435
2436       /* Add to queue for processing
2437          When just printing the packet we do not have an unpacked closure
2438          in hand, so we feed it the packet entry;
2439          again, this assumes that at least the fixed header of the closure
2440          has the same layout in the packet; also we may not overwrite entries
2441          in the packet (done in Unpack), but for printing that's a bad idea
2442          anyway */
2443       QueueClosure((StgClosure *)closure_start);
2444
2445       /* No Common up needed for printing */
2446
2447       /* No Sort out the global address mapping for printing */
2448
2449     } /* normal closure case */
2450
2451     /* Locate next parent pointer */
2452     pptr++;
2453     while (pptr + 1 > pptrs) {
2454       parent = DeQueueClosure();
2455
2456       if (parent == NULL)
2457         break;
2458       else {
2459         (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
2460                                         &pvhs, str);
2461         pptr = 0;
2462       }
2463     }
2464   } while (parent != NULL);
2465   fprintf(stderr, ".* --- End packet <<%d>> ---\n", packBuffer->id);
2466 }
2467 #else  /* GRAN */
2468 void
2469 PrintPacket(buffer)
2470 rtsPackBuffer *buffer;
2471 {
2472     // extern char *info_hdr_type(P_ infoptr);  /* defined in Threads.lc */
2473     // extern char *display_info_type(P_ infoptr);      /* defined in Threads.lc */
2474
2475     StgInfoTable *info;
2476     nat size, ptrs, nonptrs, vhs;
2477     char info_hdr_ty[80];
2478     char str1[80], str2[80], junk_str[80];
2479
2480     /* globalAddr ga; */
2481
2482     nat bufsize, unpacked_size ;
2483     StgClosure *parent;
2484     nat pptr = 0, pptrs = 0, pvhs;
2485
2486     nat unpack_locn = 0;
2487     nat gastart = unpack_locn;
2488     nat closurestart = unpack_locn;
2489
2490     StgTSO *tso;
2491     StgClosure *closure, *p;
2492
2493     nat i;
2494
2495     fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
2496     fprintf(stderr, "  size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
2497             buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
2498     fputs("  contents: ", stderr);
2499     for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
2500       closure = buffer->buffer[unpack_locn];
2501       fprintf(stderr, ", %p (%s)",
2502               closure, info_type(closure));
2503     }
2504     fputc('\n', stderr);
2505
2506 #if 0
2507     /* traverse all elements of the graph; omitted for now, but might be usefule */
2508     InitClosureQueue();
2509
2510     tso = buffer->tso;
2511
2512     /* Unpack the header */
2513     unpacked_size = buffer->unpacked_size;
2514     bufsize = buffer->size;
2515
2516     fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
2517                     buffer, bufsize, unpacked_size,
2518                     tso->id, tso, where_is((StgClosure*)tso));
2519
2520     do {
2521         closurestart = unpack_locn;
2522         closure = buffer->buffer[unpack_locn++];
2523
2524         fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
2525
2526         info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
2527         strcpy(str2, str1);
2528         fprintf(stderr, "(%s|%s) ", str1, str2);
2529
2530         if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
2531             IS_BLACK_HOLE(closure))
2532           size = ptrs = nonptrs = vhs = 0;
2533
2534         if (closure_THUNK(closure)) {
2535                 if (closure_UNPOINTED(closure))
2536                     fputs("UNPOINTED ", stderr);
2537                 else
2538                     fputs("POINTED ", stderr);
2539         }
2540         if (IS_BLACK_HOLE(closure)) {
2541                 fputs("BLACK HOLE\n", stderr);
2542         } else {
2543                 /* Fixed header */
2544                 fprintf(stderr, "FH [");
2545                 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
2546                     fprintf(stderr, " %p", *p);
2547
2548                 /* Variable header
2549                 if (vhs > 0) {
2550                     fprintf(stderr, "] VH [%p", closure->payload[_HS]);
2551
2552                     for (i = 1; i < vhs; i++)
2553                         fprintf(stderr, " %p", closure->payload[_HS+i]);
2554                 }
2555                 */
2556                 fprintf(stderr, "] PTRS %u", ptrs);
2557
2558                 /* Non-pointers */
2559                 if (nonptrs > 0) {
2560                     fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
2561
2562                     for (i = 1; i < nonptrs; i++)
2563                         fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
2564
2565                     putc(']', stderr);
2566                 }
2567                 putc('\n', stderr);
2568         }
2569     } while (unpack_locn<bufsize) ;  /* (parent != NULL); */
2570
2571     fprintf(stderr, "--- End ---\n\n");
2572 #endif /* 0 */
2573 }
2574 #endif /* PAR */
2575 #endif /* DEBUG || GRAN_CHECK */
2576
2577 #endif /* PAR  || GRAN  -- whole file */
2578
2579 //@node End of file,  , Printing Packet Contents, Graph packing
2580 //@subsection End of file
2581 //@index
2582 //* AllocClosureQueue::  @cindex\s-+AllocClosureQueue
2583 //* AllocateHeap::  @cindex\s-+AllocateHeap
2584 //* AmPacking::  @cindex\s-+AmPacking
2585 //* CommonUp::  @cindex\s-+CommonUp
2586 //* DeQueueClosure::  @cindex\s-+DeQueueClosure
2587 //* DonePacking::  @cindex\s-+DonePacking
2588 //* IS_BLACK_HOLE::  @cindex\s-+IS_BLACK_HOLE
2589 //* IS_INDIRECTION::  @cindex\s-+IS_INDIRECTION
2590 //* InitClosureQueue::  @cindex\s-+InitClosureQueue
2591 //* InitPendingGABuffer::  @cindex\s-+InitPendingGABuffer
2592 //* NotYetPacking::  @cindex\s-+NotYetPacking
2593 //* OffsetFor::  @cindex\s-+OffsetFor
2594 //* Pack::  @cindex\s-+Pack
2595 //* PackClosure::  @cindex\s-+PackClosure
2596 //* PackNearbyGraph::  @cindex\s-+PackNearbyGraph
2597 //* PackOneNode::  @cindex\s-+PackOneNode
2598 //* PackPLC::  @cindex\s-+PackPLC
2599 //* PackStkO::  @cindex\s-+PackStkO
2600 //* PackTSO::  @cindex\s-+PackTSO
2601 //* PendingGABuffer::  @cindex\s-+PendingGABuffer
2602 //* PrintPacket::  @cindex\s-+PrintPacket
2603 //* QueueClosure::  @cindex\s-+QueueClosure
2604 //* QueueEmpty::  @cindex\s-+QueueEmpty
2605 //* RoomToPack::  @cindex\s-+RoomToPack
2606 //* UnpackGraph::  @cindex\s-+UnpackGraph
2607 //* doGlobalGC::  @cindex\s-+doGlobalGC
2608 //* get_closure_info::  @cindex\s-+get_closure_info
2609 //* get_closure_info::  @cindex\s-+get_closure_info
2610 //* initPackBuffer::  @cindex\s-+initPackBuffer
2611 //* isFixed::  @cindex\s-+isFixed
2612 //* isOffset::  @cindex\s-+isOffset
2613 //* offsetTable::  @cindex\s-+offsetTable
2614 //@end index