Pack.c 127 KB
Newer Older
1
/* 
2
   Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
sof's avatar
sof committed
3
   $Id: Pack.c,v 1.7 2001/05/28 07:13:54 sof Exp $
4 5 6 7 8 9 10 11 12 13 14 15 16 17

   Graph packing and unpacking code for sending it to another processor
   and retrieving the original graph structure from the packet.
   In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
   Used in GUM and GrAnSim.

   The GrAnSim version of the code defines routines for *simulating* the
   packing of closures in the same way it is done in the parallel runtime
   system. Basically GrAnSim only puts the addresses of the closures to be
   transferred into a buffer. This buffer will then be associated with the
   event of transferring the graph. When this event is scheduled, the
   @UnpackGraph@ routine is called and the buffer can be discarded
   afterwards.

18 19
   Note that in GranSim we need many buffers, not just one per PE.
*/
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53

//@node Graph packing, , ,
//@section Graph packing

#if defined(PAR) || defined(GRAN)   /* whole file */

//@menu
//* Includes::			
//* Prototypes::		
//* Global variables::		
//* ADT of Closure Queues::	
//* Initialisation for packing::  
//* Packing Functions::		
//* Low level packing routines::  
//* Unpacking routines::	
//* Aux fcts for packing::	
//* Printing Packet Contents::	
//* End of file::		
//@end menu
//*/

//@node Includes, Prototypes, Graph packing, Graph packing
//@subsection Includes

#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
#include "ClosureTypes.h"
#include "Storage.h"
#include "Hash.h"
#include "Parallel.h"
#include "GranSimRts.h"
#include "ParallelRts.h"
# if defined(DEBUG)
54 55
# include "Sanity.h"
# include "Printer.h"
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
# include "ParallelDebug.h"
# endif
#include "FetchMe.h"

/* Which RTS flag should be used to get the size of the pack buffer ? */
# if defined(PAR)
#  define RTS_PACK_BUFFER_SIZE   RtsFlags.ParFlags.packBufferSize
# else   /* GRAN */
#  define RTS_PACK_BUFFER_SIZE   RtsFlags.GranFlags.packBufferSize
# endif

//@node Prototypes, Global variables, Includes, Graph packing
//@subsection Prototypes
/* 
   Code declarations. 
*/

//@node ADT of closure queues, Init for packing, Prototypes, Prototypes
//@subsubsection ADT of closure queues

static inline void    	  InitClosureQueue(void);
static inline rtsBool 	  QueueEmpty(void);
static inline void    	  QueueClosure(StgClosure *closure);
static inline StgClosure *DeQueueClosure(void);

//@node Init for packing, Packing routines, ADT of closure queues, Prototypes
//@subsubsection Init for packing

84
static void     InitPacking(rtsBool unpack);
85
# if defined(PAR)
86
rtsBool         InitPackBuffer(void);
87 88 89 90 91 92 93 94 95 96 97 98 99 100
# elif defined(GRAN)
rtsPackBuffer  *InstantiatePackBuffer (void);
static void     reallocPackBuffer (void);
# endif

//@node Packing routines, Low level packing fcts, Init for packing, Prototypes
//@subsubsection Packing routines

static void    PackClosure (StgClosure *closure);

//@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
//@subsubsection Low level packing fcts

# if defined(GRAN)
101
static  void    Pack (StgClosure *data);
102
# else
103
static  void    Pack (StgWord data);
104

105 106
static void    PackGeneric(StgClosure *closure);
static void    PackArray(StgClosure *closure);
107 108
static void    PackPLC (StgPtr addr);
static void    PackOffset (int offset);
109 110 111 112 113
static void    PackPAP(StgPAP *pap);
static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
static void           PackFetchMe(StgClosure *closure);

114 115 116 117 118 119 120 121 122
static void    GlobaliseAndPackGA (StgClosure *closure);
# endif

//@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
//@subsubsection Unpacking routines

# if defined(PAR)
void        InitPendingGABuffer(nat size); 
void        CommonUp(StgClosure *src, StgClosure *dst);
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure, 
				  rtsBool hasGA);
static nat         FillInClosure(StgWord ***bufptrP, StgClosure *graph);
static void        LocateNextParent(StgClosure **parentP,
				    nat *pptrP, nat *pptrsP, nat *sizeP);
StgClosure        *UnpackGraph(rtsPackBuffer *packBuffer,
			       globalAddr **gamap,
			       nat *nGAs);
static  StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, 
				   globalAddr *ga);
static  StgWord   **UnpackGA(StgWord **bufptr, globalAddr *ga);
static  StgClosure *UnpackOffset(globalAddr *ga);
static  StgClosure *UnpackPLC(globalAddr *ga);
static  void        UnpackArray(StgWord ***bufptrP, StgClosure *graph);
static  nat         UnpackPAP(StgWord ***bufptrP, StgClosure *graph);

139 140 141 142 143 144 145 146 147 148 149 150 151
# elif defined(GRAN)
void        CommonUp(StgClosure *src, StgClosure *dst);
StgClosure *UnpackGraph(rtsPackBuffer* buffer);
#endif

//@node Aux fcts for packing,  , Unpacking routines, Prototypes
//@subsubsection Aux fcts for packing

# if defined(PAR)
static void 	DonePacking(void);
static void 	AmPacking(StgClosure *closure);
static int  	OffsetFor(StgClosure *closure);
static rtsBool  NotYetPacking(int offset);
152 153 154 155 156
static inline rtsBool  RoomToPack (nat size, nat ptrs);
static inline rtsBool  isOffset(globalAddr *ga);
static inline rtsBool  isFixed(globalAddr *ga);
static inline rtsBool  isConstr(globalAddr *ga);
static inline rtsBool  isUnglobalised(globalAddr *ga);
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
# elif defined(GRAN)
static void     DonePacking(void);
static rtsBool  NotYetPacking(StgClosure *closure);
# endif

//@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
//@subsection Global variables
/*
  Static data declarations
*/

static nat     pack_locn,           /* ptr to first free loc in pack buffer */
               clq_size, clq_pos,
               buf_id = 1;          /* identifier for buffer */
static nat     unpacked_size;
172
static rtsBool roomInBuffer;
173 174 175
#if defined(PAR)
static GlobalTaskId dest_gtid=0;    /* destination for message to send */
#endif
176 177 178 179 180 181

/* 
   The pack buffer
   To be pedantic: in GrAnSim we're packing *addresses* of closures,
   not the closures themselves.
*/
182 183 184
static rtsPackBuffer *globalPackBuffer = NULL,    /* for packing a graph */
                     *globalUnpackBuffer = NULL;  /* for unpacking a graph */

185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

