Pack.c 127 KB
Newer Older
1
/* 
2
   Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
3 4 5 6 7 8 9 10 11 12 13 14 15 16

   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.

17 18
   Note that in GranSim we need many buffers, not just one per PE.
*/
19 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

//@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)
53 54
# include "Sanity.h"
# include "Printer.h"
55 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
# 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

83
static void     InitPacking(rtsBool unpack);
84
# if defined(PAR)
85
rtsBool         InitPackBuffer(void);
86 87 88 89 90 91 92 93 94 95 96 97 98 99
# 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)
100
static  void    Pack (StgClosure *data);
101
# else
102
static  void    Pack (StgWord data);
103

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

113 114 115 116 117 118 119 120 121
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);
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
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);

138 139 140 141 142 143 144 145 146 147 148 149 150
# 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);
151 152 153 154 155
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);
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
# 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;
171
static rtsBool roomInBuffer;
172 173 174
#if defined(PAR)
static GlobalTaskId dest_gtid=0;    /* destination for message to send */
#endif
175 176 177 178 179 180

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

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

/*
  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
202 203
static globalAddr *PendingGABuffer, *gaga;

204 205
# endif /* PAR */

206

207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
//@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 */

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

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

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

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

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

248
//@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
//@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;
{
269 270 271 272
  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));
273
    ClosureQueue[clq_size++] = closure;
274
  } else { 
275 276
    barf("Closure Queue Overflow (EnQueueing %p (%s))", 
	 closure, info_type(closure));
277
  }
278 279 280 281 282 283 284 285
}

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

//@cindex DeQueueClosure
static inline StgClosure * 
DeQueueClosure(void)
{
286 287 288 289 290
  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));
291
    return(ClosureQueue[clq_pos++]);
292
  } else {
293
    return((StgClosure*)NULL);
294
  }
295 296
}

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

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

  fputs("Closure queue:", stderr);
  for (i=clq_pos; i < clq_size; i++)
    fprintf(stderr, "%p (%s), ", 
309 310
	    (StgClosure *)ClosureQueue[clq_pos++], 
	    info_type(ClosureQueue[clq_pos++]));
311 312
  fputc('\n', stderr);
}
313 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
#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
354

355 356 357 358 359 360 361 362 363 364 365 366 367 368
//@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
369 370
  usual.  -- HWL
*/
371 372 373 374

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

377
  globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer), 
378
			 "InstantiatePackBuffer: failed to alloc packBuffer");
379 380
  globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
  globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
381 382 383 384
				 "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 */

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

/* 
   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) {

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

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

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

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

431 432
# endif 
//@cindex InitPacking
433
static void
434
InitPacking(rtsBool unpack)
435 436
{
# if defined(GRAN)
437
  globalPackBuffer = InstantiatePackBuffer();     /* for GrAnSim only -- HWL */
438
                                       /* NB: free in UnpackGraph */
439 440 441 442 443 444 445 446
# 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();
  }
447
# endif
448 449 450 451 452
  /* init queue of closures seen during packing */
  InitClosureQueue();

  if (unpack) 
    return;
453

454
  globalPackBuffer->id = buf_id++;  /* buffer id are only used for debugging! */
455 456
  pack_locn = 0;         /* the index into the actual pack buffer */
  unpacked_size = 0;     /* the size of the whole graph when unpacked */
457
  roomInBuffer = rtsTrue;
458 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
  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 *
491
PackNearbyGraph(closure, tso, packBufferSize, dest)
492 493 494
StgClosure* closure;
StgTSO* tso;
nat *packBufferSize;
495
GlobalTaskId dest;
496
{
497 498 499
  IF_PAR_DEBUG(resume,
	       graphFingerPrint[0] = '\0');

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

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

  /* ToDo: check that we have enough heap for the packet
     ngoq ngo'
     if (Hp + PACK_HEAP_REQUIRED > HpLim) 
     return NULL;
  */
512
  InitPacking(rtsFalse);
513 514 515
# if defined(PAR)
  dest_gtid=dest; //-1 to disable
# elif defined(GRAN)
516 517 518 519 520
  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]",
521
		      globalPackBuffer->id, globalPackBuffer, closure, where_is(closure), 
522 523 524 525 526 527
		      tso->id, tso, where_is((StgClosure*)tso)));

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

528 529 530 531
  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}",
532
		     globalPackBuffer->id, globalPackBuffer, closure, mytid,
533
		     tso->id, tso, graphFingerPrint)); 
534

535
  IF_PAR_DEBUG(packet,
536 537 538 539 540 541 542 543 544 545 546
	       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)

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

