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