/*
  Bit of a hack for testing if a closure is the root of the graph. This is
  set in @PackNearbyGraph@ and tested in @PackClosure@.  
*/

static nat          packed_thunks = 0;
static StgClosure  *graph_root;

# if defined(PAR)
/*
  The offset hash table is used during packing to record the location in
  the pack buffer of each closure which is packed.
*/
//@cindex offsetTable
static HashTable *offsetTable;

//@cindex PendingGABuffer
203 204
static globalAddr *PendingGABuffer, *gaga;

205 206
# endif /* PAR */

207

208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
//@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
//@subsection ADT of Closure Queues

//@menu
//* Closure Queues::		
//* Init routines::		
//* Basic routines::		
//@end menu

//@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
//@subsubsection Closure Queues
/*
  Closure Queues

  These routines manage the closure queue.
*/

static nat clq_pos, clq_size;

static StgClosure **ClosureQueue = NULL;   /* HWL: init in main */

229 230 231 232
#if defined(DEBUG)
static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
#endif

233 234 235
//@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
//@subsubsection Init routines

236
/* @InitClosureQueue@ allocates and initialises the closure queue. */
237 238 239 240 241 242 243

//@cindex InitClosureQueue
static inline void
InitClosureQueue(void)
{
  clq_pos = clq_size = 0;

244 245 246
  if (ClosureQueue==NULL)
    ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE, 
						 "InitClosureQueue");
247 248
}

249
//@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
//@subsubsection Basic routines

/*
  QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
*/

//@cindex QueueEmpty
static inline rtsBool
QueueEmpty(void)
{
  return(clq_pos >= clq_size);
}

/* QueueClosure adds its argument to the closure queue. */

//@cindex QueueClosure
static inline void
QueueClosure(closure)
StgClosure *closure;
{
270 271 272 273
  if(clq_size < RTS_PACK_BUFFER_SIZE ) {
    IF_PAR_DEBUG(paranoia,
		 belch(">__> <<%d>> Q: %p (%s); %d elems in q",
		       globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
274
    ClosureQueue[clq_size++] = closure;
275
  } else { 
276 277
    barf("Closure Queue Overflow (EnQueueing %p (%s))", 
	 closure, info_type(closure));
278
  }
279 280 281 282 283 284 285 286
}

/* DeQueueClosure returns the head of the closure queue. */

//@cindex DeQueueClosure
static inline StgClosure * 
DeQueueClosure(void)
{
287 288 289 290 291
  if(!QueueEmpty()) {
    IF_PAR_DEBUG(paranoia,
		 belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
		       globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]), 
		       clq_size-clq_pos));
292
    return(ClosureQueue[clq_pos++]);
293
  } else {
294
    return((StgClosure*)NULL);
295
  }
296 297
}

298 299
/* DeQueueClosure returns the head of the closure queue. */

300 301 302
#if defined(DEBUG)
//@cindex PrintQueueClosure
static void
303 304 305 306 307 308 309
PrintQueueClosure(void)
{
  nat i;

  fputs("Closure queue:", stderr);
  for (i=clq_pos; i < clq_size; i++)
    fprintf(stderr, "%p (%s), ", 
310 311
	    (StgClosure *)ClosureQueue[clq_pos++], 
	    info_type(ClosureQueue[clq_pos++]));
312 313
  fputc('\n', stderr);
}
314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354
#endif

//@node Types of Global Addresses,  , Basic routines, ADT of Closure Queues
//@subsubsection Types of Global Addresses

/*
  Types of Global Addresses

  These routines determine whether a GA is one of a number of special types
  of GA.
*/

# if defined(PAR)
//@cindex isOffset
static inline rtsBool 
isOffset(globalAddr *ga)
{
    return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
}

//@cindex isFixed
static inline rtsBool
isFixed(globalAddr *ga)
{
    return (ga->weight == 0U);
}

//@cindex isConstr
static inline rtsBool
isConstr(globalAddr *ga)
{
    return (ga->weight == 2U);
}

//@cindex isUnglobalised
static inline rtsBool
isUnglobalised(globalAddr *ga)
{
    return (ga->weight == 2U);
}
# endif
355

356 357 358 359 360 361 362 363 364 365 366 367 368 369
//@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
//@subsection Initialisation for packing
/*
  Simple Packing Routines

  About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
  gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
  words.  In the simulated PackBuffer we only keep the addresses of the
  closures that would be packed in the parallel system (see Pack). To
  decide if a packet overflow occurs pack_buffer_size must be compared
  versus unpacked_size (see RoomToPack).  Currently, there is no multi
  packet strategy implemented, so in the case of an overflow we just stop
  adding closures to the closure queue.  If an overflow of the simulated
  packet occurs, we just realloc some more space for it and carry on as
370 371
  usual.  -- HWL
*/
372 373 374 375

# if defined(GRAN)
rtsPackBuffer *
InstantiatePackBuffer (void) {
376
  extern rtsPackBuffer *globalPackBuffer;
377

378
  globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer), 
379
			 "InstantiatePackBuffer: failed to alloc packBuffer");
380 381
  globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
  globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
382 383 384 385
				 "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
  /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
  /* stgMallocWords is now simple allocate in Storage.c */

386
  return (globalPackBuffer);
387 388 389 390 391 392 393 394 395
}

/* 
   Reallocate the GranSim internal pack buffer to make room for more closure
   pointers. This is independent of the check for packet overflow as in GUM
*/
static void
reallocPackBuffer (void) {

396
  ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
397 398 399

  IF_GRAN_DEBUG(packBuffer,
		belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
400
		      globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
401 402
		      CurrentProc, CurrentTime[CurrentProc]));
  
403
  globalPackBuffer = (rtsPackBuffer*)realloc(globalPackBuffer, 
404
				  sizeof(StgClosure*)*(REALLOC_SZ +
405
						       (int)globalPackBuffer->size +
406
						       sizeofW(rtsPackBuffer))) ;
407
  if (globalPackBuffer==(rtsPackBuffer*)NULL) 
408
    barf("Failing to realloc %d more words for PackBuffer %p (PE %u @ %d)\n", 
409
	 REALLOC_SZ, globalPackBuffer, CurrentProc, CurrentTime[CurrentProc]);
410
  
411
  globalPackBuffer->size += REALLOC_SZ;
412

413
  ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
414 415 416 417 418
}
# endif

# if defined(PAR)
/* @initPacking@ initialises the packing buffer etc. */
419
//@cindex InitPackBuffer
420
rtsBool
421
InitPackBuffer(void)
422
{
423 424
  if (globalPackBuffer==(rtsPackBuffer*)NULL) {
    if ((globalPackBuffer = (rtsPackBuffer *) 
425
	 stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
426 427
			"InitPackBuffer")) == NULL)
      return rtsFalse;
428 429 430 431
  }
  return rtsTrue;
}