552 553 554 555
  /* 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);
556 557 558 559 560 561
  *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
562 563
  globalPackBuffer->tso = tso;
  globalPackBuffer->unpacked_size = unpacked_size;
564 565 566 567 568 569

  // 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);
570
  globalPackBuffer->size = pack_locn;
571 572 573 574 575 576 577 578 579
  *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",
580
		      globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size));
581 582 583 584 585
  if (RtsFlags.GranFlags.GranSimStats.Global) {
    globalGranStats.tot_packets++; 
    globalGranStats.tot_packet_size += pack_locn; 
  }
  
586
  IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
587
# elif defined(PAR)
588
  IF_PAR_DEBUG(packet,
589 590 591 592
		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));;
593

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

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

//@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;
{
616
  extern rtsPackBuffer *globalPackBuffer;
617 618
  int i, clpack_locn;

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

  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 */
629 630
  globalPackBuffer->tso = tso;
  globalPackBuffer->unpacked_size = unpacked_size;
631 632 633

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

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

644
  return (globalPackBuffer);
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
}
# 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;
{
663
  extern rtsPackBuffer *globalPackBuffer;
664 665 666 667
  IF_GRAN_DEBUG(pack,
		belch("** Packing TSO %d (%p)", tso->id, tso));
  *packBufferSize = 0;
  // PackBuffer[0] = PackBuffer[1] = 0; ???
668
  return(globalPackBuffer);
669 670 671
}

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

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

#elif defined(PAR)

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

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

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

#if defined(GRAN)
  barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
#else
725 726 727 728 729 730
  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);
731
    // unpacked_size += 0;   // unpacked_size unchanged (closure is shared!!)
732 733 734 735 736
    return;
  }

  /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
  AmPacking(closure);
737
  /* FMs must be always globalised */
738 739 740 741 742 743 744 745 746
  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]));

747
  /* Pack a FetchMe closure instead of closure */
748
  ip = &stg_FETCH_ME_info;
749 750 751 752 753
  /* 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));
  
754 755 756 757 758 759
  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);  
760 761 762 763 764
#endif
}

#endif

765 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
#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
824
#endif /* DIST */
825

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
//@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;
854
  nat clpack_locn;
855

856 857 858 859 860
  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);
861 862 863 864 865 866 867 868 869 870

  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;
  }

871
  switch (info->type) {
872 873

  case CONSTR_CHARLIKE:
874 875 876 877 878 879 880
    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;
881 882 883 884
      
  case CONSTR_INTLIKE:
    {
      StgInt val = ((StgIntCharlikeClosure*)closure)->data;
885

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

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

915 916
  case THUNK_STATIC:       // ToDo: check whether that's ok
  case FUN_STATIC:       // ToDo: check whether that's ok
917 918 919 920
  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,
921 922
		 belch("*>~~ Packing a %p (%s) as a PLC", 
		       closure, info_type(closure)));
923

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

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

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
      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.
970
    IF_PAR_DEBUG(pack,
971
		 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME", 
972
		       closure, info_type(closure)));
973 974 975 976
    PackFetchMe(closure);
    */
    PackPAP((StgPAP *)closure);
    return;
977 978 979

  case CAF_BLACKHOLE:
  case BLACKHOLE:
980 981 982
  case BLACKHOLE_BQ:
  case SE_BLACKHOLE:
  case SE_CAF_BLACKHOLE:
983 984 985 986 987 988 989 990
  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,
991 992 993 994 995 996
		 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;
997

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

1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
    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;
    
1022 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
  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

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

/*
  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));
1105 1106 1107 1108

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

1109 1110 1111 1112 1113 1114
  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);
1115 1116

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

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

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

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

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

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

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

1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170
/*
  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,
1171
	       fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
1172 1173
		       closure, info_type(closure), size, ptrs, nonptrs));

1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185
  /* 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;
  }

1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198
  /* 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 */
1199 1200 1201 1202 1203 1204 1205
  /* 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

1206 1207 1208

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

  /* At last! A closure we can actually pack! */
1211 1212 1213
  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));
1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226
      
  /* 
     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)
1227
    QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1228 1229 1230

  /* pack non-ptrs */
  for (i = 0; i < nonptrs; ++i)
1231
    Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1232
      
1233 1234 1235 1236 1237 1238 1239 1240 1241 1242
  // 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;
1243
  //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1244 1245 1246 1247 1248 1249 1250 1251 1252 1253

  /*
   * 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);
1254 1255
    ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
    ASSERT(rbh == closure);         // rbh at the same position (minced version)
1256
    packed_thunks++;
1257 1258
  } else if ( closure==graph_root ) {
    packed_thunks++;                // root of graph is counted as a thunk
1259 1260
  }
}
1261 1262 1263 1264
/*
  Pack an array of words.
  ToDo: implement packing of MUT_ARRAYs
*/
1265

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

1275 1276 1277 1278 1279 1280 1281 1282 1283 1284
  /* 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,
1285 1286
	       belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
		     closure, info_type(closure), n,
1287 1288
		     arr_words_sizeW((StgArrWords *)closure)));

1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313
  /* 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

1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337
  /* 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) {
1338 1339
  nat n, i, j, pack_start;
  StgPtr p, q;
1340
  const StgInfoTable* info;
ken's avatar
ken committed
1341
  StgWord bitmap;
1342
  /* debugging only */
