ghc/rts/parallel/Pack.c

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