432 433
# endif 
//@cindex InitPacking
434
static void
435
InitPacking(rtsBool unpack)
436 437
{
# if defined(GRAN)
438
  globalPackBuffer = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
439
                                       /* NB: free in UnpackGraph */
440 441 442 443 444 445 446 447
# elif defined(PAR)
  if (unpack) {
    /* allocate a GA-to-GA map (needed for ACK message) */
    InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
  } else {
    /* allocate memory to pack the graph into */
    InitPackBuffer();
  }
448
# endif
449 450 451 452 453
  /* init queue of closures seen during packing */
  InitClosureQueue();

  if (unpack) 
    return;
454

455
  globalPackBuffer->id = buf_id++;  /* buffer id are only used for debugging! */
456 457
  pack_locn = 0;         /* the index into the actual pack buffer */
  unpacked_size = 0;     /* the size of the whole graph when unpacked */
458
  roomInBuffer = rtsTrue;
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491
  packed_thunks = 0;   /* total number of thunks packed so far */
# if defined(PAR)
  offsetTable = allocHashTable();
# endif
}

//@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
//@subsection Packing Functions

//@menu
//* Packing Sections of Nearby Graph::	
//* Packing Closures::		
//@end menu

//@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
//@subsubsection Packing Sections of Nearby Graph
/*
  Packing Sections of Nearby Graph

  @PackNearbyGraph@ packs a closure and associated graph into a static
  buffer (@PackBuffer@).  It returns the address of this buffer and the
  size of the data packed into the buffer (in its second parameter,
  @packBufferSize@).  The associated graph is packed in a depth first
  manner, hence it uses an explicit queue of closures to be packed rather
  than simply using a recursive algorithm.  Once the packet is full,
  closures (other than primitive arrays) are packed as FetchMes, and their
  children are not queued for packing.  */

//@cindex PackNearbyGraph

/* NB: this code is shared between GranSim and GUM;
       tso only used in GranSim */
rtsPackBuffer *
492
PackNearbyGraph(closure, tso, packBufferSize, dest)
493 494 495
StgClosure* closure;
StgTSO* tso;
nat *packBufferSize;
496
GlobalTaskId dest;
497
{
498 499 500
  IF_PAR_DEBUG(resume,
	       graphFingerPrint[0] = '\0');

501
  ASSERT(RTS_PACK_BUFFER_SIZE > 0);
502 503 504 505 506
  ASSERT(_HS==1);  // HWL HACK; compile time constant

#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
  PAR_TICKY_PACK_NEARBY_GRAPH_START();
#endif
507 508 509 510 511 512

  /* ToDo: check that we have enough heap for the packet
     ngoq ngo'
     if (Hp + PACK_HEAP_REQUIRED > HpLim) 
     return NULL;
  */
513
  InitPacking(rtsFalse);
514 515 516
# if defined(PAR)
  dest_gtid=dest; //-1 to disable
# elif defined(GRAN)
517 518 519 520 521
  graph_root = closure;
# endif

  IF_GRAN_DEBUG(pack,
		belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [PE %d]\n    demanded by TSO %d (%p) [PE %u]",
522
		      globalPackBuffer->id, globalPackBuffer, closure, where_is(closure), 
523 524 525 526 527 528
		      tso->id, tso, where_is((StgClosure*)tso)));

  IF_GRAN_DEBUG(pack,
		belch("** PrintGraph of %p is:", closure); 
		PrintGraph(closure,0));

529 530 531 532
  IF_PAR_DEBUG(resume,
	       GraphFingerPrint(closure, graphFingerPrint);
	       ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
	       belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n    demanded by TSO %d (%p); Finger-print is\n    {%s}",
533
		     globalPackBuffer->id, globalPackBuffer, closure, mytid,
534
		     tso->id, tso, graphFingerPrint)); 
535

536
  IF_PAR_DEBUG(packet,
537 538 539 540 541 542 543 544 545 546 547
	       belch("** PrintGraph of %p is:", closure); 
	       belch("** pack_locn=%d", pack_locn);
	       PrintGraph(closure,0));

  QueueClosure(closure);
  do {
    PackClosure(DeQueueClosure());
  } while (!QueueEmpty());
  
# if defined(PAR)

548 549
  /* Record how much space the graph needs in packet and in heap */
  globalPackBuffer->tso = tso;       // currently unused, I think (debugging?)
550 551
  globalPackBuffer->unpacked_size = unpacked_size;
  globalPackBuffer->size = pack_locn;
552

553 554 555 556
  /* Check for buffer overflow (again) */
  ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
  IF_DEBUG(sanity,                           // write magic end-of-buffer word
	   globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
557 558 559 560 561 562
  *packBufferSize = pack_locn;

# else  /* GRAN */

  /* Record how much space is needed to unpack the graph */
  // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;  for testing
563 564
  globalPackBuffer->tso = tso;
  globalPackBuffer->unpacked_size = unpacked_size;
565 566 567 568 569 570

  // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
  /* ToDo: Print an earlier, more meaningful message */
  if (pack_locn==0)   /* i.e. packet is empty */
    barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
	 closure);
571
  globalPackBuffer->size = pack_locn;
572 573 574 575 576 577 578 579 580
  *packBufferSize = pack_locn;

# endif

  DonePacking();                               /* {GrAnSim}vaD 'ut'Ha' */

# if defined(GRAN)
  IF_GRAN_DEBUG(pack ,
		belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
581
		      globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
582 583 584 585 586
  if (RtsFlags.GranFlags.GranSimStats.Global) {
    globalGranStats.tot_packets++; 
    globalGranStats.tot_packet_size += pack_locn; 
  }
  
587
  IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
588
# elif defined(PAR)
589
  IF_PAR_DEBUG(packet,
590 591 592 593
		belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
		      globalPackBuffer->id, closure, info_type(closure),
		      globalPackBuffer->size, packed_thunks, 
		      globalPackBuffer->unpacked_size));;
594

595 596 597
  IF_DEBUG(sanity, // do a sanity check on the packet just constructed 
	   checkPacket(globalPackBuffer));
# endif   /* GRAN */
598 599 600 601

#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
  PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
#endif
602 603
  
  return (globalPackBuffer);
604 605 606 607 608 609 610 611 612 613 614 615 616
}

//@cindex PackOneNode

# if defined(GRAN)
/* This version is used when the node is already local */

rtsPackBuffer *
PackOneNode(closure, tso, packBufferSize)
StgClosure* closure;
StgTSO* tso;
nat *packBufferSize;
{
617
  extern rtsPackBuffer *globalPackBuffer;
618 619
  int i, clpack_locn;

620
  InitPacking(rtsFalse);
621 622 623 624 625 626 627 628 629

  IF_GRAN_DEBUG(pack,
		belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
		      closure, info_type(closure),
		      where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));

  Pack(closure);

  /* Record how much space is needed to unpack the graph */
