2 Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
3 $Id: Pack.c,v 1.8 2001/07/24 05:04:59 ken Exp $
5 Graph packing and unpacking code for sending it to another processor
6 and retrieving the original graph structure from the packet.
7 In the old RTS the code was split into Pack.c and Unpack.c (now deceased)
8 Used in GUM and GrAnSim.
10 The GrAnSim version of the code defines routines for *simulating* the
11 packing of closures in the same way it is done in the parallel runtime
12 system. Basically GrAnSim only puts the addresses of the closures to be
13 transferred into a buffer. This buffer will then be associated with the
14 event of transferring the graph. When this event is scheduled, the
15 @UnpackGraph@ routine is called and the buffer can be discarded
18 Note that in GranSim we need many buffers, not just one per PE.
21 //@node Graph packing, , ,
22 //@section Graph packing
24 #if defined(PAR) || defined(GRAN) /* whole file */
29 //* Global variables::
30 //* ADT of Closure Queues::
31 //* Initialisation for packing::
32 //* Packing Functions::
33 //* Low level packing routines::
34 //* Unpacking routines::
35 //* Aux fcts for packing::
36 //* Printing Packet Contents::
41 //@node Includes, Prototypes, Graph packing, Graph packing
42 //@subsection Includes
47 #include "ClosureTypes.h"
51 #include "GranSimRts.h"
52 #include "ParallelRts.h"
56 # include "ParallelDebug.h"
60 /* Which RTS flag should be used to get the size of the pack buffer ? */
62 # define RTS_PACK_BUFFER_SIZE RtsFlags.ParFlags.packBufferSize
64 # define RTS_PACK_BUFFER_SIZE RtsFlags.GranFlags.packBufferSize
67 //@node Prototypes, Global variables, Includes, Graph packing
68 //@subsection Prototypes
73 //@node ADT of closure queues, Init for packing, Prototypes, Prototypes
74 //@subsubsection ADT of closure queues
76 static inline void InitClosureQueue(void);
77 static inline rtsBool QueueEmpty(void);
78 static inline void QueueClosure(StgClosure *closure);
79 static inline StgClosure *DeQueueClosure(void);
81 //@node Init for packing, Packing routines, ADT of closure queues, Prototypes
82 //@subsubsection Init for packing
84 static void InitPacking(rtsBool unpack);
86 rtsBool InitPackBuffer(void);
88 rtsPackBuffer *InstantiatePackBuffer (void);
89 static void reallocPackBuffer (void);
92 //@node Packing routines, Low level packing fcts, Init for packing, Prototypes
93 //@subsubsection Packing routines
95 static void PackClosure (StgClosure *closure);
97 //@node Low level packing fcts, Unpacking routines, Packing routines, Prototypes
98 //@subsubsection Low level packing fcts
101 static void Pack (StgClosure *data);
103 static void Pack (StgWord data);
105 static void PackGeneric(StgClosure *closure);
106 static void PackArray(StgClosure *closure);
107 static void PackPLC (StgPtr addr);
108 static void PackOffset (int offset);
109 static void PackPAP(StgPAP *pap);
110 static rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
111 static rtsPackBuffer *PackStkO(StgPtr stko, nat *packBufferSize);
112 static void PackFetchMe(StgClosure *closure);
114 static void GlobaliseAndPackGA (StgClosure *closure);
117 //@node Unpacking routines, Aux fcts for packing, Low level packing fcts, Prototypes
118 //@subsubsection Unpacking routines
121 void InitPendingGABuffer(nat size);
122 void CommonUp(StgClosure *src, StgClosure *dst);
123 static StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure,
125 static nat FillInClosure(StgWord ***bufptrP, StgClosure *graph);
126 static void LocateNextParent(StgClosure **parentP,
127 nat *pptrP, nat *pptrsP, nat *sizeP);
128 StgClosure *UnpackGraph(rtsPackBuffer *packBuffer,
131 static StgClosure *UnpackClosure (StgWord ***bufptrP, StgClosure **graphP,
133 static StgWord **UnpackGA(StgWord **bufptr, globalAddr *ga);
134 static StgClosure *UnpackOffset(globalAddr *ga);
135 static StgClosure *UnpackPLC(globalAddr *ga);
136 static void UnpackArray(StgWord ***bufptrP, StgClosure *graph);
137 static nat UnpackPAP(StgWord ***bufptrP, StgClosure *graph);
140 void CommonUp(StgClosure *src, StgClosure *dst);
141 StgClosure *UnpackGraph(rtsPackBuffer* buffer);
144 //@node Aux fcts for packing, , Unpacking routines, Prototypes
145 //@subsubsection Aux fcts for packing
148 static void DonePacking(void);
149 static void AmPacking(StgClosure *closure);
150 static int OffsetFor(StgClosure *closure);
151 static rtsBool NotYetPacking(int offset);
152 static inline rtsBool RoomToPack (nat size, nat ptrs);
153 static inline rtsBool isOffset(globalAddr *ga);
154 static inline rtsBool isFixed(globalAddr *ga);
155 static inline rtsBool isConstr(globalAddr *ga);
156 static inline rtsBool isUnglobalised(globalAddr *ga);
158 static void DonePacking(void);
159 static rtsBool NotYetPacking(StgClosure *closure);
162 //@node Global variables, ADT of Closure Queues, Prototypes, Graph packing
163 //@subsection Global variables
165 Static data declarations
168 static nat pack_locn, /* ptr to first free loc in pack buffer */
170 buf_id = 1; /* identifier for buffer */
171 static nat unpacked_size;
172 static rtsBool roomInBuffer;
174 static GlobalTaskId dest_gtid=0; /* destination for message to send */
179 To be pedantic: in GrAnSim we're packing *addresses* of closures,
180 not the closures themselves.
182 static rtsPackBuffer *globalPackBuffer = NULL, /* for packing a graph */
183 *globalUnpackBuffer = NULL; /* for unpacking a graph */
187 Bit of a hack for testing if a closure is the root of the graph. This is
188 set in @PackNearbyGraph@ and tested in @PackClosure@.
191 static nat packed_thunks = 0;
192 static StgClosure *graph_root;
196 The offset hash table is used during packing to record the location in
197 the pack buffer of each closure which is packed.
199 //@cindex offsetTable
200 static HashTable *offsetTable;
202 //@cindex PendingGABuffer
203 static globalAddr *PendingGABuffer, *gaga;
208 //@node ADT of Closure Queues, Initialisation for packing, Global variables, Graph packing
209 //@subsection ADT of Closure Queues
217 //@node Closure Queues, Init routines, ADT of Closure Queues, ADT of Closure Queues
218 //@subsubsection Closure Queues
222 These routines manage the closure queue.
225 static nat clq_pos, clq_size;
227 static StgClosure **ClosureQueue = NULL; /* HWL: init in main */
230 static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
233 //@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
234 //@subsubsection Init routines
236 /* @InitClosureQueue@ allocates and initialises the closure queue. */
238 //@cindex InitClosureQueue
240 InitClosureQueue(void)
242 clq_pos = clq_size = 0;
244 if (ClosureQueue==NULL)
245 ClosureQueue = (StgClosure**) stgMallocWords(RTS_PACK_BUFFER_SIZE,
249 //@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
250 //@subsubsection Basic routines
253 QueueEmpty returns rtsTrue if the closure queue is empty; rtsFalse otherwise.
257 static inline rtsBool
260 return(clq_pos >= clq_size);
263 /* QueueClosure adds its argument to the closure queue. */
265 //@cindex QueueClosure
267 QueueClosure(closure)
270 if(clq_size < RTS_PACK_BUFFER_SIZE ) {
271 IF_PAR_DEBUG(paranoia,
272 belch(">__> <<%d>> Q: %p (%s); %d elems in q",
273 globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
274 ClosureQueue[clq_size++] = closure;
276 barf("Closure Queue Overflow (EnQueueing %p (%s))",
277 closure, info_type(closure));
281 /* DeQueueClosure returns the head of the closure queue. */
283 //@cindex DeQueueClosure
284 static inline StgClosure *
288 IF_PAR_DEBUG(paranoia,
289 belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
290 globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]),
292 return(ClosureQueue[clq_pos++]);
294 return((StgClosure*)NULL);
298 /* DeQueueClosure returns the head of the closure queue. */
301 //@cindex PrintQueueClosure
303 PrintQueueClosure(void)
307 fputs("Closure queue:", stderr);
308 for (i=clq_pos; i < clq_size; i++)
309 fprintf(stderr, "%p (%s), ",
310 (StgClosure *)ClosureQueue[clq_pos++],
311 info_type(ClosureQueue[clq_pos++]));
316 //@node Types of Global Addresses, , Basic routines, ADT of Closure Queues
317 //@subsubsection Types of Global Addresses
320 Types of Global Addresses
322 These routines determine whether a GA is one of a number of special types
328 static inline rtsBool
329 isOffset(globalAddr *ga)
331 return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
335 static inline rtsBool
336 isFixed(globalAddr *ga)
338 return (ga->weight == 0U);
342 static inline rtsBool
343 isConstr(globalAddr *ga)
345 return (ga->weight == 2U);
348 //@cindex isUnglobalised
349 static inline rtsBool
350 isUnglobalised(globalAddr *ga)
352 return (ga->weight == 2U);
356 //@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
357 //@subsection Initialisation for packing
359 Simple Packing Routines
361 About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
362 gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
363 words. In the simulated PackBuffer we only keep the addresses of the
364 closures that would be packed in the parallel system (see Pack). To
365 decide if a packet overflow occurs pack_buffer_size must be compared
366 versus unpacked_size (see RoomToPack). Currently, there is no multi
367 packet strategy implemented, so in the case of an overflow we just stop
368 adding closures to the closure queue. If an overflow of the simulated
369 packet occurs, we just realloc some more space for it and carry on as
375 InstantiatePackBuffer (void) {
376 extern rtsPackBuffer *globalPackBuffer;
378 globalPackBuffer = (rtsPackBuffer *) stgMallocWords(sizeofW(rtsPackBuffer),
379 "InstantiatePackBuffer: failed to alloc packBuffer");
380 globalPackBuffer->size = RtsFlags.GranFlags.packBufferSize_internal;
381 globalPackBuffer->buffer = (StgWord **) stgMallocWords(RtsFlags.GranFlags.packBufferSize_internal,
382 "InstantiatePackBuffer: failed to alloc GranSim internal packBuffer");
383 /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
384 /* stgMallocWords is now simple allocate in Storage.c */
386 return (globalPackBuffer);
390 Reallocate the GranSim internal pack buffer to make room for more closure
391 pointers. This is independent of the check for packet overflow as in GUM
394 reallocPackBuffer (void) {
396 ASSERT(pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer));
398 IF_GRAN_DEBUG(packBuffer,
399 belch("** Increasing size of PackBuffer %p to %d words (PE %u @ %d)\n",
400 globalPackBuffer, globalPackBuffer->size+REALLOC_SZ,
401 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]);
411 globalPackBuffer->size += REALLOC_SZ;
413 ASSERT(pack_locn < globalPackBuffer->size+sizeofW(rtsPackBuffer));
418 /* @initPacking@ initialises the packing buffer etc. */
419 //@cindex InitPackBuffer
423 if (globalPackBuffer==(rtsPackBuffer*)NULL) {
424 if ((globalPackBuffer = (rtsPackBuffer *)
425 stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
426 "InitPackBuffer")) == NULL)
433 //@cindex InitPacking
435 InitPacking(rtsBool unpack)
438 globalPackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
439 /* NB: free in UnpackGraph */
442 /* allocate a GA-to-GA map (needed for ACK message) */
443 InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize);
445 /* allocate memory to pack the graph into */
449 /* init queue of closures seen during packing */
455 globalPackBuffer->id = buf_id++; /* buffer id are only used for debugging! */
456 pack_locn = 0; /* the index into the actual pack buffer */
457 unpacked_size = 0; /* the size of the whole graph when unpacked */
458 roomInBuffer = rtsTrue;
459 packed_thunks = 0; /* total number of thunks packed so far */
461 offsetTable = allocHashTable();
465 //@node Packing Functions, Low level packing routines, Initialisation for packing, Graph packing
466 //@subsection Packing Functions
469 //* Packing Sections of Nearby Graph::
470 //* Packing Closures::
473 //@node Packing Sections of Nearby Graph, Packing Closures, Packing Functions, Packing Functions
474 //@subsubsection Packing Sections of Nearby Graph
476 Packing Sections of Nearby Graph
478 @PackNearbyGraph@ packs a closure and associated graph into a static
479 buffer (@PackBuffer@). It returns the address of this buffer and the
480 size of the data packed into the buffer (in its second parameter,
481 @packBufferSize@). The associated graph is packed in a depth first
482 manner, hence it uses an explicit queue of closures to be packed rather
483 than simply using a recursive algorithm. Once the packet is full,
484 closures (other than primitive arrays) are packed as FetchMes, and their
485 children are not queued for packing. */
487 //@cindex PackNearbyGraph
489 /* NB: this code is shared between GranSim and GUM;
490 tso only used in GranSim */
492 PackNearbyGraph(closure, tso, packBufferSize, dest)
499 graphFingerPrint[0] = '\0');
501 ASSERT(RTS_PACK_BUFFER_SIZE > 0);
502 ASSERT(_HS==1); // HWL HACK; compile time constant
504 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
505 PAR_TICKY_PACK_NEARBY_GRAPH_START();
508 /* ToDo: check that we have enough heap for the packet
510 if (Hp + PACK_HEAP_REQUIRED > HpLim)
513 InitPacking(rtsFalse);
515 dest_gtid=dest; //-1 to disable
517 graph_root = closure;
521 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 tso->id, tso, where_is((StgClosure*)tso)));
526 belch("** PrintGraph of %p is:", closure);
527 PrintGraph(closure,0));
530 GraphFingerPrint(closure, graphFingerPrint);
531 ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
532 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));
537 belch("** PrintGraph of %p is:", closure);
538 belch("** pack_locn=%d", pack_locn);
539 PrintGraph(closure,0));
541 QueueClosure(closure);
543 PackClosure(DeQueueClosure());
544 } while (!QueueEmpty());
548 /* Record how much space the graph needs in packet and in heap */
549 globalPackBuffer->tso = tso; // currently unused, I think (debugging?)
550 globalPackBuffer->unpacked_size = unpacked_size;
551 globalPackBuffer->size = pack_locn;
553 /* Check for buffer overflow (again) */
554 ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
555 IF_DEBUG(sanity, // write magic end-of-buffer word
556 globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
557 *packBufferSize = pack_locn;
561 /* Record how much space is needed to unpack the graph */
562 // PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG; for testing
563 globalPackBuffer->tso = tso;
564 globalPackBuffer->unpacked_size = unpacked_size;
566 // ASSERT(pack_locn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
567 /* ToDo: Print an earlier, more meaningful message */
568 if (pack_locn==0) /* i.e. packet is empty */
569 barf("EMPTY PACKET! Can't transfer closure %p at all!!\n",
571 globalPackBuffer->size = pack_locn;
572 *packBufferSize = pack_locn;
576 DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
580 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 if (RtsFlags.GranFlags.GranSimStats.Global) {
583 globalGranStats.tot_packets++;
584 globalGranStats.tot_packet_size += pack_locn;
587 IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
590 belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
591 globalPackBuffer->id, closure, info_type(closure),
592 globalPackBuffer->size, packed_thunks,
593 globalPackBuffer->unpacked_size));;
595 IF_DEBUG(sanity, // do a sanity check on the packet just constructed
596 checkPacket(globalPackBuffer));
599 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
600 PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
603 return (globalPackBuffer);
606 //@cindex PackOneNode
609 /* This version is used when the node is already local */
612 PackOneNode(closure, tso, packBufferSize)
617 extern rtsPackBuffer *globalPackBuffer;
620 InitPacking(rtsFalse);
623 belch("** PackOneNode: %p (%s)[PE %d] requested by TSO %d (%p) [PE %d]",
624 closure, info_type(closure),
625 where_is(closure), tso->id, tso, where_is((StgClosure *)tso)));
629 /* Record how much space is needed to unpack the graph */
630 globalPackBuffer->tso = tso;
631 globalPackBuffer->unpacked_size = unpacked_size;
633 /* Set the size parameter */
634 ASSERT(pack_locn <= RTS_PACK_BUFFER_SIZE);
635 globalPackBuffer->size = pack_locn;
636 *packBufferSize = pack_locn;
638 if (RtsFlags.GranFlags.GranSimStats.Global) {
639 globalGranStats.tot_packets++;
640 globalGranStats.tot_packet_size += pack_locn;
643 PrintPacket(globalPackBuffer));
645 return (globalPackBuffer);
652 PackTSO and PackStkO are entry points for two special kinds of closure
653 which are used in the parallel RTS. Compared with other closures they
654 are rather awkward to pack because they don't follow the normal closure
655 layout (where all pointers occur before all non-pointers). Luckily,
656 they're only needed when migrating threads between processors. */
660 PackTSO(tso, packBufferSize)
664 extern rtsPackBuffer *globalPackBuffer;
666 belch("** Packing TSO %d (%p)", tso->id, tso));
668 // PackBuffer[0] = PackBuffer[1] = 0; ???
669 return(globalPackBuffer);
673 static rtsPackBuffer*
674 PackStkO(stko, packBufferSize)
678 extern rtsPackBuffer *globalPackBuffer;
680 belch("** Packing STKO %p", stko));
682 // PackBuffer[0] = PackBuffer[1] = 0;
683 return(globalPackBuffer);
687 PackFetchMe(StgClosure *closure)
689 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
694 static rtsPackBuffer*
695 PackTSO(tso, packBufferSize)
699 barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet",
700 tso->id, tso, packBufferSize);
704 PackStkO(stko, packBufferSize)
708 barf("{PackStkO}Daq Qagh: trying to pack a STKO (%p) of size %d; thread migrations not supported, yet",
709 stko, packBufferSize);
712 //@cindex PackFetchMe
714 PackFetchMe(StgClosure *closure)
724 barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
726 offset = OffsetFor(closure);
727 if (!NotYetPacking(offset)) {
729 belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
730 closure, info_type(closure), offset));
732 // unpacked_size += 0; // unpacked_size unchanged (closure is shared!!)
736 /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
738 /* FMs must be always globalised */
739 GlobaliseAndPackGA(closure);
742 belch("*>.. Packing FETCH_ME for closure %p (%s) with GA: ((%x, %d, %x))",
743 closure, info_type(closure),
744 globalPackBuffer->buffer[pack_locn-2],
745 globalPackBuffer->buffer[pack_locn-1],
746 globalPackBuffer->buffer[pack_locn-3]));
748 /* Pack a FetchMe closure instead of closure */
749 ip = &stg_FETCH_ME_info;
750 /* this assumes that the info ptr is always the first word in a closure*/
752 for (i = 1; i < _HS; ++i) // pack rest of fixed header
753 Pack((StgWord)*(((StgPtr)closure)+i));
755 unpacked_size += sizeofW(StgFetchMe);
756 /* size of FETCHME in packed is the same as that constant */
757 ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
758 /* In the pack buffer the pointer to a GA (in the FetchMe closure)
759 is expanded to the full GA; this is a compile-time const */
760 //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
768 PackRemoteRef(StgClosure *closure)
774 offset = OffsetFor(closure);
775 if (!NotYetPacking(offset)) {
781 /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
784 /* basically we just Globalise, but for sticky things we can't have multiple GAs,
785 so we must prevent the GAs being split.
787 In returning things to the true sticky owner, this case is already handled, but for
788 anything else we just give up at the moment... This needs to be fixed!
791 ga = LAGAlookup(closure); // surely this ga must exist?
793 // ***************************************************************************
794 // ***************************************************************************
795 // REMOTE_REF HACK - dual is in SetGAandCommonUp
796 // - prevents the weight from ever reaching zero
798 ga->weight=0x06660666; //anything apart from 0 really...
799 // ***************************************************************************
800 // ***************************************************************************
802 if((ga != NULL)&&(ga->weight / 2 <= 2))
803 barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
804 closure, info_type(closure),
805 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);
807 GlobaliseAndPackGA(closure);
810 belch("*>.. Packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
811 closure, info_type(closure),
812 globalPackBuffer->buffer[pack_locn-2],
813 globalPackBuffer->buffer[pack_locn-1],
814 globalPackBuffer->buffer[pack_locn-3]));
816 /* Pack a REMOTE_REF closure instead of closure */
817 ip = &stg_REMOTE_REF_info;
818 /* this assumes that the info ptr is always the first word in a closure*/
820 for (i = 1; i < _HS; ++i) // pack rest of fixed header
821 Pack((StgWord)*(((StgPtr)closure)+i));
823 unpacked_size += PACK_FETCHME_SIZE;
827 //@node Packing Closures, , Packing Sections of Nearby Graph, Packing Functions
828 //@subsubsection Packing Closures
832 @PackClosure@ is the heart of the normal packing code. It packs a single
833 closure into the pack buffer, skipping over any indirections and
834 globalising it as necessary, queues any child pointers for further
835 packing, and turns it into a @FetchMe@ or revertible black hole (@RBH@)
836 locally if it was a thunk. Before the actual closure is packed, a
837 suitable global address (GA) is inserted in the pack buffer. There is
838 always room to pack a fetch-me to the closure (guaranteed by the
839 RoomToPack calculation), and this is packed if there is no room for the
842 Space is allocated for any primitive array children of a closure, and
843 hence a primitive array can always be packed along with it's parent
846 //@cindex PackClosure
857 ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
859 closure = UNWIND_IND(closure);
860 /* now closure is the thing we want to pack */
861 info = get_itbl(closure);
863 clpack_locn = OffsetFor(closure);
865 /* If the closure has been packed already, just pack an indirection to it
866 to guarantee that the graph doesn't become a tree when unpacked */
867 if (!NotYetPacking(clpack_locn)) {
868 PackOffset(clpack_locn);
872 switch (info->type) {
874 case CONSTR_CHARLIKE:
876 belch("*>^^ Packing a charlike closure %d",
877 ((StgIntCharlikeClosure*)closure)->data));
879 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
880 // NB: unpacked_size of a PLC is 0
885 StgInt val = ((StgIntCharlikeClosure*)closure)->data;
887 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
889 belch("*>^^ Packing a small intlike %d as a PLC",
891 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
892 // NB: unpacked_size of a PLC is 0
896 belch("*>^^ Packing a big intlike %d as a normal closure",
898 PackGeneric(closure);
909 /* it's a constructor (i.e. plain data) */
911 belch("*>^^ Packing a CONSTR %p (%s) using generic packing",
912 closure, info_type(closure)));
913 PackGeneric(closure);
916 case THUNK_STATIC: // ToDo: check whether that's ok
917 case FUN_STATIC: // ToDo: check whether that's ok
919 case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
920 // evaluated on each PE if needed
922 belch("*>~~ Packing a %p (%s) as a PLC",
923 closure, info_type(closure)));
925 PackPLC((StgPtr)closure);
926 // NB: unpacked_size of a PLC is 0
931 StgClosure *selectee = ((StgSelector *)closure)->selectee;
934 belch("*>** Found THUNK_SELECTOR at %p (%s) pointing to %p (%s); using PackGeneric",
935 closure, info_type(closure),
936 selectee, info_type(selectee)));
937 PackGeneric(closure);
938 /* inlined code; probably could use PackGeneric
939 Pack((StgWord)(*(StgPtr)closure));
940 Pack((StgWord)(selectee));
941 QueueClosure(selectee);
959 PackGeneric(closure);
965 barf("*> Packing of PAP not implemented %p (%s)",
966 closure, info_type(closure));
968 Currently we don't pack PAPs; we pack a FETCH_ME to the closure,
969 instead. Note that since PAPs contain a chunk of stack as payload,
970 implementing packing of PAPs is a first step towards thread migration.
972 belch("*>.. Packing a PAP closure at %p (%s) as a FETCH_ME",
973 closure, info_type(closure)));
974 PackFetchMe(closure);
976 PackPAP((StgPAP *)closure);
983 case SE_CAF_BLACKHOLE:
988 /* If it's a (revertible) black-hole, pack a FetchMe closure to it */
989 //ASSERT(pack_locn > PACK_HDR_SIZE);
992 belch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME",
993 closure, info_type(closure)));
994 /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
995 phps short-cut the GA here */
996 PackFetchMe(closure);
1002 belch("*>.. Packing %p (%s) as a REMOTE_REF",
1003 closure, info_type(closure)));
1004 PackRemoteRef(closure);
1005 /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
1014 belch("*>.. Packing %p (%s) as a RemoteRef",
1015 closure, info_type(closure)));
1016 PackRemoteRef(closure);
1018 barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)",
1019 closure, info_type(closure));
1028 case MUT_ARR_PTRS_FROZEN:
1031 Eventually, this should use the same packing routine as ARR_WRODS
1033 GlobaliseAndPackGA(closure);
1037 barf("Qagh{Pack}Doq: packing of mutable closures not yet implemented: %p (%s)",
1038 closure, info_type(closure));
1042 barf("{Pack}Daq Qagh: found BCO closure %p (%s); GUM hates interpreted code",
1043 closure, info_type(closure));
1046 // check error cases only in a debugging setup
1053 barf("{Pack}Daq Qagh: found return vector %p (%s) when packing (thread migration not implemented)",
1054 closure, info_type(closure));
1061 barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)",
1062 closure, info_type(closure));
1067 /* something's very wrong */
1068 barf("{Pack}Daq Qagh: found %s (%p) when packing",
1069 info_type(closure), closure);
1075 case IND_OLDGEN_PERM:
1077 barf("Pack: found IND_... after shorting out indirections %d (%s)",
1078 (nat)(info->type), info_type(closure));
1083 barf("Pack: found foreign thingy; not yet implemented in %d (%s)",
1084 (nat)(info->type), info_type(closure));
1088 barf("Pack: strange closure %d", (nat)(info->type));
1093 Pack a constructor of unknown size.
1094 Similar to PackGeneric but without creating GAs.
1097 //@cindex PackConstr
1099 PackConstr(StgClosure *closure)
1102 nat size, ptrs, nonptrs, vhs, i;
1105 ASSERT(LOOKS_LIKE_GHC_INFO(closure->header.info));
1107 /* get info about basic layout of the closure */
1108 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1110 ASSERT(info->type == CONSTR ||
1111 info->type == CONSTR_1_0 ||
1112 info->type == CONSTR_0_1 ||
1113 info->type == CONSTR_2_0 ||
1114 info->type == CONSTR_1_1 ||
1115 info->type == CONSTR_0_2);
1118 fprintf(stderr, "*>^^ packing a constructor at %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
1119 closure, info_type(closure), size, ptrs, nonptrs));
1121 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1123 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1125 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1126 closure, info_type(closure)));
1127 PackFetchMe(closure);
1131 /* Record the location of the GA */
1134 /* Pack Constructor marker */
1137 /* pack fixed and variable header */
1138 for (i = 0; i < _HS + vhs; ++i)
1139 Pack((StgWord)*(((StgPtr)closure)+i));
1141 /* register all ptrs for further packing */
1142 for (i = 0; i < ptrs; ++i)
1143 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1146 for (i = 0; i < nonptrs; ++i)
1147 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1152 Generic packing code.
1153 This code is performed for `ordinary' closures such as CONSTR, THUNK etc.
1155 //@cindex PackGeneric
1157 PackGeneric(StgClosure *closure)
1161 nat size, ptrs, nonptrs, vhs, i, m;
1164 ASSERT(LOOKS_LIKE_COOL_CLOSURE(closure));
1166 /* get info about basic layout of the closure */
1167 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1169 ASSERT(!IS_BLACK_HOLE(closure));
1172 fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
1173 closure, info_type(closure), size, ptrs, nonptrs));
1175 /* packing strategies: how many thunks to add to a packet;
1176 default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
1177 if (RtsFlags.ParFlags.thunksToPack &&
1178 packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
1179 closure_THUNK(closure)) {
1181 belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
1182 packed_thunks, closure, info_type(closure)));
1183 PackFetchMe(closure);
1187 /* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
1189 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1191 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1192 closure, info_type(closure)));
1193 PackFetchMe(closure);
1197 /* Record the location of the GA */
1199 /* Allocate a GA for this closure and put it into the buffer */
1200 /* Checks for globalisation scheme; default: globalise everything thunks */
1201 if ( RtsFlags.ParFlags.globalising == 0 ||
1202 (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1203 GlobaliseAndPackGA(closure);
1205 Pack((StgWord)2); // marker for unglobalised closure
1208 ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1209 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
1211 /* At last! A closure we can actually pack! */
1212 if (ip_MUTABLE(info) && ((info->type != FETCH_ME)||(info->type != REMOTE_REF)))
1213 barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
1214 closure, info_type(closure));
1217 Remember, the generic closure layout is as follows:
1218 +-------------------------------------------------+
1219 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
1220 +-------------------------------------------------+
1222 /* pack fixed and variable header */
1223 for (i = 0; i < _HS + vhs; ++i)
1224 Pack((StgWord)*(((StgPtr)closure)+i));
1226 /* register all ptrs for further packing */
1227 for (i = 0; i < ptrs; ++i)
1228 QueueClosure(((StgClosure *) *(((StgPtr)closure)+(_HS+vhs)+i)));
1231 for (i = 0; i < nonptrs; ++i)
1232 Pack((StgWord)*(((StgPtr)closure)+(_HS+vhs)+ptrs+i));
1234 // ASSERT(_HS+vhs+ptrs+nonptrs==size);
1235 if ((m=_HS+vhs+ptrs+nonptrs)<size) {
1237 belch("*>** WARNING: slop in closure %p (%s); filling %d words; SHOULD NEVER HAPPEN",
1238 closure, info_type(closure), size-m));
1239 for (i=m; i<size; i++)
1240 Pack((StgWord)*(((StgPtr)closure)+i));
1243 unpacked_size += size;
1244 //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
1247 * Record that this is a revertable black hole so that we can fill in
1248 * its address from the fetch reply. Problem: unshared thunks may cause
1249 * space leaks this way, their GAs should be deallocated following an
1253 if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
1254 rbh = convertToRBH(closure);
1255 ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
1256 ASSERT(rbh == closure); // rbh at the same position (minced version)
1258 } else if ( closure==graph_root ) {
1259 packed_thunks++; // root of graph is counted as a thunk
1263 Pack an array of words.
1264 ToDo: implement packing of MUT_ARRAYs
1269 PackArray(StgClosure *closure)
1272 nat size, ptrs, nonptrs, vhs;
1276 /* get info about basic layout of the closure */
1277 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1279 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
1280 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
1282 n = ((StgArrWords *)closure)->words;
1283 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
1286 belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
1287 closure, info_type(closure), n,
1288 arr_words_sizeW((StgArrWords *)closure)));
1290 /* check that we have enough room in the pack buffer */
1291 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1293 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1294 closure, info_type(closure)));
1295 PackFetchMe(closure);
1299 /* global stats about arrays sent */
1300 if (RtsFlags.ParFlags.ParStats.Global &&
1301 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
1302 globalParStats.tot_arrs++;
1303 globalParStats.tot_arr_size += ((StgArrWords *)closure)->words;
1306 /* record offset of the closure and allocate a GA */
1308 /* Checks for globalisation scheme; default: globalise everything thunks */
1309 if ( RtsFlags.ParFlags.globalising == 0 ||
1310 (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
1311 GlobaliseAndPackGA(closure);
1313 Pack((StgWord)2); // marker for unglobalised closure
1315 /* Pack the header (2 words: info ptr and the number of words to follow) */
1316 Pack((StgWord)*(StgPtr)closure);
1317 Pack(((StgArrWords *)closure)->words);
1319 /* pack the payload of the closure (all non-ptrs) */
1321 Pack((StgWord)((StgArrWords *)closure)->payload[i]);
1323 unpacked_size += arr_words_sizeW((StgArrWords *)closure);
1328 Note that the representation of a PAP in the buffer is different from
1329 its representation in the heap. In particular, pointers to local
1330 closures are packed directly as FETCHME closures, using
1331 PACK_FETCHME_SIZE words to represent q 1 word pointer in the orig graph
1332 structure. To account for the difference in size we store the packed
1333 size of the closure as part of the PAP's variable header in the buffer.
1338 PackPAP(StgPAP *pap) {
1339 nat n, i, j, pack_start;
1341 const StgInfoTable* info;
1343 /* debugging only */
1345 nat size, ptrs, nonptrs, vhs;
1347 nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
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)));
1353 unpacked_size_before_PAP = unpacked_size);
1355 n = (nat)(pap->n_args);
1357 /* get info about basic layout of the closure */
1358 info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
1359 ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
1362 belch("*>** %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:",
1363 (StgClosure *)pap, info_type((StgClosure *)pap),
1364 n, size, ptrs, nonptrs);
1365 printClosure((StgClosure *)pap));
1367 /* check that we have enough room in the pack buffer */
1368 if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
1370 belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
1371 (StgClosure *)pap, info_type((StgClosure *)pap)));
1372 PackFetchMe((StgClosure *)pap);
1376 /* record offset of the closure and allocate a GA */
1377 AmPacking((StgClosure *)pap);
1378 /* Checks for globalisation scheme; default: globalise everything thunks */
1379 if ( RtsFlags.ParFlags.globalising == 0 ||
1380 (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
1381 GlobaliseAndPackGA((StgClosure *)pap);
1383 Pack((StgWord)2); // marker for unglobalised closure
1385 /* Pack the PAP header */
1386 Pack((StgWord)(pap->header.info));
1387 Pack((StgWord)(pap->n_args));
1388 Pack((StgWord)(pap->fun));
1389 pack_start = pack_locn; // to compute size of PAP in buffer
1390 Pack((StgWord)0); // this will be filled in later (size of PAP in buffer)
1392 /* Pack the payload of a PAP i.e. a stack chunk */
1393 /* pointers to start of stack chunk */
1394 p = (StgPtr)(pap->payload);
1395 end = (StgPtr)((nat)pap+pap_sizeW(pap)*sizeof(StgWord)); // (StgPtr)((nat)pap+sizeof(StgPAP)+sizeof(StgPtr)*n);
1397 /* the loop body has been borrowed from scavenge_stack */
1400 /* If we've got a tag, pack all words in that block */
1401 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
1404 belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
1406 for (i=0; i<m+1; i++)
1407 Pack((StgWord)*(p+i));
1408 p += m+1; // m words + the tag
1412 /* If q is is a pointer to a (heap allocated) closure we pack a FETCH_ME
1413 ToDo: provide RTS flag to also pack these closures
1415 if (! LOOKS_LIKE_GHC_INFO(q) ) {
1416 /* distinguish static closure (PLC) from other closures (FM) */
1417 switch (get_itbl((StgClosure*)q)->type) {
1418 case CONSTR_CHARLIKE:
1420 belch("*>** PackPAP: packing a charlike closure %d",
1421 ((StgIntCharlikeClosure*)q)->data));
1423 PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
1427 case CONSTR_INTLIKE:
1429 StgInt val = ((StgIntCharlikeClosure*)q)->data;
1431 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
1433 belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
1434 PackPLC((StgPtr)INTLIKE_CLOSURE(val));
1439 belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
1441 Pack((StgWord)(ARGTAG_MAX+1));
1442 PackFetchMe((StgClosure *)q);
1444 IF_DEBUG(sanity, FMs_in_PAP++);
1448 case THUNK_STATIC: // ToDo: check whether that's ok
1449 case FUN_STATIC: // ToDo: check whether that's ok
1451 case CONSTR_NOCAF_STATIC:
1454 belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
1455 q, info_type((StgClosure *)q)));
1463 belch("*>** PackPAP @ %p: packing FM to %p (%s)",
1464 p, q, info_type((StgClosure*)q)));
1465 Pack((StgWord)(ARGTAG_MAX+1));
1466 PackFetchMe((StgClosure *)q);
1468 IF_DEBUG(sanity, FMs_in_PAP++);
1475 * Otherwise, q must be the info pointer of an activation
1476 * record. All activation records have 'bitmap' style layout
1479 info = get_itbl((StgClosure *)p);
1480 switch (info->type) {
1482 /* Dynamic bitmap: the mask is stored on the stack */
1485 belch("*>** PackPAP @ %p: RET_DYN",
1488 /* Pack the header as is */
1489 Pack((StgWord)(((StgRetDyn *)p)->info));
1490 Pack((StgWord)(((StgRetDyn *)p)->liveness));
1491 Pack((StgWord)(((StgRetDyn *)p)->ret_addr));
1493 bitmap = ((StgRetDyn *)p)->liveness;
1494 p = (P_)&((StgRetDyn *)p)->payload[0];
1497 /* probably a slow-entry point return address: */
1502 belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
1505 Pack((StgWord)(((StgClosure *)p)->header.info));
1508 goto follow_srt; //??
1511 /* Using generic code here; could inline as in scavenge_stack */
1514 StgUpdateFrame *frame = (StgUpdateFrame *)p;
1515 nat type = get_itbl(frame->updatee)->type;
1517 ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
1520 belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
1521 p, frame->updatee, frame->link));
1523 Pack((StgWord)(frame->header.info));
1524 Pack((StgWord)(frame->link)); // ToDo: fix intra-stack pointer
1525 Pack((StgWord)(frame->updatee)); // ToDo: follow link
1530 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
1534 belch("*>** PackPAP @ %p: STOP_FRAME",
1536 Pack((StgWord)((StgStopFrame *)p)->header.info);
1543 belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
1544 p, ((StgCatchFrame *)p)->handler));
1546 Pack((StgWord)((StgCatchFrame *)p)->header.info);
1547 Pack((StgWord)((StgCatchFrame *)p)->link); // ToDo: fix intra-stack pointer
1548 Pack((StgWord)((StgCatchFrame *)p)->exceptions_blocked);
1549 Pack((StgWord)((StgCatchFrame *)p)->handler);
1556 belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
1557 p, ((StgSeqFrame *)p)->link));
1559 Pack((StgWord)((StgSeqFrame *)p)->header.info);
1560 Pack((StgWord)((StgSeqFrame *)p)->link); // ToDo: fix intra-stack pointer
1562 // ToDo: handle bitmap
1563 bitmap = info->layout.bitmap;
1565 p = (StgPtr)&(((StgClosure *)p)->payload);
1572 belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
1573 p, info->layout.bitmap));
1576 Pack((StgWord)((StgClosure *)p)->header.info);
1578 // ToDo: handle bitmap
1579 bitmap = info->layout.bitmap;
1580 /* this assumes that the payload starts immediately after the info-ptr */
1583 while (bitmap != 0) {
1584 if ((bitmap & 1) == 0) {
1585 Pack((StgWord)(ARGTAG_MAX+1));
1586 PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
1587 IF_DEBUG(sanity, FMs_in_PAP++);
1589 Pack((StgWord)*p++);
1591 bitmap = bitmap >> 1;
1596 belch("*>-- PackPAP: nothing to do for follow_srt"));
1599 /* large bitmap (> 32 entries) */
1604 StgLargeBitmap *large_bitmap;
1607 belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
1608 p, info->layout.large_bitmap));
1611 Pack((StgWord)((StgClosure *)p)->header.info);
1614 large_bitmap = info->layout.large_bitmap;
1616 for (j=0; j<large_bitmap->size; j++) {
1617 bitmap = large_bitmap->bitmap[j];
1618 q = p + BITS_IN(W_);
1619 while (bitmap != 0) {
1620 if ((bitmap & 1) == 0) {
1621 Pack((StgWord)(ARGTAG_MAX+1));
1622 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
1623 IF_DEBUG(sanity, FMs_in_PAP++);
1625 Pack((StgWord)*p++);
1627 bitmap = bitmap >> 1;
1629 if (j+1 < large_bitmap->size) {
1631 Pack((StgWord)(ARGTAG_MAX+1));
1632 PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
1633 IF_DEBUG(sanity, FMs_in_PAP++);
1638 /* and don't forget to follow the SRT */
1643 barf("PackPAP: weird activation record found on stack (@ %p): %d",
1644 p, (int)(info->type));
1647 // fill in size of the PAP (only the payload!) in buffer
1648 globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
1650 We can use the generic pap_sizeW macro to compute the size of the
1651 unpacked PAP because whenever we pack a new FETCHME as part of the
1652 PAP's payload we also adjust unpacked_size accordingly (smart, aren't we?)
1654 NB: the current PAP (un-)packing code relies on the fact that
1655 the size of the unpacked PAP + size of all unpacked FMs is the same as
1656 the size of the packed PAP!!
1658 unpacked_size += pap_sizeW(pap); // sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
1660 ASSERT(unpacked_size-unpacked_size_before_PAP==pap_sizeW(pap)+FMs_in_PAP*sizeofW(StgFetchMe)));
1664 /* Fake the packing of a closure */
1667 PackClosure(closure)
1668 StgClosure *closure;
1670 StgInfoTable *info, *childInfo;
1671 nat size, ptrs, nonptrs, vhs;
1672 char info_hdr_ty[80];
1674 StgClosure *indirectee, *rbh;
1676 rtsBool is_mutable, will_be_rbh, no_more_thunks_please;
1678 is_mutable = rtsFalse;
1680 /* In GranSim we don't pack and unpack closures -- we just simulate
1681 packing by updating the bitmask. So, the graph structure is unchanged
1682 i.e. we don't short out indirections here. -- HWL */
1684 /* Nothing to do with packing but good place to (sanity) check closure;
1685 if the closure is a thunk, it must be unique; otherwise we have copied
1686 work at some point before that which violates one of our main global
1687 assertions in GranSim/GUM */
1688 ASSERT(!closure_THUNK(closure) || is_unique(closure));
1691 belch("** Packing closure %p (%s)",
1692 closure, info_type(closure)));
1694 if (where_is(closure) != where_is(graph_root)) {
1696 belch("** faking a FETCHME [current PE: %d, closure's PE: %d]",
1697 where_is(graph_root), where_is(closure)));
1699 /* GUM would pack a FETCHME here; simulate that by increasing the */
1700 /* unpacked size accordingly but don't pack anything -- HWL */
1701 unpacked_size += _HS + 2 ; // sizeofW(StgFetchMe);
1705 /* If the closure's not already being packed */
1706 if (!NotYetPacking(closure))
1707 /* Don't have to do anything in GrAnSim if closure is already */
1711 belch("** Closure %p is already packed and omitted now!",
1716 switch (get_itbl(closure)->type) {
1717 /* ToDo: check for sticky bit here? */
1718 /* BH-like closures which must not be moved to another PE */
1719 case CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1720 case SE_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1721 case SE_CAF_BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1722 case BLACKHOLE: /* # of ptrs, nptrs: 0,2 */
1723 case BLACKHOLE_BQ: /* # of ptrs, nptrs: 1,1 */
1724 case RBH: /* # of ptrs, nptrs: 1,1 */
1725 /* same for these parallel specific closures */
1730 belch("** Avoid packing BH-like closures (%p, %s)!",
1731 closure, info_type(closure)));
1732 /* Just ignore RBHs i.e. they stay where they are */
1735 case THUNK_SELECTOR:
1737 StgClosure *selectee = ((StgSelector *)closure)->selectee;
1740 belch("** Avoid packing THUNK_SELECTOR (%p, %s) but queuing %p (%s)!",
1741 closure, info_type(closure), selectee, info_type(selectee)));
1742 QueueClosure(selectee);
1744 belch("** [%p (%s) (Queueing closure) ....]",
1745 selectee, info_type(selectee)));
1750 case CONSTR_NOCAF_STATIC:
1751 /* For now we ship indirections to CAFs:
1752 * They are evaluated on each PE if needed */
1754 belch("** Nothing to pack for %p (%s)!",
1755 closure, info_type(closure)));
1756 // Pack(closure); GUM only
1759 case CONSTR_CHARLIKE:
1760 case CONSTR_INTLIKE:
1762 belch("** Nothing to pack for %s (%p)!",
1763 closure, info_type(closure)));
1764 // PackPLC(((StgIntCharlikeClosure *)closure)->data); GUM only
1769 /* partial applications; special treatment necessary? */
1773 barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
1774 closure, info_type(closure));
1779 case MUT_ARR_PTRS_FROZEN:
1780 /* Mutable objects; require special treatment to ship all data */
1781 is_mutable = rtsTrue;
1787 /* weak pointers and other FFI objects */
1788 barf("{PackClosure}Daq Qagh: found an FFI object (%p, %s); FFI not yet supported by GranSim, sorry",
1789 closure, info_type(closure));
1792 /* parallel objects */
1793 barf("{PackClosure}Daq Qagh: found a TSO when packing (%p, %s); thread migration not yet implemented, sorry",
1794 closure, info_type(closure));
1797 /* Hugs objects (i.e. closures used by the interpreter) */
1798 barf("{PackClosure}Daq Qagh: found a Hugs closure when packing (%p, %s); GranSim not yet integrated with Hugs, sorry",
1799 closure, info_type(closure));
1801 case IND: /* # of ptrs, nptrs: 1,0 */
1802 case IND_STATIC: /* # of ptrs, nptrs: 1,0 */
1803 case IND_PERM: /* # of ptrs, nptrs: 1,1 */
1804 case IND_OLDGEN: /* # of ptrs, nptrs: 1,1 */
1805 case IND_OLDGEN_PERM: /* # of ptrs, nptrs: 1,1 */
1806 /* we shouldn't find an indirection here, because we have shorted them
1807 out at the beginning of this functions already.
1811 barf("{PackClosure}Daq Qagh: found indirection when packing (%p, %s)",
1812 closure, info_type(closure));
1819 /* stack frames; should never be found when packing for now;
1820 once we support thread migration these have to be covered properly
1822 barf("{PackClosure}Daq Qagh: found stack frame when packing (%p, %s)",
1823 closure, info_type(closure));
1831 /* vectored returns; should never be found when packing; */
1832 barf("{PackClosure}Daq Qagh: found vectored return (%p, %s)",
1833 closure, info_type(closure));
1835 case INVALID_OBJECT:
1836 barf("{PackClosure}Daq Qagh: found Invalid object (%p, %s)",
1837 closure, info_type(closure));
1841 Here we know that the closure is a CONSTR, FUN or THUNK (maybe
1842 a specialised version with wired in #ptr/#nptr info; currently
1843 we treat these specialised versions like the generic version)
1847 /* Otherwise it's not Fixed */
1849 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1850 will_be_rbh = closure_THUNK(closure) && !closure_UNPOINTED(closure);
1853 belch("** Info on closure %p (%s): size=%d; ptrs=%d",
1854 closure, info_type(closure),
1856 (will_be_rbh) ? "will become RBH" : "will NOT become RBH"));
1858 // check whether IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) -- HWL
1859 no_more_thunks_please =
1860 (RtsFlags.GranFlags.ThunksToPack>0) &&
1861 (packed_thunks>=RtsFlags.GranFlags.ThunksToPack);
1864 should be covered by get_closure_info
1865 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
1866 info->type == BLACKHOLE || info->type == RBH )
1867 size = ptrs = nonptrs = vhs = 0;
1869 /* Now peek ahead to see whether the closure has any primitive */
1870 /* array children */
1873 for (i = 0; i < ptrs; ++i) {
1875 W_ childSize, childPtrs, childNonPtrs, childVhs;
1877 childInfo = get_closure_info(((StgPtrPtr) (closure))[i + _HS + vhs],
1878 &childSize, &childPtrs, &childNonPtrs,
1879 &childVhs, junk_str);
1880 if (IS_BIG_MOTHER(childInfo)) {
1881 reservedPAsize += PACK_GA_SIZE + _HS +
1882 childVhs + childNonPtrs +
1883 childPtrs * PACK_FETCHME_SIZE;
1884 PAsize += PACK_GA_SIZE + _HS + childSize;
1885 PAptrs += childPtrs;
1889 /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
1890 * is full and it isn't a primitive array. N.B. Primitive arrays are
1891 * always packed (because their parents index into them directly) */
1893 if (IS_BLACK_HOLE(closure))
1897 !(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)
1898 || IS_BIG_MOTHER(info)))
1902 /* At last! A closure we can actually pack! */
1904 if (closure_MUTABLE(closure)) // not nec. && (info->type != FETCHME))
1905 belch("ghuH: Replicated a Mutable closure!");
1907 if (RtsFlags.GranFlags.GranSimStats.Global &&
1908 no_more_thunks_please && will_be_rbh) {
1909 globalGranStats.tot_cuts++;
1910 if ( RtsFlags.GranFlags.Debug.pack )
1911 belch("** PackClosure (w/ ThunksToPack=%d): Cutting tree with root at %#x\n",
1912 RtsFlags.GranFlags.ThunksToPack, closure);
1913 } else if (will_be_rbh || (closure==graph_root) ) {
1915 globalGranStats.tot_thunks++;
1918 if (no_more_thunks_please && will_be_rbh)
1919 return; /* don't pack anything */
1921 /* actual PACKING done here -- HWL */
1923 for (i = 0; i < ptrs; ++i) {
1924 /* extract i-th pointer from closure */
1925 QueueClosure((StgClosure *)(closure->payload[i]));
1927 belch("** [%p (%s) (Queueing closure) ....]",
1928 closure->payload[i],
1929 info_type(*stgCast(StgPtr*,((closure)->payload+(i))))));
1930 //^^^^^^^^^^^ payloadPtr(closure,i))));
1934 for packing words (GUM only) do something like this:
1936 for (i = 0; i < ptrs; ++i) {
1937 Pack(payloadWord(obj,i+j));
1940 /* Turn thunk into a revertible black hole. */
1942 rbh = convertToRBH(closure);
1943 ASSERT(rbh != NULL);
1948 //@node Low level packing routines, Unpacking routines, Packing Functions, Graph packing
1949 //@subsection Low level packing routines
1952 @Pack@ is the basic packing routine. It just writes a word of data into
1953 the pack buffer and increments the pack location. */
1962 ASSERT(pack_locn < RtsFlags.ParFlags.packBufferSize);
1963 globalPackBuffer->buffer[pack_locn++] = data;
1970 StgClosure *closure;
1973 nat size, ptrs, nonptrs, vhs;
1976 /* This checks the size of the GrAnSim internal pack buffer. The simulated
1977 pack buffer is checked via RoomToPack (as in GUM) */
1978 if (pack_locn >= (int)globalPackBuffer->size+sizeofW(rtsPackBuffer))
1979 reallocPackBuffer();
1981 if (closure==(StgClosure*)NULL)
1982 belch("Qagh {Pack}Daq: Trying to pack 0");
1983 globalPackBuffer->buffer[pack_locn++] = closure;
1984 /* ASSERT: Data is a closure in GrAnSim here */
1985 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
1986 // ToDo: is check for MIN_UPD_SIZE really needed? */
1987 unpacked_size += _HS + (size < MIN_UPD_SIZE ?
1994 If a closure is local, make it global. Then, divide its weight for
1995 export. The GA is then packed into the pack buffer. */
1998 //@cindex GlobaliseAndPackGA
2000 GlobaliseAndPackGA(closure)
2001 StgClosure *closure;
2006 if ((ga = LAGAlookup(closure)) == NULL) {
2007 ga = makeGlobal(closure, rtsTrue);
2009 // Global statistics: increase amount of global data by closure-size
2010 if (RtsFlags.ParFlags.ParStats.Global &&
2011 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2013 nat size, ptrs, nonptrs, vhs, i, m; // stats only!!
2014 char str[80]; // stats only!!
2016 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
2017 globalParStats.tot_global += size;
2020 ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
2022 if(dest_gtid==ga->payload.gc.gtid)
2023 { packGA.payload = ga->payload;
2024 packGA.weight = 0xFFFFFFFF; // 0,1,2 are used already
2027 { splitWeight(&packGA, ga);
2028 ASSERT(packGA.weight > 0);
2032 fprintf(stderr, "*>## %p (%s): Globalising (%s) closure with GA ",
2033 closure, info_type(closure),
2034 ( (ga->payload.gc.gtid==dest_gtid)?"returning":
2035 ( (ga->payload.gc.gtid==mytid)?"creating":"sharing" ) ));
2037 fputc('\n', stderr));
2040 Pack((StgWord) packGA.weight);
2041 Pack((StgWord) packGA.payload.gc.gtid);
2042 Pack((StgWord) packGA.payload.gc.slot);
2046 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
2047 address follows instead of PE, slot. */
2055 Pack(0L); /* weight */
2056 Pack((StgWord) addr); /* address */
2060 @PackOffset@ packs a special GA value that will be interpreted as an
2061 offset to a closure in the pack buffer. This is used to avoid unfolding
2062 the graph structure into a tree. */
2070 belch("** Packing Offset %d at pack location %u",
2071 offset, pack_locn));
2073 Pack(1L); /* weight */
2075 Pack(offset); /* slot/offset */
2079 //@node Unpacking routines, Aux fcts for packing, Low level packing routines, Graph packing
2080 //@subsection Unpacking routines
2083 This was formerly in the (now deceased) module Unpack.c
2085 Unpacking closures which have been exported to remote processors
2087 This module defines routines for unpacking closures in the parallel
2088 runtime system (GUM).
2090 In the case of GrAnSim, this module defines routines for *simulating* the
2091 unpacking of closures as it is done in the parallel runtime system.
2094 //@node GUM code, GranSim Code, Unpacking routines, Unpacking routines
2095 //@subsubsection GUM code
2099 //@cindex InitPendingGABuffer
2101 InitPendingGABuffer(size)
2104 if (PendingGABuffer==(globalAddr *)NULL)
2105 PendingGABuffer = (globalAddr *)
2106 stgMallocBytes(size*2*sizeof(globalAddr),
2107 "InitPendingGABuffer");
2109 /* current location in the buffer */
2110 gaga = PendingGABuffer;
2114 @CommonUp@ commons up two closures which we have discovered to be
2115 variants of the same object. One is made an indirection to the other. */
2119 CommonUp(StgClosure *src, StgClosure *dst)
2121 StgBlockingQueueElement *bqe;
2124 nat size, ptrs, nonptrs, vhs, i;
2127 /* get info about basic layout of the closure */
2128 info = get_closure_info(src, &size, &ptrs, &nonptrs, &vhs, str);
2131 ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
2135 belch("*___ CommonUp %p (%s) --> %p (%s)",
2136 src, info_type(src), dst, info_type(dst)));
2138 switch (get_itbl(src)->type) {
2140 bqe = ((StgBlockingQueue *)src)->blocking_queue;
2144 bqe = ((StgFetchMeBlockingQueue *)src)->blocking_queue;
2148 bqe = ((StgRBH *)src)->blocking_queue;
2156 /* These closures are too small to be updated with an indirection!!! */
2159 ASSERT(size<_HS+MIN_UPD_SIZE); // that's why we have to avoid UPD_IND
2162 /* currently we also common up 2 CONSTRs; this should reduce heap
2163 * consumption but also does more work; not sure whether it's worth doing
2171 case MUT_ARR_PTRS_FROZEN:
2176 /* Don't common up anything else */
2180 /* closure must be big enough to permit update with ind */
2181 ASSERT(size>=_HS+MIN_UPD_SIZE);
2182 /* NB: this also awakens the blocking queue for src */
2187 * Common up the new closure with any existing closure having the same
2190 //@cindex SetGAandCommonUp
2192 SetGAandCommonUp(globalAddr *ga, StgClosure *closure, rtsBool hasGA)
2194 StgClosure *existing;
2195 StgInfoTable *ip, *oldip;
2201 /* should we already have a local copy? */
2202 if (ga->weight==0xFFFFFFFF) {
2203 ASSERT(ga->payload.gc.gtid==mytid); //sanity
2205 /* probably should also ASSERT that a commonUp takes place...*/
2208 ip = get_itbl(closure);
2209 if ((existing = GALAlookup(ga)) == NULL) {
2210 /* Just keep the new object */
2212 belch("*<## New local object for GA ((%x, %d, %x)) is %p (%s)",
2213 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2214 closure, info_type(closure)));
2216 // make an entry binding closure to ga in the RemoteGA table
2217 newGA = setRemoteGA(closure, ga, rtsTrue);
2218 // if local closure is a FETCH_ME etc fill in the global indirection
2219 if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
2220 ((StgFetchMe *)closure)->ga = newGA;
2225 // ***************************************************************************
2226 // ***************************************************************************
2227 // REMOTE_REF HACK - dual is in PackRemoteRef
2228 // - prevents the weight ever being updated
2229 if (ip->type == REMOTE_REF)
2231 // ***************************************************************************
2232 // ***************************************************************************
2235 /* Two closures, one global name. Someone loses */
2236 oldip = get_itbl(existing);
2237 if ((oldip->type == FETCH_ME ||
2238 IS_BLACK_HOLE(existing) ||
2239 /* try to share evaluated closures */
2240 oldip->type == CONSTR ||
2241 oldip->type == CONSTR_1_0 ||
2242 oldip->type == CONSTR_0_1 ||
2243 oldip->type == CONSTR_2_0 ||
2244 oldip->type == CONSTR_1_1 ||
2245 oldip->type == CONSTR_0_2
2247 ip->type != FETCH_ME)
2250 belch("*<#- Duplicate local object for GA ((%x, %d, %x)); redirecting %p (%s) -> %p (%s)",
2251 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2252 existing, info_type(existing), closure, info_type(closure)));
2255 * What we had wasn't worth keeping, so make the old closure an
2256 * indirection to the new closure (copying BQs if necessary) and
2257 * make sure that the old entry is not the preferred one for this
2260 CommonUp(existing, closure);
2261 //GALAdeprecate(ga);
2265 nat size, ptrs, nonptrs, vhs, i;
2268 /* get info about basic layout of the closure */
2269 info = get_closure_info(GALAlookup(ga), &size, &ptrs, &nonptrs, &vhs, str);
2271 /* now ga indirectly refers to the new closure */
2272 ASSERT(size<_HS+MIN_UPD_SIZE ||
2273 UNWIND_IND(GALAlookup(ga))==closure);
2278 * Either we already had something worthwhile by this name or
2279 * the new thing is just another FetchMe. However, the thing we
2280 * just unpacked has to be left as-is, or the child unpacking
2281 * code will fail. Remember that the way pointer words are
2282 * filled in depends on the info pointers of the parents being
2283 * the same as when they were packed.
2286 belch("*<#@ Duplicate local object for GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
2287 ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
2288 existing, info_type(existing), closure, info_type(closure)));
2290 /* overwrite 2nd word; indicates that the closure is garbage */
2292 ((StgFetchMe*)closure)->ga = (globalAddr*)GARBAGE_MARKER;
2294 belch("++++ unpacked closure %p (%s) is garbage: %p",
2295 closure, info_type(closure), *(closure+1))));
2300 ty = get_itbl(closure)->type;
2307 CommonUp(closure, graph);
2310 /* We don't use this GA after all, so give back the weight */
2311 (void) addWeight(ga);
2314 /* if we have unpacked a FETCH_ME, we have a GA, too */
2315 ASSERT(get_itbl(closure)->type!=FETCH_ME ||
2316 looks_like_ga(((StgFetchMe*)closure)->ga));
2318 /* Sort out the global address mapping */
2320 // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
2321 //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) {
2322 /* Make up new GAs for single-copy closures */
2323 globalAddr *newGA = makeGlobal(closure, rtsTrue);
2325 // It's a new GA and therefore has the full weight
2326 ASSERT(newGA->weight==0);
2328 /* Create an old GA to new GA mapping */
2330 splitWeight(gaga, newGA);
2331 /* inlined splitWeight; we know that newGALA has full weight
2332 newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
2333 gaga->payload = newGA->payload;
2335 ASSERT(gaga->weight == 1U << (BITS_IN(unsigned) - 1));
2342 Copies a segment of the buffer, starting at @bufptr@, representing a closure
2343 into the heap at @graph@.
2345 //@cindex FillInClosure
2347 FillInClosure(StgWord ***bufptrP, StgClosure *graph)
2350 StgWord **bufptr = *bufptrP;
2351 nat ptrs, nonptrs, vhs, i, size;
2354 ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure*)bufptr)->header.info));
2357 * Close your eyes. You don't want to see where we're looking. You
2358 * can't get closure info until you've unpacked the variable header,
2359 * but you don't know how big it is until you've got closure info.
2360 * So...we trust that the closure in the buffer is organized the
2361 * same way as they will be in the heap...at least up through the
2362 * end of the variable header.
2364 ip = get_closure_info((StgClosure *)bufptr, &size, &ptrs, &nonptrs, &vhs, str);
2366 /* Make sure that nothing sans the fixed header is filled in
2367 The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
2368 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
2369 ASSERT(size>=_HS+MIN_UPD_SIZE); // size of the FM in the heap
2370 ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
2372 /* ToDo: check whether this is really needed */
2373 if (ip->type == ARR_WORDS) {
2374 UnpackArray(bufptrP, graph);
2375 return arr_words_sizeW((StgArrWords *)bufptr);
2378 if (ip->type == PAP || ip->type == AP_UPD) {
2379 return UnpackPAP(bufptrP, graph); // includes size of unpackes FMs
2383 Remember, the generic closure layout is as follows:
2384 +-------------------------------------------------+
2385 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
2386 +-------------------------------------------------+
2388 /* Fill in the fixed header */
2389 for (i = 0; i < _HS; i++)
2390 ((StgPtr)graph)[i] = (StgWord)*bufptr++;
2392 /* Fill in the packed variable header */
2393 for (i = 0; i < vhs; i++)
2394 ((StgPtr)graph)[_HS + i] = (StgWord)*bufptr++;
2396 /* Pointers will be filled in later */
2398 /* Fill in the packed non-pointers */
2399 for (i = 0; i < nonptrs; i++)
2400 ((StgPtr)graph)[_HS + i + vhs + ptrs] = (StgWord)*bufptr++;
2402 /* Indirections are never packed */
2403 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
2406 ASSERT(((ip->type==FETCH_ME || ip->type==REMOTE_REF)&& sizeofW(StgFetchMe)==size) ||
2407 _HS+vhs+ptrs+nonptrs == size);
2412 Find the next pointer field in the parent closure.
2413 If the current parent has been completely unpacked already, get the
2414 next closure from the global closure queue.
2416 //@cindex LocateNextParent
2418 LocateNextParent(parentP, pptrP, pptrsP, sizeP)
2419 StgClosure **parentP;
2420 nat *pptrP, *pptrsP, *sizeP;
2422 StgInfoTable *ip; // debugging
2426 /* pptr as an index into the current parent; find the next pointer field
2427 in the parent by increasing pptr; if that takes us off the closure
2428 (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue
2431 while (*pptrP + 1 > *pptrsP) {
2432 /* *parentP has been constructed (all pointer set); so check it now */
2434 if ((*parentP!=(StgClosure*)NULL) && // not root
2435 (*((StgPtr)(*parentP)+1)!=GARBAGE_MARKER) && // not commoned up
2436 (get_itbl(*parentP)->type != FETCH_ME))
2437 checkClosure(*parentP));
2439 *parentP = DeQueueClosure();
2441 if (*parentP == NULL)
2444 ip = get_closure_info(*parentP, sizeP, pptrsP, &nonptrs,
2449 /* *parentP points to the new (or old) parent; */
2450 /* *pptr, *pptrs and *size have been updated referring to the new parent */
2454 UnpackClosure is the heart of the unpacking routine. It is called for
2455 every closure found in the packBuffer. Any prefix such as GA, PLC marker
2456 etc has been unpacked into the *ga structure.
2457 UnpackClosure does the following:
2458 - check for the kind of the closure (PLC, Offset, std closure)
2459 - copy the contents of the closure from the buffer into the heap
2460 - update LAGA tables (in particular if we end up with 2 closures
2461 having the same GA, we make one an indirection to the other)
2462 - set the GAGA map in order to send back an ACK message
2464 At the end of this function *graphP has been updated to point to the
2465 next free word in the heap for unpacking the rest of the graph and
2466 *bufptrP points to the next word in the pack buffer to be unpacked.
2470 UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
2471 StgClosure *closure;
2473 rtsBool hasGA = rtsFalse, unglobalised = rtsFalse;
2475 /* Now unpack the closure body, if there is one; three cases:
2476 - PLC: closure is just a pointer to a static closure
2477 - Offset: closure has been unpacked already
2478 - else: copy data from packet into closure
2481 closure = UnpackPLC(ga);
2482 } else if (isOffset(ga)) {
2483 closure = UnpackOffset(ga);
2485 /* if not PLC or Offset it must be a GA and then the closure */
2486 ASSERT(RtsFlags.ParFlags.globalising!=0 || LOOKS_LIKE_GA(ga));
2487 /* check whether this is an unglobalised closure */
2488 unglobalised = isUnglobalised(ga);
2489 /* Now we have to build something. */
2490 hasGA = !isConstr(ga);
2491 /* the new closure will be built here */
2494 /* fill in the closure from the buffer */
2495 size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
2496 /* if it is unglobalised, it may not be a thunk!! */
2497 ASSERT(!unglobalised || !closure_THUNK(closure));
2499 /* Add to queue for processing */
2500 QueueClosure(closure);
2502 /* common up with other graph if necessary */
2504 closure = SetGAandCommonUp(ga, closure, hasGA);
2506 /* if we unpacked a THUNK, check that it is large enough to update */
2507 ASSERT(!closure_THUNK(closure) || size>=_HS+MIN_UPD_SIZE);
2508 /* graph shall point to next free word in the heap */
2510 //*graphP += (size < _HS+MIN_UPD_SIZE) ? _HS+MIN_UPD_SIZE : size; // see ASSERT
2516 @UnpackGraph@ unpacks the graph contained in a message buffer. It
2517 returns a pointer to the new graph. The @gamap@ parameter is set to
2518 point to an array of (oldGA,newGA) pairs which were created as a result
2519 of unpacking the buffer; @nGAs@ is set to the number of GA pairs which
2522 The format of graph in the pack buffer is as defined in @Pack.lc@. */
2524 //@cindex UnpackGraph
2526 UnpackGraph(packBuffer, gamap, nGAs)
2527 rtsPackBuffer *packBuffer;
2531 StgWord **bufptr, **slotptr;
2533 StgClosure *closure, *graphroot, *graph, *parent;
2534 nat size, heapsize, bufsize,
2535 pptr = 0, pptrs = 0, pvhs = 0;
2536 nat unpacked_closures = 0, unpacked_thunks = 0; // stats only
2538 IF_PAR_DEBUG(resume,
2539 graphFingerPrint[0] = '\0');
2541 ASSERT(_HS==1); // HWL HACK; compile time constant
2543 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2544 PAR_TICKY_UNPACK_GRAPH_START();
2547 /* Initialisation */
2548 InitPacking(rtsTrue); // same as in PackNearbyGraph
2549 globalUnpackBuffer = packBuffer;
2551 IF_DEBUG(sanity, // do a sanity check on the incoming packet
2552 checkPacket(packBuffer));
2554 ASSERT(gaga==PendingGABuffer);
2555 graphroot = (StgClosure *)NULL;
2557 /* Unpack the header */
2558 bufsize = packBuffer->size;
2559 heapsize = packBuffer->unpacked_size;
2560 bufptr = packBuffer->buffer;
2564 graph = (StgClosure *)allocate(heapsize);
2565 ASSERT(graph != NULL);
2566 // parallel global statistics: increase amount of global data
2567 if (RtsFlags.ParFlags.ParStats.Global &&
2568 RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
2569 globalParStats.tot_global += heapsize;
2573 /* iterate over the buffer contents and unpack all closures */
2574 parent = (StgClosure *)NULL;
2576 /* check that we aren't at the end of the buffer, yet */
2577 IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
2579 /* This is where we will ultimately save the closure's address */
2582 /* fill in gaS from buffer; gaS may receive GA, PLC- or offset-marker */
2583 bufptr = UnpackGA(/*in*/bufptr, /*out*/&gaS);
2585 /* this allocates heap space, updates LAGA tables etc */
2586 closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
2587 unpacked_closures++; // stats only; doesn't count FMs in PAP!!!
2588 unpacked_thunks += (closure_THUNK(closure)) ? 1 : 0; // stats only
2591 * Set parent pointer to point to chosen closure. If we're at the top of
2592 * the graph (our parent is NULL), then we want to arrange to return the
2593 * chosen closure to our caller (possibly in place of the allocated graph
2597 graphroot = closure;
2599 ((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
2601 /* Save closure pointer for resolving offsets */
2602 *slotptr = (StgWord*) closure;
2604 /* Locate next parent pointer */
2605 LocateNextParent(&parent, &pptr, &pptrs, &size);
2608 gaS.weight = 0xdeadffff;
2609 gaS.payload.gc.gtid = 0xdead;
2610 gaS.payload.gc.slot = 0xdeadbeef;);
2611 } while (parent != NULL);
2613 IF_PAR_DEBUG(resume,
2614 GraphFingerPrint(graphroot, graphFingerPrint);
2615 ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
2616 belch(">>> Fingerprint of graph rooted at %p (after unpacking <<%d>>:\n {%s}",
2617 graphroot, packBuffer->id, graphFingerPrint));
2619 /* we unpacked exactly as many words as there are in the buffer */
2620 ASSERT(bufsize == (nat) (bufptr-(packBuffer->buffer)));
2621 /* we filled no more heap closure than we allocated at the beginning;
2622 ideally this should be a ==;
2623 NB: test is only valid if we unpacked anything at all (graphroot might
2624 end up to be a PLC!), therfore the strange test for HEAP_ALLOCED
2629 StgInfoTable *info = get_itbl(graphroot);
2630 ASSERT(!HEAP_ALLOCED(graphroot) || heapsize >= (nat) (graph-graphroot) ||
2631 // ToDo: check whether CAFs are really a special case here!!
2632 info->type==CAF_BLACKHOLE || info->type==FETCH_ME || info->type==FETCH_ME_BQ);
2636 /* check for magic end-of-buffer word */
2637 IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
2639 *gamap = PendingGABuffer;
2640 *nGAs = (gaga - PendingGABuffer) / 2;
2642 IF_PAR_DEBUG(tables,
2643 belch("** LAGA table after unpacking closure %p:",
2647 /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
2648 ASSERT(graphroot!=NULL);
2654 /* check the unpacked graph */
2655 //checkHeapChunk(graphroot,graph-sizeof(StgWord));
2657 // if we do sanity checks, then wipe the pack buffer after unpacking
2658 for (p=(StgPtr)packBuffer->buffer; p<(StgPtr)(packBuffer->buffer)+(packBuffer->size); )
2662 /* reset the global variable */
2663 globalUnpackBuffer = (rtsPackBuffer*)NULL;
2665 #if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
2666 PAR_TICKY_UNPACK_GRAPH_END(unpacked_closures, unpacked_thunks);
2674 UnpackGA(StgWord **bufptr, globalAddr *ga)
2676 /* First, unpack the next GA or PLC */
2677 ga->weight = (rtsWeight) *bufptr++;
2679 if (ga->weight == 2) { // unglobalised closure to follow
2680 // nothing to do; closure starts at *bufptr
2681 } else if (ga->weight > 0) { // fill in GA
2682 ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
2683 ga->payload.gc.slot = (int) *bufptr++;
2685 ga->payload.plc = (StgPtr) *bufptr++;
2692 UnpackPLC(globalAddr *ga)
2694 /* No more to unpack; just set closure to local address */
2696 belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
2697 return (StgClosure*)ga->payload.plc;
2700 //@cindex UnpackOffset
2702 UnpackOffset(globalAddr *ga)
2704 /* globalUnpackBuffer is a global var init in UnpackGraph */
2705 ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
2706 /* No more to unpack; just set closure to cached address */
2708 belch("*<__ Unpacked indirection to %p (was OFFSET %d)",
2709 (StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
2710 ga->payload.gc.slot));
2711 return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
2715 Input: *bufptrP, *graphP ... ptrs to the pack buffer and into the heap.
2717 *bufptrP points to something that should be unpacked as a FETCH_ME:
2720 +-------------------------------
2722 +-------------------------------
2724 The first 3 words starting at *bufptrP are the GA address; the next
2725 word is the generic FM info ptr followed by the remaining FH (if any)
2726 The result after unpacking will be a FETCH_ME closure, pointed to by
2727 *graphP at the start of the fct;
2730 +------------------------+
2731 | FH of FM | ptr to a GA |
2732 +------------------------+
2734 The ptr field points into the RemoteGA table, which holds the actual GA.
2735 *bufptrP has been updated to point to the next word in the buffer.
2736 *graphP has been updated to point to the first free word at the end.
2740 UnpackFetchMe (StgWord ***bufptrP, StgClosure **graphP) {
2741 StgClosure *closure, *foo;
2744 /* This fct relies on size of FM < size of FM in pack buffer */
2745 ASSERT(sizeofW(StgFetchMe)<=PACK_FETCHME_SIZE);
2747 /* fill in gaS from buffer */
2748 *bufptrP = UnpackGA(*bufptrP, &gaS);
2749 /* might be an offset to a closure in the pack buffer */
2750 if (isOffset(&gaS)) {
2751 belch("*< UnpackFetchMe: found OFFSET to %d when unpacking FM at buffer loc %p",
2752 gaS.payload.gc.slot, *bufptrP);
2754 closure = UnpackOffset(&gaS);
2755 /* return address of previously unpacked closure; leaves *graphP unchanged */
2759 /* we have a proper GA at hand */
2760 ASSERT(LOOKS_LIKE_GA(&gaS));
2764 barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
2765 *bufptrP, info_type((StgClosure*)*bufptrP)));
2768 belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
2771 fputc('\n', stderr));
2773 /* the next thing must be the IP to a FETCH_ME closure */
2774 ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
2777 /* fill in the closure from the buffer */
2778 FillInClosure(bufptrP, closure);
2780 /* the newly built closure is a FETCH_ME */
2781 ASSERT(get_itbl(closure)->type == FETCH_ME);
2783 /* common up with other graph if necessary
2784 this also assigns the contents of gaS to the ga field of the FM closure */
2785 foo = SetGAandCommonUp(&gaS, closure, rtsTrue);
2787 ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
2790 if (foo==closure) { // only if not commoned up
2791 belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
2792 *graphP, *graphP+sizeofW(StgFetchMe), closure);
2793 printClosure(closure);
2795 *graphP += sizeofW(StgFetchMe);
2800 Unpack an array of words.
2801 Could use generic unpack most of the time, but cleaner to separate it.
2802 ToDo: implement packing of MUT_ARRAYs
2805 //@cindex UnackArray
2807 UnpackArray(StgWord ***bufptrP, StgClosure *graph)
2810 StgWord **bufptr=*bufptrP;
2811 nat size, ptrs, nonptrs, vhs, i, n;
2814 /* yes, I know I am paranoid; but who's asking !? */
2816 info = get_closure_info((StgClosure*)bufptr,
2817 &size, &ptrs, &nonptrs, &vhs, str);
2818 ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
2819 info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
2821 n = ((StgArrWords *)bufptr)->words;
2822 // this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
2826 belch("*<== unpacking an array of %d words %p (%s) (size=%d) |%s|\n",
2827 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2828 arr_words_sizeW((StgArrWords *)bufptr),
2829 /* print array (string?) */
2830 ((StgArrWords *)graph)->payload);
2832 belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
2833 n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
2834 arr_words_sizeW((StgArrWords *)bufptr)));
2836 /* Unpack the header (2 words: info ptr and the number of words to follow) */
2837 ((StgArrWords *)graph)->header.info = (StgInfoTable*)*bufptr++; // assumes _HS==1; yuck!
2838 ((StgArrWords *)graph)->words = (StgWord)*bufptr++;
2840 /* unpack the payload of the closure (all non-ptrs) */
2842 ((StgArrWords *)graph)->payload[i] = (StgWord)*bufptr++;
2844 ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
2849 Unpack a PAP in the buffer into a heap closure.
2850 For each FETCHME we find in the packed PAP we have to unpack a separate
2851 FETCHME closure and insert a pointer to this closure into the PAP.
2852 We unpack all FETCHMEs into an area after the PAP proper (the `FM area').
2853 Note that the size of a FETCHME in the buffer is exactly the same as
2854 the size of an unpacked FETCHME plus 1 word for the pointer to it.
2855 Therefore, we just allocate packed_size words in the heap for the unpacking.
2856 After this routine the heap starting from *graph looks like this:
2860 v PAP closure | FM area |
2861 +------------------------------------------------------------+
2862 | PAP header | n_args | fun | payload ... | FM_1 | FM_2 .... |
2863 +------------------------------------------------------------+
2865 where payload contains pointers to each of the unpacked FM_1, FM_2 ...
2866 The size of the PAP closure plus all FMs is _HS+2+packed_size.
2871 UnpackPAP(StgWord ***bufptrP, StgClosure *graph)
2873 nat n, i, j, packed_size = 0;
2874 StgPtr p, q, end, payload_start, p_FMs;
2875 const StgInfoTable* info;
2877 StgWord **bufptr = *bufptrP;
2880 void checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end);
2884 belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
2885 *bufptr, *(bufptr+1), graph));
2887 /* Unpack the PAP header (both fixed and variable) */
2888 ((StgPAP *)graph)->header.info = (StgInfoTable*)*bufptr++;
2889 n = ((StgPAP *)graph)->n_args = (StgWord)*bufptr++;
2890 ((StgPAP *)graph)->fun = (StgClosure*)*bufptr++;
2891 packed_size = (nat)*bufptr++;
2894 belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
2895 ((StgPAP *)graph)->header.info,
2896 ((StgPAP *)graph)->n_args,
2897 ((StgPAP *)graph)->fun,
2900 payload_start = (StgPtr)bufptr;
2901 /* p points to the current word in the heap */
2902 p = (StgPtr)((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
2903 p_FMs = (StgPtr)graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
2904 end = (StgPtr) payload_start+packed_size;
2906 The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
2907 FM area for unpacking all FETCHMEs encountered during unpacking.
2909 while ((StgPtr)bufptr<end) {
2910 /* be sure that we don't write more than we allocated for this closure */
2911 ASSERT(p_FMs <= (StgPtr)(graph+_HS+2+packed_size));
2912 /* be sure that the unpacked PAP doesn't run into the FM area */
2913 ASSERT(p < (StgPtr)(graph+pap_sizeW((StgPAP*)graph)));
2914 /* the loop body has been borrowed from scavenge_stack */
2915 q = *bufptr; // let q be the contents of the current pointer into the buffer
2917 /* Test whether the next thing is a FETCH_ME.
2918 In PAPs FETCH_ME are encoded via a starting marker of ARGTAG_MAX+1
2920 if (q==(StgPtr)(ARGTAG_MAX+1)) {
2922 belch("*<** UnpackPAP @ %p: unpacking FM; filling in ptr to FM area: %p",
2924 bufptr++; // skip ARGTAG_MAX+1 marker
2925 // Unpack a FM into the FM area after the PAP proper and insert pointer
2926 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
2927 IF_DEBUG(sanity, FMs_in_PAP++);
2931 /* Test whether it is a PLC */
2932 if (q==(StgPtr)0) { // same as isFixed(q)
2934 belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
2936 bufptr++; // skip 0 marker
2937 *p++ = (StgWord)*bufptr++;
2941 /* If we've got a tag, pack all words in that block */
2942 if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
2943 nat m = ARG_SIZE(q); // first word after this block
2945 belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
2947 for (i=0; i<m+1; i++)
2948 *p++ = (StgWord)*bufptr++;
2953 * Otherwise, q must be the info pointer of an activation
2954 * record. All activation records have 'bitmap' style layout
2957 info = get_itbl((StgClosure *)q);
2958 switch (info->type) {
2960 /* Dynamic bitmap: the mask is stored on the stack */
2963 belch("*<** UnpackPAP @ %p: RET_DYN",
2966 /* Pack the header as is */
2967 ((StgRetDyn *)p)->info = (StgWord)*bufptr++;
2968 ((StgRetDyn *)p)->liveness = (StgWord)*bufptr++;
2969 ((StgRetDyn *)p)->ret_addr = (StgWord)*bufptr++;
2972 //bitmap = ((StgRetDyn *)p)->liveness;
2973 //p = (P_)&((StgRetDyn *)p)->payload[0];
2976 /* probably a slow-entry point return address: */
2981 belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
2984 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr;
2987 goto follow_srt; //??
2990 /* Using generic code here; could inline as in scavenge_stack */
2993 StgUpdateFrame *frame = (StgUpdateFrame *)p;
2994 //nat type = get_itbl(frame->updatee)->type;
2996 //ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
2999 belch("*<** UnackPAP @ %p: UPDATE_FRAME",
3002 ((StgUpdateFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3003 ((StgUpdateFrame *)p)->link = (StgUpdateFrame*)*bufptr++; // ToDo: fix intra-stack pointer
3004 ((StgUpdateFrame *)p)->updatee = (StgClosure*)*bufptr++; // ToDo: follow link
3009 /* small bitmap (< 32 entries, or 64 on a 64-bit machine) */
3013 belch("*<** UnpackPAP @ %p: STOP_FRAME",
3015 ((StgStopFrame *)p)->header.info = (StgInfoTable*)*bufptr;
3022 belch("*<** UnpackPAP @ %p: CATCH_FRAME",
3025 ((StgCatchFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3026 ((StgCatchFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
3027 ((StgCatchFrame *)p)->exceptions_blocked = (StgInt)*bufptr++;
3028 ((StgCatchFrame *)p)->handler = (StgClosure*)*bufptr++;
3035 belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
3038 ((StgSeqFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
3039 ((StgSeqFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
3041 // ToDo: handle bitmap
3042 bitmap = info->layout.bitmap;
3044 p = (StgPtr)&(((StgClosure *)p)->payload);
3051 belch("*<** UnpackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL}",
3055 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3057 // ToDo: handle bitmap
3058 bitmap = info->layout.bitmap;
3059 /* this assumes that the payload starts immediately after the info-ptr */
3062 while (bitmap != 0) {
3063 if ((bitmap & 1) == 0) {
3064 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3065 IF_DEBUG(sanity, FMs_in_PAP++);
3067 *p++ = (StgWord)*bufptr++;
3069 bitmap = bitmap >> 1;
3073 belch("*<-- UnpackPAP: nothing to do for follow_srt");
3076 /* large bitmap (> 32 entries) */
3081 StgLargeBitmap *large_bitmap;
3084 belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
3085 p, info->layout.large_bitmap));
3088 ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
3091 large_bitmap = info->layout.large_bitmap;
3093 for (j=0; j<large_bitmap->size; j++) {
3094 bitmap = large_bitmap->bitmap[j];
3095 q = p + BITS_IN(W_);
3096 while (bitmap != 0) {
3097 if ((bitmap & 1) == 0) {
3098 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3099 IF_DEBUG(sanity, FMs_in_PAP++);
3101 *p++ = (StgWord)*bufptr;
3103 bitmap = bitmap >> 1;
3105 if (j+1 < large_bitmap->size) {
3107 *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
3108 IF_DEBUG(sanity, FMs_in_PAP++);
3113 /* and don't forget to follow the SRT */
3118 barf("UnpackPAP: weird activation record found on stack: %d",
3123 belch("*<** UnpackPAP finished; unpacked closure @ %p is:",
3124 (StgClosure *)graph);
3125 printClosure((StgClosure *)graph));
3127 IF_DEBUG(sanity, /* check sanity of unpacked PAP */
3128 checkClosure(graph));
3132 Now p points to the first word after the PAP proper and p_FMs points
3133 to the next free word in the heap; everything between p and p_FMs are
3137 checkPAPSanity(graph, p, p_FMs));
3139 /* we have to return the size of PAP + FMs as size of the unpacked thing */
3140 ASSERT(graph+pap_sizeW((StgPAP*)graph)==p);
3141 return (nat)((StgClosure*)p_FMs-graph);
3146 Check sanity of a PAP after unpacking the PAP.
3147 This means that there is slice of heap after the PAP containing FETCHMEs
3150 checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end)
3154 /* check that the main unpacked closure is a PAP */
3155 ASSERT(graph->header.info = &stg_PAP_info);
3156 checkClosure(graph);
3157 /* check that all of the closures in the FM-area are FETCHMEs */
3158 for (xx=p_FM_begin; xx<p_FM_end; xx += sizeofW(StgFetchMe)) {
3159 /* must be a FETCHME closure */
3160 ASSERT(((StgClosure*)xx)->header.info == &stg_FETCH_ME_info);
3161 /* it might have been commoned up (=> marked as garbage);
3162 otherwise it points to a GA */
3163 ASSERT((((StgFetchMe*)xx)->ga)==GARBAGE_MARKER ||
3164 LOOKS_LIKE_GA(((StgFetchMe*)xx)->ga));
3166 /* traverse the payload of the PAP */
3167 for (xx=graph->payload; xx-(StgPtr)(graph->payload)<graph->n_args; xx++) {
3168 /* if the current elem is a pointer into the FM area, check that
3169 the GA field is ok */
3170 ASSERT(!(p_FM_begin<(StgPtr)*xx && (StgPtr)*xx<p_FM_end) ||
3171 LOOKS_LIKE_GA(((StgFetchMe*)*xx)->ga));
3177 //@node GranSim Code, , GUM code, Unpacking routines
3178 //@subsubsection GranSim Code
3181 For GrAnSim: No actual unpacking should be necessary. We just
3182 have to walk over the graph and set the bitmasks appropriately.
3183 Since we use RBHs similarly to GUM but without an ACK message/event
3184 we have to revert the RBH from within the UnpackGraph routine (good luck!)
3190 CommonUp(StgClosure *src, StgClosure *dst)
3192 barf("CommonUp: should never be entered in a GranSim setup");
3197 rtsPackBuffer* buffer;
3199 nat size, ptrs, nonptrs, vhs,
3201 StgClosure *closure, *graphroot, *graph;
3203 StgWord bufsize, unpackedsize,
3204 pptr = 0, pptrs = 0, pvhs;
3206 char str[240], str1[80];
3210 graphroot = buffer->buffer[0];
3214 /* Unpack the header */
3215 unpackedsize = buffer->unpacked_size;
3216 bufsize = buffer->size;
3219 belch("<<< Unpacking <<%d>> (buffer @ %p):\n (root @ %p, PE %d,size=%d), demanded by TSO %d (%p)[PE %d]",
3220 buffer->id, buffer, graphroot, where_is(graphroot),
3221 bufsize, tso->id, tso,
3222 where_is((StgClosure *)tso)));
3225 closure = buffer->buffer[bufptr++]; /* that's all we need for GrAnSim -- HWL */
3227 /* Actually only ip is needed; rest is useful for TESTING -- HWL */
3228 ip = get_closure_info(closure,
3229 &size, &ptrs, &nonptrs, &vhs, str);
3232 sprintf(str, "** (%p): Changing bitmask[%s]: 0x%x ",
3233 closure, (closure_HNF(closure) ? "NF" : "__"),
3236 if (get_itbl(closure)->type == RBH) {
3237 /* if it's an RBH, we have to revert it into a normal closure, thereby
3238 awakening the blocking queue; not that this is code currently not
3239 needed in GUM, but it should be added with the new features in
3240 GdH (and the implementation of an NACK message)
3242 // closure->header.gran.procs = PE_NUMBER(CurrentProc);
3243 SET_GRAN_HDR(closure, PE_NUMBER(CurrentProc)); /* Move node */
3246 strcat(str, " (converting RBH) "));
3248 convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
3251 belch(":: closure %p (%s) is a RBH; after reverting: IP=%p",
3252 closure, info_type(closure), get_itbl(closure)));
3253 } else if (IS_BLACK_HOLE(closure)) {
3255 belch(":: closure %p (%s) is a BH; copying node to %d",
3256 closure, info_type(closure), CurrentProc));
3257 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3258 } else if ( (closure->header.gran.procs & PE_NUMBER(CurrentProc)) == 0 ) {
3259 if (closure_HNF(closure)) {
3261 belch(":: closure %p (%s) is a HNF; copying node to %d",
3262 closure, info_type(closure), CurrentProc));
3263 closure->header.gran.procs |= PE_NUMBER(CurrentProc); /* Copy node */
3266 belch(":: closure %p (%s) is no (R)BH or HNF; moving node to %d",
3267 closure, info_type(closure), CurrentProc));
3268 closure->header.gran.procs = PE_NUMBER(CurrentProc); /* Move node */
3273 sprintf(str1, "0x%x", PROCS(closure)); strcat(str, str1));
3274 IF_GRAN_DEBUG(pack, belch(str));
3276 } while (bufptr<buffer->size) ; /* (parent != NULL); */
3278 /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
3279 free(buffer->buffer);
3283 belch("PrintGraph of %p is:", graphroot); PrintGraph(graphroot,0));
3289 //@node Aux fcts for packing, Printing Packet Contents, Unpacking routines, Graph packing
3290 //@subsection Aux fcts for packing
3295 //* Types of Global Addresses::
3299 //@node Offset table, Packet size, Aux fcts for packing, Aux fcts for packing
3300 //@subsubsection Offset table
3303 DonePacking is called when we've finished packing. It releases memory
3306 //@cindex DonePacking
3313 freeHashTable(offsetTable, NULL);
3318 AmPacking records that the closure is being packed. Note the abuse of
3319 the data field in the hash table -- this saves calling @malloc@! */
3325 StgClosure *closure;
3327 insertHashTable(offsetTable, (StgWord) closure, (void *) (StgWord) pack_locn);
3331 OffsetFor returns an offset for a closure which is already being packed. */
3337 StgClosure *closure;
3339 return (int) (StgWord) lookupHashTable(offsetTable, (StgWord) closure);
3343 NotYetPacking determines whether the closure's already being packed.
3344 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no. */
3346 //@cindex NotYetPacking
3349 NotYetPacking(offset)
3352 return(offset == 0); // ToDo: what if root is found again?? FIX
3364 NotYetPacking searches through the whole pack buffer for closure. */
3367 NotYetPacking(closure)
3368 StgClosure *closure;
3370 rtsBool found = rtsFalse;
3372 for (i=0; (i<pack_locn) && !found; i++)
3373 found = globalPackBuffer->buffer[i]==closure;
3379 //@node Packet size, Closure Info, Offset table, Aux fcts for packing
3380 //@subsubsection Packet size
3383 The size needed if all currently queued closures are packed as FETCH_ME
3384 closures. This represents the headroom we must have when packing the
3385 buffer in order to maintain all links in the graphs.
3387 // ToDo: check and merge cases
3390 QueuedClosuresMinSize (nat ptrs) {
3391 return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3395 QueuedClosuresMinSize (nat ptrs) {
3396 return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
3401 RoomToPack determines whether there's room to pack the closure into
3402 the pack buffer based on
3404 o how full the buffer is already,
3405 o the closures' size and number of pointers (which must be packed as GAs),
3406 o the size and number of pointers held by any primitive arrays that it
3409 It has a *side-effect* (naughty, naughty) in assigning roomInBuffer
3413 //@cindex RoomToPack
3415 RoomToPack(size, ptrs)
3420 (pack_locn + // where we are in the buffer right now
3421 size + // space needed for the current closure
3422 QueuedClosuresMinSize(ptrs) // space for queued closures as FETCH_MEs
3423 + 1 // headroom (DEBUGGING only)
3425 RTS_PACK_BUFFER_SIZE))
3427 roomInBuffer = rtsFalse;
3433 QueuedClosuresMinSize(ptrs)
3435 RTS_PACK_BUFFER_SIZE))
3437 roomInBuffer = rtsFalse;
3440 return (roomInBuffer);
3443 //@node Closure Info, , Packet size, Aux fcts for packing
3444 //@subsubsection Closure Info
3449 @get_closure_info@ determines the size, number of pointers etc. for this
3450 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
3452 [Can someone please keep this function up to date. I keep needing it
3453 (or something similar) for interpretive code, and it keeps
3454 bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95] */
3458 // {Parallel.h}Daq ngoqvam vIroQpu'
3460 # if defined(GRAN) || defined(PAR)
3461 /* extracting specific info out of closure; currently only used in GRAN -- HWL */
3462 //@cindex get_closure_info
3464 get_closure_info(node, size, ptrs, nonptrs, vhs, info_hdr_ty)
3466 nat *size, *ptrs, *nonptrs, *vhs;
3471 info = get_itbl(node);
3472 /* the switch shouldn't be necessary, really; just use default case */
3473 switch (info->type) {
3478 *size = sizeW_fromITBL(info);
3479 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3480 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3481 *vhs = (nat) 0; // unknown
3482 info_hdr_type(node, info_hdr_ty);
3488 *size = sizeW_fromITBL(info);
3489 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3490 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3491 *vhs = (nat) 0; // unknown
3492 info_hdr_type(node, info_hdr_ty);
3498 *size = sizeW_fromITBL(info);
3499 *ptrs = (nat) 2; // (info->layout.payload.ptrs);
3500 *nonptrs = (nat) 0; // (info->layout.payload.nptrs);
3501 *vhs = (nat) 0; // unknown
3502 info_hdr_type(node, info_hdr_ty);
3508 *size = sizeW_fromITBL(info);
3509 *ptrs = (nat) 1; // (info->layout.payload.ptrs);
3510 *nonptrs = (nat) 1; // (info->layout.payload.nptrs);
3511 *vhs = (nat) 0; // unknown
3512 info_hdr_type(node, info_hdr_ty);
3518 *size = sizeW_fromITBL(info);
3519 *ptrs = (nat) 0; // (info->layout.payload.ptrs);
3520 *nonptrs = (nat) 2; // (info->layout.payload.nptrs);
3521 *vhs = (nat) 0; // unknown
3522 info_hdr_type(node, info_hdr_ty);
3527 StgInfoTable *rip = REVERT_INFOPTR(info); // closure to revert to
3528 *size = sizeW_fromITBL(rip);
3529 *ptrs = (nat) (rip->layout.payload.ptrs);
3530 *nonptrs = (nat) (rip->layout.payload.nptrs);
3531 *vhs = (nat) 0; // unknown
3532 info_hdr_type(node, info_hdr_ty);
3533 return rip; // NB: we return the reverted info ptr for a RBH!!!!!!
3537 *size = sizeW_fromITBL(info);
3538 *ptrs = (nat) (info->layout.payload.ptrs);
3539 *nonptrs = (nat) (info->layout.payload.nptrs);
3540 *vhs = (nat) 0; // unknown
3541 info_hdr_type(node, info_hdr_ty);
3546 //@cindex IS_BLACK_HOLE
3548 IS_BLACK_HOLE(StgClosure* node)
3551 info = get_itbl(node);
3552 return ((info->type == BLACKHOLE || info->type == RBH) ? rtsTrue : rtsFalse);
3555 //@cindex IS_INDIRECTION
3557 IS_INDIRECTION(StgClosure* node)
3560 info = get_itbl(node);
3561 switch (info->type) {
3565 case IND_OLDGEN_PERM:
3567 /* relies on indirectee being at same place for all these closure types */
3568 return (((StgInd*)node) -> indirectee);
3576 IS_THUNK(StgClosure* node)
3579 info = get_itbl(node);
3580 return ((info->type == THUNK ||
3581 info->type == THUNK_STATIC ||
3582 info->type == THUNK_SELECTOR) ? rtsTrue : rtsFalse);
3593 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
3595 W_ *size, *ptrs, *nonptrs, *vhs;
3598 P_ ip = (P_) INFO_PTR(closure);
3600 if (closure==NULL) {
3601 fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
3602 *size = *ptrs = *nonptrs = *vhs = 0;
3603 strcpy(type,"ERROR in get_closure_info");
3605 } else if (closure==PrelBase_Z91Z93_closure) {
3606 /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
3607 *size = *ptrs = *nonptrs = *vhs = 0;
3608 strcpy(type,"PrelBase_Z91Z93_closure");
3612 ip = (P_) INFO_PTR(closure);
3614 switch (INFO_TYPE(ip)) {
3615 case INFO_SPEC_U_TYPE:
3616 case INFO_SPEC_S_TYPE:
3617 case INFO_SPEC_N_TYPE:
3618 *size = SPEC_CLOSURE_SIZE(closure);
3619 *ptrs = SPEC_CLOSURE_NoPTRS(closure);
3620 *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
3621 *vhs = 0 /*SPEC_VHS*/;
3622 strcpy(type,"SPEC");
3625 case INFO_GEN_U_TYPE:
3626 case INFO_GEN_S_TYPE:
3627 case INFO_GEN_N_TYPE:
3628 *size = GEN_CLOSURE_SIZE(closure);
3629 *ptrs = GEN_CLOSURE_NoPTRS(closure);
3630 *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
3636 *size = DYN_CLOSURE_SIZE(closure);
3637 *ptrs = DYN_CLOSURE_NoPTRS(closure);
3638 *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
3643 case INFO_TUPLE_TYPE:
3644 *size = TUPLE_CLOSURE_SIZE(closure);
3645 *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
3646 *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
3648 strcpy(type,"TUPLE");
3651 case INFO_DATA_TYPE:
3652 *size = DATA_CLOSURE_SIZE(closure);
3653 *ptrs = DATA_CLOSURE_NoPTRS(closure);
3654 *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
3656 strcpy(type,"DATA");
3659 case INFO_IMMUTUPLE_TYPE:
3660 case INFO_MUTUPLE_TYPE:
3661 *size = MUTUPLE_CLOSURE_SIZE(closure);
3662 *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
3663 *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
3665 strcpy(type,"(IM)MUTUPLE");
3668 case INFO_STATIC_TYPE:
3669 *size = STATIC_CLOSURE_SIZE(closure);
3670 *ptrs = STATIC_CLOSURE_NoPTRS(closure);
3671 *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
3673 strcpy(type,"STATIC");
3678 *size = IND_CLOSURE_SIZE(closure);
3679 *ptrs = IND_CLOSURE_NoPTRS(closure);
3680 *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
3682 strcpy(type,"CAF|IND");
3685 case INFO_CONST_TYPE:
3686 *size = CONST_CLOSURE_SIZE(closure);
3687 *ptrs = CONST_CLOSURE_NoPTRS(closure);
3688 *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
3690 strcpy(type,"CONST");
3693 case INFO_SPEC_RBH_TYPE:
3694 *size = SPEC_RBH_CLOSURE_SIZE(closure);
3695 *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
3696 *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
3698 *nonptrs -= (2 - *ptrs);
3702 *vhs = SPEC_RBH_VHS;
3703 strcpy(type,"SPEC_RBH");
3706 case INFO_GEN_RBH_TYPE:
3707 *size = GEN_RBH_CLOSURE_SIZE(closure);
3708 *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
3709 *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
3711 *nonptrs -= (2 - *ptrs);
3716 strcpy(type,"GEN_RBH");
3719 case INFO_CHARLIKE_TYPE:
3720 *size = CHARLIKE_CLOSURE_SIZE(closure);
3721 *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
3722 *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
3723 *vhs = CHARLIKE_VHS;
3724 strcpy(type,"CHARLIKE");
3727 case INFO_INTLIKE_TYPE:
3728 *size = INTLIKE_CLOSURE_SIZE(closure);
3729 *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
3730 *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
3732 strcpy(type,"INTLIKE");
3736 case INFO_FETCHME_TYPE:
3737 *size = FETCHME_CLOSURE_SIZE(closure);
3738 *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
3739 *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
3741 strcpy(type,"FETCHME");
3744 case INFO_FMBQ_TYPE:
3745 *size = FMBQ_CLOSURE_SIZE(closure);
3746 *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
3747 *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
3749 strcpy(type,"FMBQ");
3754 *size = BQ_CLOSURE_SIZE(closure);
3755 *ptrs = BQ_CLOSURE_NoPTRS(closure);
3756 *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
3762 *size = BH_CLOSURE_SIZE(closure);
3763 *ptrs = BH_CLOSURE_NoPTRS(closure);
3764 *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
3770 *size = 0; /* TSO_CLOSURE_SIZE(closure); */
3771 *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
3772 *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
3777 case INFO_STKO_TYPE:
3782 strcpy(type,"STKO");
3786 fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
3787 INFO_TYPE(ip), (StgWord) closure);
3796 // Use allocate in Storage.c instead
3798 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
3799 is available, but it will not perform garbage collection.
3800 ToDo: check whether we can use an existing STG allocation routine -- HWL
3804 //@cindex AllocateHeap
3811 /* Allocate a new closure */
3812 if (Hp + size > HpLim)
3815 newClosure = Hp + 1;
3824 //@cindex doGlobalGC
3828 fprintf(stderr,"Splat -- we just hit global GC!\n");
3829 stg_exit(EXIT_FAILURE);
3830 //fishing = rtsFalse;
3831 outstandingFishes--;
3836 //@node Printing Packet Contents, End of file, Aux fcts for packing, Graph packing
3837 //@subsection Printing Packet Contents
3839 Printing Packet Contents
3842 #if defined(DEBUG) || defined(GRAN_CHECK)
3844 //@cindex PrintPacket
3848 PrintPacket(packBuffer)
3849 rtsPackBuffer *packBuffer;
3851 StgClosure *parent, *graphroot, *closure_start;
3852 const StgInfoTable *ip;
3854 StgWord **bufptr, **slotptr;
3857 nat pptr = 0, pptrs = 0, pvhs;
3860 nat size, ptrs, nonptrs, vhs;
3863 /* disable printing if a non-std globalisation scheme is used; ToDo: FIX */
3864 if (RtsFlags.ParFlags.globalising != 0)
3867 /* NB: this whole routine is more or less a copy of UnpackGraph with all
3868 unpacking components replaced by printing fcts
3869 Long live higher-order fcts!
3871 /* Initialisation */
3872 //InitPackBuffer(); /* in case it isn't already init'd */
3874 // ASSERT(gaga==PendingGABuffer);
3875 graphroot = (StgClosure *)NULL;
3877 /* Unpack the header */
3878 bufsize = packBuffer->size;
3879 bufptr = packBuffer->buffer;
3881 fprintf(stderr, "*. Printing <<%d>> (buffer @ %p):\n",
3882 packBuffer->id, packBuffer);
3883 fprintf(stderr, "*. size: %d; unpacked_size: %d; tso: %p; buffer: %p\n",
3884 packBuffer->size, packBuffer->unpacked_size,
3885 packBuffer->tso, packBuffer->buffer);
3887 parent = (StgClosure *)NULL;
3890 /* This is where we will ultimately save the closure's address */
3892 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
3894 /* First, unpack the next GA or PLC */
3895 ga.weight = (rtsWeight) *bufptr++;
3897 if (ga.weight == 2) { // unglobalised closure to follow
3898 // nothing to do; closure starts at *bufptr
3899 } else if (ga.weight > 0) { // fill in GA
3900 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
3901 ga.payload.gc.slot = (int) *bufptr++;
3903 ga.payload.plc = (StgPtr) *bufptr++;
3905 /* Now unpack the closure body, if there is one */
3907 fprintf(stderr, "*. %u: PLC @ %p\n", locn, ga.payload.plc);
3908 // closure = ga.payload.plc;
3909 } else if (isOffset(&ga)) {
3910 fprintf(stderr, "*. %u: OFFSET TO %d\n", locn, ga.payload.gc.slot);
3911 // closure = (StgClosure *) buffer[ga.payload.gc.slot];
3913 /* Print normal closures */
3915 ASSERT(bufsize > 0);
3917 fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
3918 ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
3920 closure_start = (StgClosure*)bufptr;
3921 ip = get_closure_info((StgClosure *)bufptr,
3922 &size, &ptrs, &nonptrs, &vhs, str);
3924 /* ToDo: check whether this is really needed */
3925 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
3927 ptrs = nonptrs = vhs = 0;
3929 /* ToDo: check whether this is really needed */
3930 if (ip->type == ARR_WORDS) {
3932 nonptrs = ((StgArrWords *)bufptr)->words;
3933 size = arr_words_sizeW((StgArrWords *)bufptr);
3936 /* special code for printing a PAP in a buffer */
3937 if (ip->type == PAP || ip->type == AP_UPD) {
3940 nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
3941 size = _HS+vhs+ptrs+nonptrs;
3945 Remember, the generic closure layout is as follows:
3946 +-------------------------------------------------+
3947 | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS |
3948 +-------------------------------------------------+
3950 /* Print fixed header */
3951 fprintf(stderr, "FH [");
3952 for (i = 0; i < _HS; i++)
3953 fprintf(stderr, " %p", *bufptr++);
3955 if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
3956 size = ptrs = nonptrs = vhs = 0;
3958 // VH is always empty in the new RTS
3960 ip->type == PAP || ip->type == AP_UPD);
3961 /* Print variable header */
3962 fprintf(stderr, "] VH [");
3963 for (i = 0; i < vhs; i++)
3964 fprintf(stderr, " %p", *bufptr++);
3966 //fprintf(stderr, "] %d PTRS [", ptrs);
3967 /* Pointers will be filled in later */
3969 fprintf(stderr, " ] (%d, %d) [", ptrs, nonptrs);
3970 /* Print non-pointers */
3971 for (i = 0; i < nonptrs; i++)
3972 fprintf(stderr, " %p", *bufptr++);
3974 fprintf(stderr, "] (%s)\n", str);
3976 /* Indirections are never packed */
3977 // ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
3979 /* Add to queue for processing
3980 When just printing the packet we do not have an unpacked closure
3981 in hand, so we feed it the packet entry;
3982 again, this assumes that at least the fixed header of the closure
3983 has the same layout in the packet; also we may not overwrite entries
3984 in the packet (done in Unpack), but for printing that's a bad idea
3986 QueueClosure((StgClosure *)closure_start);
3988 /* No Common up needed for printing */
3990 /* No Sort out the global address mapping for printing */
3992 } /* normal closure case */
3994 /* Locate next parent pointer */
3996 while (pptr + 1 > pptrs) {
3997 parent = DeQueueClosure();
4002 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4007 } while (parent != NULL);
4008 fprintf(stderr, "*. --- End packet <<%d>> (claimed size=%d; real size=%d)---\n",
4009 packBuffer->id, packBuffer->size, size);
4014 Doing a sanity check on a packet.
4015 This does a full iteration over the packet, as in PrintPacket.
4017 //@cindex checkPacket
4019 checkPacket(packBuffer)
4020 rtsPackBuffer *packBuffer;
4022 StgClosure *parent, *graphroot, *closure_start;
4023 const StgInfoTable *ip;
4025 StgWord **bufptr, **slotptr;
4028 nat pptr = 0, pptrs = 0, pvhs;
4030 nat size, ptrs, nonptrs, vhs;
4033 /* NB: this whole routine is more or less a copy of UnpackGraph with all
4034 unpacking components replaced by printing fcts
4035 Long live higher-order fcts!
4037 /* Initialisation */
4038 //InitPackBuffer(); /* in case it isn't already init'd */
4040 // ASSERT(gaga==PendingGABuffer);
4041 graphroot = (StgClosure *)NULL;
4043 /* Unpack the header */
4044 bufsize = packBuffer->size;
4045 bufptr = packBuffer->buffer;
4046 parent = (StgClosure *)NULL;
4047 ASSERT(bufsize > 0);
4049 /* check that we are not at the end of the buffer, yet */
4050 IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
4052 /* This is where we will ultimately save the closure's address */
4054 locn = slotptr-(packBuffer->buffer); // index of closure in buffer
4055 ASSERT(locn<=bufsize);
4057 /* First, check whether we have a GA, a PLC, or an OFFSET at hand */
4058 ga.weight = (rtsWeight) *bufptr++;
4060 if (ga.weight == 2) { // unglobalised closure to follow
4061 // nothing to do; closure starts at *bufptr
4062 } else if (ga.weight > 0) { // fill in GA
4063 ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
4064 ga.payload.gc.slot = (int) *bufptr++;
4066 ga.payload.plc = (StgPtr) *bufptr++;
4068 /* Now unpack the closure body, if there is one */
4071 ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
4072 } else if (isOffset(&ga)) {
4073 ASSERT(ga.payload.gc.slot<=(int)bufsize);
4075 /* normal closure */
4076 ASSERT(!RtsFlags.ParFlags.globalising==0 || LOOKS_LIKE_GA(&ga));
4078 closure_start = (StgClosure*)bufptr;
4079 ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
4080 ip = get_closure_info((StgClosure *)bufptr,
4081 &size, &ptrs, &nonptrs, &vhs, str);
4083 /* ToDo: check whether this is really needed */
4084 if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
4086 ptrs = nonptrs = vhs = 0;
4088 /* ToDo: check whether this is really needed */
4089 if (ip->type == ARR_WORDS) {
4091 nonptrs = ((StgArrWords *)bufptr)->words+1; // payload+words
4092 size = arr_words_sizeW((StgArrWords *)bufptr);
4093 ASSERT(size==_HS+vhs+nonptrs);
4095 /* special code for printing a PAP in a buffer */
4096 if (ip->type == PAP || ip->type == AP_UPD) {
4099 nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
4100 size = _HS+vhs+ptrs+nonptrs;
4103 /* no checks on contents of closure (pointers aren't packed anyway) */
4104 ASSERT(_HS+vhs+nonptrs>=MIN_NONUPD_SIZE);
4105 bufptr += _HS+vhs+nonptrs;
4107 /* Add to queue for processing */
4108 QueueClosure((StgClosure *)closure_start);
4110 /* No Common up needed for checking */
4112 /* No Sort out the global address mapping for checking */
4114 } /* normal closure case */
4116 /* Locate next parent pointer */
4118 while (pptr + 1 > pptrs) {
4119 parent = DeQueueClosure();
4124 //ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*parent));
4125 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
4130 } while (parent != NULL);
4131 /* we unpacked exactly as many words as there are in the buffer */
4132 ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
4133 /* check for magic end-of-buffer word */
4134 IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
4139 rtsPackBuffer *buffer;
4141 // extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
4142 // extern char *display_info_type(P_ infoptr); /* defined in Threads.lc */
4145 nat size, ptrs, nonptrs, vhs;
4146 char info_hdr_ty[80];
4147 char str1[80], str2[80], junk_str[80];
4149 /* globalAddr ga; */
4151 nat bufsize, unpacked_size ;
4153 nat pptr = 0, pptrs = 0, pvhs;
4155 nat unpack_locn = 0;
4156 nat gastart = unpack_locn;
4157 nat closurestart = unpack_locn;
4160 StgClosure *closure, *p;
4164 fprintf(stderr, "*** Printing <<%d>> (buffer @ %p):\n", buffer->id, buffer);
4165 fprintf(stderr, " size: %d; unpacked_size: %d; tso: %d (%p); buffer: %p\n",
4166 buffer->size, buffer->unpacked_size, buffer->tso, buffer->buffer);
4167 fputs(" contents: ", stderr);
4168 for (unpack_locn=0; unpack_locn<buffer->size; unpack_locn++) {
4169 closure = buffer->buffer[unpack_locn];
4170 fprintf(stderr, ", %p (%s)",
4171 closure, info_type(closure));
4173 fputc('\n', stderr);
4176 /* traverse all elements of the graph; omitted for now, but might be usefule */
4181 /* Unpack the header */
4182 unpacked_size = buffer->unpacked_size;
4183 bufsize = buffer->size;
4185 fprintf(stderr, "Packet %p, size %u (unpacked size is %u); demanded by TSO %d (%p)[PE %d]\n--- Begin ---\n",
4186 buffer, bufsize, unpacked_size,
4187 tso->id, tso, where_is((StgClosure*)tso));
4190 closurestart = unpack_locn;
4191 closure = buffer->buffer[unpack_locn++];
4193 fprintf(stderr, "[%u]: (%p) ", closurestart, closure);
4195 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str1);
4197 fprintf(stderr, "(%s|%s) ", str1, str2);
4199 if (info->type == FETCH_ME || info->type == FETCH_ME_BQ ||
4200 IS_BLACK_HOLE(closure))
4201 size = ptrs = nonptrs = vhs = 0;
4203 if (closure_THUNK(closure)) {
4204 if (closure_UNPOINTED(closure))
4205 fputs("UNPOINTED ", stderr);
4207 fputs("POINTED ", stderr);
4209 if (IS_BLACK_HOLE(closure)) {
4210 fputs("BLACK HOLE\n", stderr);
4213 fprintf(stderr, "FH [");
4214 for (i = 0, p = (StgClosure*)&(closure->header); i < _HS; i++, p++)
4215 fprintf(stderr, " %p", *p);
4219 fprintf(stderr, "] VH [%p", closure->payload[_HS]);
4221 for (i = 1; i < vhs; i++)
4222 fprintf(stderr, " %p", closure->payload[_HS+i]);
4225 fprintf(stderr, "] PTRS %u", ptrs);
4229 fprintf(stderr, " NPTRS [%p", closure->payload[_HS+vhs]);
4231 for (i = 1; i < nonptrs; i++)
4232 fprintf(stderr, " %p", closure->payload[_HS+vhs+i]);
4238 } while (unpack_locn<bufsize) ; /* (parent != NULL); */
4240 fprintf(stderr, "--- End ---\n\n");
4244 #endif /* DEBUG || GRAN_CHECK */
4246 #endif /* PAR || GRAN -- whole file */
4248 //@node End of file, , Printing Packet Contents, Graph packing
4249 //@subsection End of file
4252 //* AllocateHeap:: @cindex\s-+AllocateHeap
4253 //* AmPacking:: @cindex\s-+AmPacking
4254 //* CommonUp:: @cindex\s-+CommonUp
4255 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
4256 //* DeQueueClosure:: @cindex\s-+DeQueueClosure
4257 //* DonePacking:: @cindex\s-+DonePacking
4258 //* FillInClosure:: @cindex\s-+FillInClosure
4259 //* IS_BLACK_HOLE:: @cindex\s-+IS_BLACK_HOLE
4260 //* IS_INDIRECTION:: @cindex\s-+IS_INDIRECTION
4261 //* InitClosureQueue:: @cindex\s-+InitClosureQueue
4262 //* InitPendingGABuffer:: @cindex\s-+InitPendingGABuffer
4263 //* LocateNextParent:: @cindex\s-+LocateNextParent
4264 //* NotYetPacking:: @cindex\s-+NotYetPacking
4265 //* OffsetFor:: @cindex\s-+OffsetFor
4266 //* Pack:: @cindex\s-+Pack
4267 //* PackArray:: @cindex\s-+PackArray
4268 //* PackClosure:: @cindex\s-+PackClosure
4269 //* PackFetchMe:: @cindex\s-+PackFetchMe
4270 //* PackGeneric:: @cindex\s-+PackGeneric
4271 //* PackNearbyGraph:: @cindex\s-+PackNearbyGraph
4272 //* PackOneNode:: @cindex\s-+PackOneNode
4273 //* PackPAP:: @cindex\s-+PackPAP
4274 //* PackPLC:: @cindex\s-+PackPLC
4275 //* PackStkO:: @cindex\s-+PackStkO
4276 //* PackTSO:: @cindex\s-+PackTSO
4277 //* PendingGABuffer:: @cindex\s-+PendingGABuffer
4278 //* PrintPacket:: @cindex\s-+PrintPacket
4279 //* QueueClosure:: @cindex\s-+QueueClosure
4280 //* QueueEmpty:: @cindex\s-+QueueEmpty
4281 //* RoomToPack:: @cindex\s-+RoomToPack
4282 //* SetGAandCommonUp:: @cindex\s-+SetGAandCommonUp
4283 //* UnpackGA:: @cindex\s-+UnpackGA
4284 //* UnpackGraph:: @cindex\s-+UnpackGraph
4285 //* UnpackOffset:: @cindex\s-+UnpackOffset
4286 //* UnpackPLC:: @cindex\s-+UnpackPLC
4287 //* doGlobalGC:: @cindex\s-+doGlobalGC
4288 //* get_closure_info:: @cindex\s-+get_closure_info
4289 //* InitPackBuffer:: @cindex\s-+initPackBuffer
4290 //* isFixed:: @cindex\s-+isFixed
4291 //* isOffset:: @cindex\s-+isOffset
4292 //* offsetTable:: @cindex\s-+offsetTable