1343
  StgPtr end;
1344 1345
  nat size, ptrs, nonptrs, vhs;
  char str[80];
1346
  nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
1347 1348

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

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

  /* 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,
1361 1362 1363
	       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);
1364 1365
               printClosure((StgClosure *)pap));

1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383
  /* 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

1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400
  /* 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
1401
      nat m = ARG_TAG((W_)q);      // first word after this block
1402
      IF_PAR_DEBUG(pack,
1403
		   belch("*>**    PackPAP @ %p: packing %d words (tagged), starting @ %p", 
1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417
			 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:
1418 1419 1420 1421 1422 1423 1424
	IF_PAR_DEBUG(pack,
		     belch("*>**    PackPAP: packing a charlike closure %d", 
			   ((StgIntCharlikeClosure*)q)->data));
    
	PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
	p++;
	break;
1425 1426 1427 1428 1429 1430 1431
      
      case CONSTR_INTLIKE:
	{
	  StgInt val = ((StgIntCharlikeClosure*)q)->data;
      
	  if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
	    IF_PAR_DEBUG(pack,
1432
			 belch("*>**    PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1433
	    PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1434 1435
	    p++;
	    break;
1436 1437
	  } else {
	    IF_PAR_DEBUG(pack,
1438
			 belch("*>**    PackPAP: Packing a ptr to a big intlike %d as a FM", 
1439 1440 1441
			       val));
	    Pack((StgWord)(ARGTAG_MAX+1));
	    PackFetchMe((StgClosure *)q);
1442 1443 1444
	    p++;
	    IF_DEBUG(sanity, FMs_in_PAP++);
	    break;
1445 1446 1447 1448 1449 1450 1451 1452
	  }
	}
	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,
1453
			 belch("*>**    PackPAP: packing a ptr to a %p (%s) as a PLC", 
1454 1455 1456 1457 1458 1459 1460 1461
			       q, info_type((StgClosure *)q)));
	    
	    PackPLC((StgPtr)q);
	    p++;
	    break;
	  }
      default:
	  IF_PAR_DEBUG(pack,
1462
		       belch("*>**    PackPAP @ %p: packing FM to %p (%s)", 
1463 1464 1465 1466
			     p, q, info_type((StgClosure*)q)));
	  Pack((StgWord)(ARGTAG_MAX+1));
	  PackFetchMe((StgClosure *)q);
	  p++;
1467
	  IF_DEBUG(sanity, FMs_in_PAP++);
1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483
	  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,
1484
		   belch("*>**    PackPAP @ %p: RET_DYN", 
1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500
			 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,
1501
		   belch("*>**    PackPAP @ %p: FUN or FUN_STATIC", 
1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518
			 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,
1519
		     belch("*>**    PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)", 
1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532
			   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,
1533
		     belch("*>**    PackPAP @ %p: STOP_FRAME", 
1534 1535 1536 1537 1538 1539 1540 1541
			   p));
	Pack((StgWord)((StgStopFrame *)p)->header.info);
	p++;
      }

    case CATCH_FRAME:
      {
	IF_PAR_DEBUG(pack,
1542
		     belch("*>**    PackPAP @ %p: CATCH_FRAME (handler=%p)", 
1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554
			   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,
1555
		     belch("*>**    PackPAP @ %p: UPDATE_FRAME (link=%p)", 
1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570
			   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,
1571
		   belch("*>**    PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)", 
1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585
			 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
1586
	  IF_DEBUG(sanity, FMs_in_PAP++);
1587 1588 1589 1590 1591 1592 1593
	} else {
	  Pack((StgWord)*p++);
	}
	bitmap = bitmap >> 1;
      }
      
    follow_srt:
1594 1595
	IF_PAR_DEBUG(pack,
	             belch("*>--    PackPAP: nothing to do for follow_srt"));
1596 1597 1598 1599 1600 1601 1602 1603 1604 1605
      continue;

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

	IF_PAR_DEBUG(pack,
1606
		     belch("*>**    PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)", 
1607 1608 1609 1610 1611 1612 1613 1614 1615 1616
			   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];
ken's avatar
ken committed
1617
	  q = p + BITS_IN(W_);
1618 1619 1620 1621
	  while (bitmap != 0) {
	    if ((bitmap & 1) == 0) {
	      Pack((StgWord)(ARGTAG_MAX+1));
	      PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1622
	      IF_DEBUG(sanity, FMs_in_PAP++);
1623 1624 1625 1626 1627 1628 1629 1630 1631
	    } 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);
1632
	      IF_DEBUG(sanity, FMs_in_PAP++);
1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647
	    }
	  }
	}

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