630 631
  globalPackBuffer->tso = tso;
  globalPackBuffer->unpacked_size = unpacked_size;
632 633 634

  /* Set the size parameter */
  ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
635
  globalPackBuffer->size =  pack_locn;
636 637 638 639 640 641 642
  *packBufferSize = pack_locn;

  if (RtsFlags.GranFlags.GranSimStats.Global) {
    globalGranStats.tot_packets++; 
    globalGranStats.tot_packet_size += pack_locn; 
  }
  IF_GRAN_DEBUG(pack,
643
    PrintPacket(globalPackBuffer));
644

645
  return (globalPackBuffer);
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663
}
# endif  /* GRAN */

#if defined(GRAN)

/*
   PackTSO and PackStkO are entry points for two special kinds of closure
   which are used in the parallel RTS.  Compared with other closures they
   are rather awkward to pack because they don't follow the normal closure
   layout (where all pointers occur before all non-pointers).  Luckily,
   they're only needed when migrating threads between processors.  */

//@cindex PackTSO
rtsPackBuffer*
PackTSO(tso, packBufferSize)
StgTSO *tso;
nat *packBufferSize;
{
664
  extern rtsPackBuffer *globalPackBuffer;
665 666 667 668
  IF_GRAN_DEBUG(pack,
		belch("** Packing TSO %d (%p)", tso->id, tso));
  *packBufferSize = 0;
  // PackBuffer[0] = PackBuffer[1] = 0; ???
669
  return(globalPackBuffer);
670 671 672
}

//@cindex PackStkO
673
static rtsPackBuffer*
674 675 676 677
PackStkO(stko, packBufferSize)
StgPtr stko;
nat *packBufferSize;
{
678
  extern rtsPackBuffer *globalPackBuffer;
679 680 681 682
  IF_GRAN_DEBUG(pack,
		belch("** Packing STKO %p", stko));
  *packBufferSize = 0;
  // PackBuffer[0] = PackBuffer[1] = 0;
683
  return(globalPackBuffer);
684 685
}

686
static void
687 688 689 690 691 692 693
PackFetchMe(StgClosure *closure)
{
  barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
}

#elif defined(PAR)

694
static rtsPackBuffer*
695 696 697 698
PackTSO(tso, packBufferSize)
StgTSO *tso;
nat *packBufferSize;
{
699 700
  barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
       tso->id, tso, packBufferSize);
701 702 703 704 705 706 707
}

rtsPackBuffer*
PackStkO(stko, packBufferSize)
StgPtr stko;
nat *packBufferSize;
{
708 709
  barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
       stko, packBufferSize);
710 711 712
}

//@cindex PackFetchMe
713
static void
714 715 716 717
PackFetchMe(StgClosure *closure)
{
  StgInfoTable *ip;
  nat i;
718
  int offset;
719 720 721
#if defined(DEBUG)
  nat x = pack_locn;
#endif
722 723 724 725

#if defined(GRAN)
  barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
#else
726 727 728 729 730 731
  offset = OffsetFor(closure);
  if (!NotYetPacking(offset)) {
    IF_PAR_DEBUG(pack,
		 belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
		       closure, info_type(closure), offset));
    PackOffset(offset);
732
    // unpacked_size += 0;   // unpacked_size unchanged (closure is shared!!)
733 734 735 736 737
    return;
  }

  /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
  AmPacking(closure);
738
  /* FMs must be always globalised */
739 740 741 742 743 744 745 746 747
  GlobaliseAndPackGA(closure);

  IF_PAR_DEBUG(pack,
	       belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
		     closure, info_type(closure), 
		     globalPackBuffer->buffer[pack_locn-2],
		     globalPackBuffer->buffer[pack_locn-1],
		     globalPackBuffer->buffer[pack_locn-3]));

748
  /* Pack a FetchMe closure instead of closure */
749
  ip = &stg_FETCH_ME_info;
750 751 752 753 754
  /* this assumes that the info ptr is always the first word in a closure*/
  Pack((StgWord)ip);
  for (i = 1; i < _HS; ++i)               // pack rest of fixed header
    Pack((StgWord)*(((StgPtr)closure)+i));
  
755 756 757 758 759 760
  unpacked_size += sizeofW(StgFetchMe);
  /* size of FETCHME in packed is the same as that constant */
  ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
  /* In the pack buffer the pointer to a GA (in the FetchMe closure) 
     is expanded to the full GA; this is a compile-time const */
  //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);  
761 762 763 764 765
#endif
}

#endif

766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824
#ifdef DIST
static void
PackRemoteRef(StgClosure *closure)
{
  StgInfoTable *ip;
  nat i;
  int offset;

  offset = OffsetFor(closure);
  if (!NotYetPacking(offset)) {
    PackOffset(offset);
    unpacked_size += 2;
    return;
  }

  /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
  AmPacking(closure);
  
  /* basically we just Globalise, but for sticky things we can't have multiple GAs,
     so we must prevent the GAs being split.
     
     In returning things to the true sticky owner, this case is already handled, but for
     anything else we just give up at the moment... This needs to be fixed! 
  */
  { globalAddr *ga;
    ga = LAGAlookup(closure); // surely this ga must exist?
    
    // ***************************************************************************
    // ***************************************************************************
    // REMOTE_REF HACK - dual is in SetGAandCommonUp
    // - prevents the weight from ever reaching zero
    if(ga != NULL) 
      ga->weight=0x06660666; //anything apart from 0 really...
    // ***************************************************************************
    // ***************************************************************************
    
    if((ga != NULL)&&(ga->weight / 2 <= 2))
      barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
		closure, info_type(closure), 
	   	ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);   			     
  } 
  GlobaliseAndPackGA(closure);
      
  IF_PAR_DEBUG(pack,
	       belch("*>.. Packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
		     closure, info_type(closure), 
		     globalPackBuffer->buffer[pack_locn-2],
		     globalPackBuffer->buffer[pack_locn-1],
		     globalPackBuffer->buffer[pack_locn-3]));

  /* Pack a REMOTE_REF closure instead of closure */
  ip = &stg_REMOTE_REF_info;
  /* this assumes that the info ptr is always the first word in a closure*/
  Pack((StgWord)ip);
  for (i = 1; i < _HS; ++i)               // pack rest of fixed header
    Pack((StgWord)*(((StgPtr)closure)+i));
  
  unpacked_size += PACK_FETCHME_SIZE;
}
sof's avatar
sof committed
825
#endif /* DIST */
826

827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854
//@node Packing Closures,  , Packing Sections of Nearby Graph, Packing Functions
//@subsubsection Packing Closures
/*
  Packing Closures

  @PackClosure@ is the heart of the normal packing code.  It packs a single
  closure into the pack buffer, skipping over any indirections and
  globalising it as necessary, queues any child pointers for further
  packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
  locally if it was a thunk.  Before the actual closure is packed, a
  suitable global address (GA) is inserted in the pack buffer.  There is
  always room to pack a fetch-me to the closure (guaranteed by the
  RoomToPack calculation), and this is packed if there is no room for the
  entire closure.

  Space is allocated for any primitive array children of a closure, and
  hence a primitive array can always be packed along with it's parent
  closure.  */

//@cindex PackClosure

# if defined(PAR)

void
PackClosure(closure)
StgClosure *closure;
{
  StgInfoTable *info;
855
  nat clpack_locn;
856

857 858 859 860 861
  ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));

  closure = UNWIND_IND(closure);
  /* now closure is the thing we want to pack */
  info = get_itbl(closure);
862 863 864 865 866 867 868 869 870 871

  clpack_locn = OffsetFor(closure);

  /* If the closure has been packed already, just pack an indirection to it
     to guarantee that the graph doesn't become a tree when unpacked */
  if (!NotYetPacking(clpack_locn)) {
    PackOffset(clpack_locn);
    return;
  }

872
  switch (info->type) {
873 874

  case CONSTR_CHARLIKE:
875 876 877 878 879 880 881
    IF_PAR_DEBUG(pack,
		 belch("*>^^ Packing a charlike closure %d", 
		       ((StgIntCharlikeClosure*)closure)->data));
    
    PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
    // NB: unpacked_size of a PLC is 0
    return;
882 883 884 885
      
  case CONSTR_INTLIKE:
    {
      StgInt val = ((StgIntCharlikeClosure*)closure)->data;
886

887 888
      if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
	IF_PAR_DEBUG(pack,
889 890
		     belch("*>^^ Packing a small intlike %d as a PLC", 
			   val));
891
	PackPLC((StgPtr)INTLIKE_CLOSURE(val));
892 893
	// NB: unpacked_size of a PLC is 0
	return;
894 895
      } else {
	IF_PAR_DEBUG(pack,
896
		     belch("*>^^ Packing a big intlike %d as a normal closure", 
897
			   val));
898
	PackGeneric(closure);
899
	return;
900 901 902 903 904 905 906 907 908
      }
    }

  case CONSTR:
  case CONSTR_1_0:
  case CONSTR_0_1:
  case CONSTR_2_0:
  case CONSTR_1_1:
  case CONSTR_0_2:
909
    /* it's a constructor (i.e. plain data) */
910
    IF_PAR_DEBUG(pack,
911
		 belch("*>^^ Packing a CONSTR %p (%s) using generic packing", 
912
		       closure, info_type(closure)));
913 914
    PackGeneric(closure);
    return;
915

916 917
  case THUNK_STATIC:       // ToDo: check whether that's ok
  case FUN_STATIC:       // ToDo: check whether that's ok
918 919 920 921
  case CONSTR_STATIC:
  case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
			   // evaluated on each PE if needed
    IF_PAR_DEBUG(pack,
922 923
		 belch("*>~~ Packing a %p (%s) as a PLC", 
		       closure, info_type(closure)));
924

925
    PackPLC((StgPtr)closure);
926
    // NB: unpacked_size of a PLC is 0
927 928
    return;

929 930 931
  case THUNK_SELECTOR: 
    {
      StgClosure *selectee = ((StgSelector *)closure)->selectee;
932

933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970
      IF_PAR_DEBUG(pack,
		   belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric", 
			 closure, info_type(closure), 
			 selectee, info_type(selectee)));
      PackGeneric(closure);
      /* inlined code; probably could use PackGeneric
      Pack((StgWord)(*(StgPtr)closure));  
      Pack((StgWord)(selectee));
      QueueClosure(selectee);
      unpacked_size += 2;
      */
    }
    return;

  case  FUN:
  case	FUN_1_0:
  case	FUN_0_1:
  case	FUN_2_0:
  case	FUN_1_1:
  case	FUN_0_2:
  case  THUNK:
  case	THUNK_1_0:
  case	THUNK_0_1:
  case	THUNK_2_0:
  case	THUNK_1_1:
  case	THUNK_0_2:
    PackGeneric(closure);
    return;

  case AP_UPD:
  case PAP:
    /* 
    barf("*>   Packing of PAP not implemented %p (%s)",
		       closure, info_type(closure));
	 
       Currently we don't pack PAPs; we pack a FETCH_ME to the closure, 
       instead. Note that since PAPs contain a chunk of stack as payload,
       implementing packing of PAPs is a first step towards thread migration.
971
    IF_PAR_DEBUG(pack,
972
		 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME", 
973
		       closure, info_type(closure)));
974 975 976 977
    PackFetchMe(closure);
    */
    PackPAP((StgPAP *)closure);
    return;
978 979 980

  case CAF_BLACKHOLE:
  case BLACKHOLE:
981 982 983
  case BLACKHOLE_BQ:
  case SE_BLACKHOLE:
  case SE_CAF_BLACKHOLE:
984 985 986 987 988 989 990 991
  case RBH:
  case FETCH_ME:
  case FETCH_ME_BQ:

    /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
    //ASSERT(pack_locn > PACK_HDR_SIZE);
    
    IF_PAR_DEBUG(pack,
992 993 994 995 996 997
		 belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME", 
		       closure, info_type(closure)));
    /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
           phps short-cut the GA here */
    PackFetchMe(closure);
    return;
998

999 1000
#ifdef DIST    
  case REMOTE_REF:
1001
    IF_PAR_DEBUG(pack,
1002
		 belch("*>.. Packing %p (%s) as a REMOTE_REF", 
1003
		       closure, info_type(closure)));
1004 1005
    PackRemoteRef(closure);
    /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
1006

1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022
    return;
#endif  
    
  case TSO:
  case MVAR:
#ifdef DIST
          IF_PAR_DEBUG(pack,
		 belch("*>.. Packing %p (%s) as a RemoteRef", 
		       closure, info_type(closure)));
    PackRemoteRef(closure);
#else
    barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)", 
	 closure, info_type(closure));
#endif    
    return;
    
1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086
  case ARR_WORDS:
    PackArray(closure);
    return;

  case MUT_ARR_PTRS:
  case MUT_ARR_PTRS_FROZEN:
  case MUT_VAR:
    /* 
       Eventually, this should use the same packing routine as ARR_WRODS

       GlobaliseAndPackGA(closure);
       PackArray(closure);
       return;
    */
    barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
	 closure, info_type(closure));

#  ifdef DEBUG
  case BCO:
    barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code", 
	 closure, info_type(closure));
    /* never reached */
    
    // check error cases only in a debugging setup
  case RET_BCO:
  case RET_SMALL:
  case RET_VEC_SMALL:
  case RET_BIG:
  case RET_VEC_BIG:
  case RET_DYN:
    barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)", 
	 closure, info_type(closure));
    /* never reached */
    
  case UPDATE_FRAME:
  case STOP_FRAME:
  case CATCH_FRAME:
  case SEQ_FRAME:
    barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)", 
	 closure, info_type(closure));
    /* never reached */

  case BLOCKED_FETCH:
  case EVACUATED:
    /* something's very wrong */
    barf("{Pack}Daq Qagh: found %s (%p) when packing", 
	 info_type(closure), closure);
    /* never reached */

  case IND:
  case IND_OLDGEN:
  case IND_PERM:
  case IND_OLDGEN_PERM:
  case IND_STATIC:
    barf("Pack: found IND_... after shorting out indirections %d (%s)", 
	 (nat)(info->type), info_type(closure));

  case WEAK:
  case FOREIGN:
  case STABLE_NAME:
    barf("Pack: found foreign thingy; not yet implemented in %d (%s)", 
	 (nat)(info->type), info_type(closure));
#endif

1087
  default:
1088
    barf("Pack: strange closure %d", (nat)(info->type));
1089
  } /* switch */
1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105
}

/*
  Pack a constructor of unknown size.
  Similar to PackGeneric but without creating GAs.
*/
#if 0
//@cindex PackConstr
static void
PackConstr(StgClosure *closure)
{
  StgInfoTable *info;
  nat size, ptrs, nonptrs, vhs, i;
  char str[80];

  ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
1106 1107 1108 1109

  /* get info about basic layout of the closure */
  info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);

1110 1111 1112 1113 1114 1115
  ASSERT(info->type == CONSTR ||
         info->type == CONSTR_1_0 ||
         info->type == CONSTR_0_1 ||
         info->type == CONSTR_2_0 ||
         info->type == CONSTR_1_1 ||
         info->type == CONSTR_0_2);
1116 1117

  IF_PAR_DEBUG(pack,
1118
	       fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1119 1120
		       closure, info_type(closure), size, ptrs, nonptrs));

1121
  /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1122

1123
  if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1124
    IF_PAR_DEBUG(pack,
1125
		 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1126
		       closure, info_type(closure)));
1127 1128
    PackFetchMe(closure);
    return;
1129 1130
  }

1131 1132
  /* Record the location of the GA */
  AmPacking(closure);
1133

1134 1135
  /* Pack Constructor marker */
  Pack((StgWord)2);
1136

1137 1138 1139
  /* pack fixed and variable header */
  for (i = 0; i < _HS + vhs; ++i)
    Pack((StgWord)*(((StgPtr)closure)+i));
1140
      
1141 1142 1143
  /* register all ptrs for further packing */
  for (i = 0; i < ptrs; ++i)
    QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1144

1145 1146 1147 1148 1149
  /* pack non-ptrs */
  for (i = 0; i < nonptrs; ++i)
    Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
}
#endif
1150

1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171
/*
  Generic packing code.
  This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
*/
//@cindex PackGeneric
static void
PackGeneric(StgClosure *closure)
{
  StgInfoTable *info;
  StgClosure *rbh;
  nat size, ptrs, nonptrs, vhs, i, m;
  char str[80];

  ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));

  /* get info about basic layout of the closure */
  info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);

  ASSERT(!IS_BLACK_HOLE(closure));

  IF_PAR_DEBUG(pack,
1172
	       fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
1173 1174
		       closure, info_type(closure), size, ptrs, nonptrs));

1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186
  /* packing strategies: how many thunks to add to a packet; 
     default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
  if (RtsFlags.ParFlags.thunksToPack &&
      packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
      closure_THUNK(closure)) {
    IF_PAR_DEBUG(pack,
		 belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
		       packed_thunks, closure, info_type(closure)));
    PackFetchMe(closure);
    return;
  }

1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199
  /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */

  if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
    IF_PAR_DEBUG(pack,
		 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
		       closure, info_type(closure)));
    PackFetchMe(closure);
    return;
  }

  /* Record the location of the GA */
  AmPacking(closure);
  /* Allocate a GA for this closure and put it into the buffer */
1200 1201 1202 1203 1204 1205 1206
  /* Checks for globalisation scheme; default: globalise everything thunks */
  if ( RtsFlags.ParFlags.globalising == 0 || 
       (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
    GlobaliseAndPackGA(closure);
  else
    Pack((StgWord)2);  // marker for unglobalised closure

1207 1208 1209

  ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
	   info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1210 1211

  /* At last! A closure we can actually pack! */
1212 1213 1214
  if (ip_MUTABLE(info) && ((info->type != FETCH_ME)||(info->type != REMOTE_REF)))
    barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
	 closure, info_type(closure));
1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227
      
  /* 
     Remember, the generic closure layout is as follows:
        +-------------------------------------------------+
	| FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
        +-------------------------------------------------+
  */
  /* pack fixed and variable header */
  for (i = 0; i < _HS + vhs; ++i)
    Pack((StgWord)*(((StgPtr)closure)+i));
      
  /* register all ptrs for further packing */
  for (i = 0; i < ptrs; ++i)
1228
    QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1229 1230 1231

  /* pack non-ptrs */
  for (i = 0; i < nonptrs; ++i)
1232
    Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1233
      
1234 1235 1236 1237 1238 1239 1240 1241 1242 1243
  // ASSERT(_HS+vhs+ptrs+nonptrs==size);
  if ((m=_HS+vhs+ptrs+nonptrs)<size) {
    IF_PAR_DEBUG(pack,
		 belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
		       closure, info_type(closure), size-m));
    for (i=m; i<size; i++) 
      Pack((StgWord)*(((StgPtr)closure)+i));
  }

  unpacked_size += size;
1244
  //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1245 1246 1247 1248 1249 1250 1251 1252 1253 1254

  /*
   * Record that this is a revertable black hole so that we can fill in
   * its address from the fetch reply.  Problem: unshared thunks may cause
   * space leaks this way, their GAs should be deallocated following an
   * ACK.
   */
      
  if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) { 
    rbh = convertToRBH(closure);
1255 1256
    ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
    ASSERT(rbh == closure);         // rbh at the same position (minced version)
1257
    packed_thunks++;
1258 1259
  } else if ( closure==graph_root ) {
    packed_thunks++;                // root of graph is counted as a thunk
1260 1261
  }
}
1262 1263 1264 1265
/*
  Pack an array of words.
  ToDo: implement packing of MUT_ARRAYs
*/
1266

1267 1268 1269 1270 1271
//@cindex PackArray
static void
PackArray(StgClosure *closure)
{
  StgInfoTable *info;
1272 1273
  nat size, ptrs, nonptrs, vhs;
  nat i, n;
1274
  char str[80];
1275

1276 1277 1278 1279 1280 1281 1282 1283 1284 1285
  /* get info about basic layout of the closure */
  info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);

  ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
	 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);

  n = ((StgArrWords *)closure)->words;
  // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q)); 

  IF_PAR_DEBUG(pack,
1286 1287
	       belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
		     closure, info_type(closure), n,
1288 1289
		     arr_words_sizeW((StgArrWords *)closure)));

1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314
  /* check that we have enough room in the pack buffer */
  if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
    IF_PAR_DEBUG(pack,
		 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
		       closure, info_type(closure)));
    PackFetchMe(closure);
    return;
  }

  /* global stats about arrays sent */
  if (RtsFlags.ParFlags.ParStats.Global &&
      RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
    globalParStats.tot_arrs++;
    globalParStats.tot_arr_size += ((StgArrWords *)closure)->words;
  }

  /* record offset of the closure and allocate a GA */
  AmPacking(closure);
  /* Checks for globalisation scheme; default: globalise everything thunks */
  if ( RtsFlags.ParFlags.globalising == 0 || 
       (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
    GlobaliseAndPackGA(closure);
  else
    Pack((StgWord)2);  // marker for unglobalised closure

1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338
  /* Pack the header (2 words: info ptr and the number of words to follow) */
  Pack((StgWord)*(StgPtr)closure);
  Pack(((StgArrWords *)closure)->words);

  /* pack the payload of the closure (all non-ptrs) */
  for (i=0; i<n; i++)
    Pack((StgWord)((StgArrWords *)closure)->payload[i]);

  unpacked_size += arr_words_sizeW((StgArrWords *)closure);
}

/*
   Pack a PAP closure.
   Note that the representation of a PAP in the buffer is different from
   its representation in the heap. In particular, pointers to local
   closures are packed directly as FETCHME closures, using
   PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
   structure. To account for the difference in size we store the packed
   size of the closure as part of the PAP's variable header in the buffer.
*/

//@cindex PackPAP
static void
PackPAP(StgPAP *pap) {
1339 1340
  nat n, i, j, pack_start;
  StgPtr p, q;
1341 1342 1343
  const StgInfoTable* info;
  StgWord32 bitmap;
  /* debugging only */
1344
  StgPtr end;
1345 1346
  nat size, ptrs, nonptrs, vhs;
  char str[80];
1347
  nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
1348 1349

  /* This is actually a setup invariant; checked here 'cause it affects PAPs*/
1350
  //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
1351
  ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
1352 1353
  IF_DEBUG(sanity,
	   unpacked_size_before_PAP = unpacked_size);
1354

1355
  n = (nat)(pap->n_args);
1356 1357 1358 1359 1360 1361

  /* get info about basic layout of the closure */
  info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
  ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));

  IF_PAR_DEBUG(pack,
1362 1363 1364
	       belch("*>**  %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:", 
		     (StgClosure *)pap, info_type((StgClosure *)pap),
		     n, size, ptrs, nonptrs);
1365 1366
               printClosure((StgClosure *)pap));

1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384
  /* check that we have enough room in the pack buffer */
  if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
    IF_PAR_DEBUG(pack,
		 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
		       (StgClosure *)pap, info_type((StgClosure *)pap)));
    PackFetchMe((StgClosure *)pap);
    return;
  }

  /* record offset of the closure and allocate a GA */
  AmPacking((StgClosure *)pap);
  /* Checks for globalisation scheme; default: globalise everything thunks */
  if ( RtsFlags.ParFlags.globalising == 0 || 
       (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
    GlobaliseAndPackGA((StgClosure *)pap);
  else
    Pack((StgWord)2);  // marker for unglobalised closure

1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401
  /* Pack the PAP header */
  Pack((StgWord)(pap->header.info));
  Pack((StgWord)(pap->n_args));
  Pack((StgWord)(pap->fun));
  pack_start = pack_locn;   // to compute size of PAP in buffer
  Pack((StgWord)0);    // this will be filled in later (size of PAP in buffer)

  /* Pack the payload of a PAP i.e. a stack chunk */
  /* pointers to start of stack chunk */
  p = (StgPtr)(pap->payload);
  end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
  while (p<end) {
    /* the loop body has been borrowed from scavenge_stack */
    q = (StgPtr)*p;

    /* If we've got a tag, pack all words in that block */
    if (IS_ARG_TAG((W_)q)) {   // q stands for the no. of non-ptrs to follow
1402
      nat m = ARG_TAG((W_)q);      // first word after this block
1403
      IF_PAR_DEBUG(pack,
1404
		   belch("*>**    PackPAP @ %p: packing %d words (tagged), starting @ %p", 
1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418
			 p, m, p));
      for (i=0; i<m+1; i++)
	Pack((StgWord)*(p+i));
      p += m+1;                // m words + the tag
      continue;
    }
     
    /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
       ToDo: provide RTS flag to also pack these closures
    */
    if (! LOOKS_LIKE_GHC_INFO(q) ) {
      /* distinguish static closure (PLC) from other closures (FM) */
      switch (get_itbl((StgClosure*)q)->type) {
      case CONSTR_CHARLIKE:
1419 1420 1421 1422 1423 1424 1425
	IF_PAR_DEBUG(pack,
		     belch("*>**    PackPAP: packing a charlike closure %d", 
			   ((StgIntCharlikeClosure*)q)->data));
    
	PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
	p++;
	break;
1426 1427 1428 1429 1430 1431 1432
      
      case CONSTR_INTLIKE:
	{
	  StgInt val = ((StgIntCharlikeClosure*)q)->data;
      
	  if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
	    IF_PAR_DEBUG(pack,
1433
			 belch("*>**    PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1434
	    PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1435 1436
	    p++;
	    break;
1437 1438
	  } else {
	    IF_PAR_DEBUG(pack,
1439
			 belch("*>**    PackPAP: Packing a ptr to a big intlike %d as a FM", 
1440 1441 1442
			       val));
	    Pack((StgWord)(ARGTAG_MAX+1));
	    PackFetchMe((StgClosure *)q);
1443 1444 1445
	    p++;
	    IF_DEBUG(sanity, FMs_in_PAP++);
	    break;
1446 1447 1448 1449 1450 1451 1452 1453
	  }
	}
	case THUNK_STATIC:       // ToDo: check whether that's ok
	case FUN_STATIC:       // ToDo: check whether that's ok
	case CONSTR_STATIC:
	case CONSTR_NOCAF_STATIC:
	  {
	    IF_PAR_DEBUG(pack,
1454
			 belch("*>**    PackPAP: packing a ptr to a %p (%s) as a PLC", 
1455 1456 1457 1458 1459 1460 1461 1462
			       q, info_type((StgClosure *)q)));
	    
	    PackPLC((StgPtr)q);
	    p++;
	    break;
	  }
      default:
	  IF_PAR_DEBUG(pack,
1463
		       belch("*>**    PackPAP @ %p: packing FM to %p (%s)", 
1464 1465 1466 1467
			     p, q, info_type((StgClosure*)q)));
	  Pack((StgWord)(ARGTAG_MAX+1));
	  PackFetchMe((StgClosure *)q);
	  p++;
1468
	  IF_DEBUG(sanity, FMs_in_PAP++);
1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484
	  break;
      }
      continue;
    }
	
    /* 
     * Otherwise, q must be the info pointer of an activation
     * record.  All activation records have 'bitmap' style layout
     * info.
     */
    info  = get_itbl((StgClosure *)p);
    switch (info->type) {
	
      /* Dynamic bitmap: the mask is stored on the stack */
    case RET_DYN:
      IF_PAR_DEBUG(pack,
1485
		   belch("*>**    PackPAP @ %p: RET_DYN", 
1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501
			 p));

      /* Pack the header as is */
      Pack((StgWord)(((StgRetDyn *)p)->info));
      Pack((StgWord)(((StgRetDyn *)p)->liveness));
      Pack((StgWord)(((StgRetDyn *)p)->ret_addr));

      bitmap = ((StgRetDyn *)p)->liveness;
      p      = (P_)&((StgRetDyn *)p)->payload[0];
      goto small_bitmap;

      /* probably a slow-entry point return address: */
    case FUN:
    case FUN_STATIC:
      {
      IF_PAR_DEBUG(pack,
1502
		   belch("*>**    PackPAP @ %p: FUN or FUN_STATIC", 
1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519
			 p));

      Pack((StgWord)(((StgClosure *)p)->header.info));
      p++;

      goto follow_srt; //??
      }

      /* Using generic code here; could inline as in scavenge_stack */
    case UPDATE_FRAME:
      {
	StgUpdateFrame *frame = (StgUpdateFrame *)p;
	nat type = get_itbl(frame->updatee)->type;

	ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);

	IF_PAR_DEBUG(pack,
1520
		     belch("*>**    PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)", 
1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533
			   p, frame->updatee, frame->link));

	Pack((StgWord)(frame->header.info));
	Pack((StgWord)(frame->link));     // ToDo: fix intra-stack pointer
	Pack((StgWord)(frame->updatee));  // ToDo: follow link 

	p += 3;
      }

      /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
    case STOP_FRAME:
      {
	IF_PAR_DEBUG(pack,
1534
		     belch("*>**    PackPAP @ %p: STOP_FRAME", 
1535 1536 1537 1538 1539 1540 1541 1542
			   p));
	Pack((StgWord)((StgStopFrame *)p)->header.info);
	p++;
      }

    case CATCH_FRAME:
      {
	IF_PAR_DEBUG(pack,
1543
		     belch("*>**    PackPAP @ %p: CATCH_FRAME (handler=%p)", 
1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555
			   p, ((StgCatchFrame *)p)->handler));

	Pack((StgWord)((StgCatchFrame *)p)->header.info);
	Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
	Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
	Pack((StgWord)((StgCatchFrame *)p)->handler);
	p += 4;
      }

    case SEQ_FRAME:
      {
	IF_PAR_DEBUG(pack,
1556
		     belch("*>**    PackPAP @ %p: UPDATE_FRAME (link=%p)", 
1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571
			   p, ((StgSeqFrame *)p)->link));

	Pack((StgWord)((StgSeqFrame *)p)->header.info);
	Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer

        // ToDo: handle bitmap
        bitmap = info->layout.bitmap;

        p = (StgPtr)&(((StgClosure *)p)->payload);
        goto small_bitmap;
      }
    case RET_BCO:
    case RET_SMALL:
    case RET_VEC_SMALL:
      IF_PAR_DEBUG(pack,
1572
		   belch("*>**    PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)", 
1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586
			 p, info->layout.bitmap));


      Pack((StgWord)((StgClosure *)p)->header.info);
      p++;
      // ToDo: handle bitmap
      bitmap = info->layout.bitmap;
      /* this assumes that the payload starts immediately after the info-ptr */

    small_bitmap:
      while (bitmap != 0) {
	if ((bitmap & 1) == 0) {
	  Pack((StgWord)(ARGTAG_MAX+1));
	  PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1587
	  IF_DEBUG(sanity, FMs_in_PAP++);
1588 1589 1590 1591 1592 1593 1594
	} else {
	  Pack((StgWord)*p++);
	}
	bitmap = bitmap >> 1;
      }
      
    follow_srt:
1595 1596
	IF_PAR_DEBUG(pack,
	             belch("*>--    PackPAP: nothing to do for follow_srt"));
1597 1598 1599 1600 1601 1602 1603 1604 1605 1606
      continue;

      /* large bitmap (> 32 entries) */
    case RET_BIG:
    case RET_VEC_BIG:
      {
	StgPtr q;
	StgLargeBitmap *large_bitmap;

	IF_PAR_DEBUG(pack,
1607
		     belch("*>**    PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)", 
1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622
			   p, info->layout.large_bitmap));


	Pack((StgWord)((StgClosure *)p)->header.info);
	p++;

	large_bitmap = info->layout.large_bitmap;

	for (j=0; j<large_bitmap->size; j++) {
	  bitmap = large_bitmap->bitmap[j];
	  q = p + sizeof(W_) * 8;
	  while (bitmap != 0) {
	    if ((bitmap & 1) == 0) {
	      Pack((StgWord)(ARGTAG_MAX+1));
	      PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1623
	      IF_DEBUG(sanity, FMs_in_PAP++);
1624 1625 1626 1627 1628 1629 1630 1631 1632
	    } else {
	      Pack((StgWord)*p++);
	    }
	    bitmap = bitmap >> 1;
	  }
	  if (j+1 < large_bitmap->size) {
	    while (p < q) {
	      Pack((StgWord)(ARGTAG_MAX+1));
	      PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1633
	      IF_DEBUG(sanity, FMs_in_PAP++);
1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648
	    }
	  }
	}

	/* and don't forget to follow the SRT */
	goto follow_srt;
      }

    default:
      barf("PackPAP: weird activation record found on stack (@ %p): %d", 
	   p, (int)(info->type));
    }
  }
  // fill in size of the PAP (only the payload!) in buffer
  globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1649 1650 1651 1652 1653 1654