2 % (c) The Parade/AQUA Projects, Glasgow University, 1995
3 % Kevin Hammond, February 15th. 1995
5 % This is for GUM and for GrAnSim.
7 %************************************************************************
9 \section[Pack.lc]{Packing closures for export to remote processors}
11 %************************************************************************
13 This module defines routines for packing closures in the parallel runtime
16 The GrAnSim version of the code defines routines for *simulating* the
17 packing of closures in the same way it
18 is done in the parallel runtime system. Basically GrAnSim only puts the
19 addresses of the closures to be transferred into a buffer. This buffer will
20 then be associated with the event of transferring the graph. When this
21 event is scheduled, the @UnpackGraph@ routine is called and the buffer
22 can be discarded afterwards.
24 Note that in GrAnSim we need many buffers, not just one per PE.
27 #if defined(PAR) || defined(GRAN) /* whole file */
31 /* Which RTS flag should be used to get the size of the pack buffer ? */
33 #define PACK_BUFFER_SIZE RTSflags.ParFlags.packBufferSize
35 #define PACK_BUFFER_SIZE RTSflags.GranFlags.packBufferSize
39 Static data and code declarations.
43 /* To be pedantic: in GrAnSim we're packing *addresses* of closures,
44 not the closures themselves.
46 static P_ *PackBuffer = NULL; /* size: can be set via option */
48 static W_ *PackBuffer = NULL; /* size: can be set via option */
51 static W_ packlocn, clqsize, clqpos;
52 static W_ unpackedsize;
53 static W_ reservedPAsize; /*Space reserved for primitive arrays*/
54 static rtsBool RoomInBuffer;
57 static void InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
59 static rtsBool NotYetPacking PROTO((P_ closure));
60 static void Pack PROTO((P_ data));
62 static rtsBool NotYetPacking PROTO((int offset));
63 static void Pack PROTO((W_ data));
65 static rtsBool RoomToPack PROTO((W_ size, W_ ptrs));
66 static void AmPacking PROTO((P_ closure));
68 static void PackClosure PROTO((P_ closure))
70 , PackPLC PROTO((P_ addr))
71 , PackOffset PROTO((int offset))
72 , GlobaliseAndPackGA PROTO((P_ closure))
76 static int OffsetFor PROTO((P_ closure));
79 Bit of a hack for testing if a closure is the root of the graph. This is
80 set in @PackNearbyGraph@ and tested in @PackClosure@.
89 %************************************************************************
91 \subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
93 %************************************************************************
95 @PackNearbyGraph@ packs a closure and associated graph into a static
96 buffer (@PackBuffer@). It returns the address of this buffer and the
97 size of the data packed into the buffer (in its second parameter,
98 @packbuffersize@). The associated graph is packed in a depth first
99 manner, hence it uses an explicit queue of closures to be packed
100 rather than simply using a recursive algorithm. Once the packet is
101 full, closures (other than primitive arrays) are packed as FetchMes,
102 and their children are not queued for packing.
107 PackNearbyGraph(closure, packbuffersize)
112 PackNearbyGraph(closure, tso, packbuffersize)
118 /* Ensure enough heap for all possible RBH_Save closures */
120 ASSERT(PACK_BUFFER_SIZE > 0);
122 # if defined(GRAN) && defined(GRAN_CHECK)
123 if ( RTSflags.GranFlags.debug & 0x100 )
124 fprintf(stderr,"Packing graph with root at 0x%lx (PE %d); demanded by TSO %#lx (%d) (PE %d) ...\n",
125 closure, where_is(closure), tso, TSO_ID(tso), where_is(tso) );
128 if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
136 QueueClosure(closure);
138 PackClosure(DeQueueClosure());
139 } while (!QueueEmpty());
142 /* Record how much space is needed to unpack the graph */
143 PackBuffer[0] = unpackedsize;
145 /* Record how much space is needed to unpack the graph */
146 PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
147 PackBuffer[PACK_TSO_LOCN] = tso;
148 PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
151 /* Set the size parameter */
153 ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
154 *packbuffersize = packlocn;
156 ASSERT(packlocn <= PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
157 /* ToDo: Print an earlier, more meaningful message */
158 if (packlocn==PACK_HDR_SIZE) { /* i.e. packet is empty */
159 fprintf(stderr,"EMPTY PACKET! Can't transfer closure %#lx at all!!\n",
163 PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
164 *packbuffersize = packlocn;
168 DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
171 # if defined(GRAN) && defined(GRAN_CHECK)
173 tot_packet_size += packlocn-PACK_HDR_SIZE ;
175 if ( RTSflags.GranFlags.debug & 0x100 ) {
176 PrintPacket((P_)PackBuffer);
180 return ((P_)PackBuffer);
184 /* This version is used when the node is already local */
187 PackOneNode(closure, tso, packbuffersize)
196 # if defined(GRAN) && defined(GRAN_CHECK)
197 if ( RTSflags.GranFlags.debug & 0x100 ) {
198 W_ size, ptrs, nonptrs, vhs;
200 char str[80], junk_str[80];
202 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
203 fprintf(stderr,"PackOneNode: %#lx (%s)(PE %#lx) requested by TSO %#lx (%d) (PE %#lx)\n",
204 closure, str, where_is(closure), tso, TSO_ID(tso), where_is(tso));
210 /* Record how much space is needed to unpack the graph */
211 PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
212 PackBuffer[PACK_TSO_LOCN] = tso;
213 PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
215 /* Set the size parameter */
216 ASSERT(packlocn <= PACK_BUFFER_SIZE);
217 PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
218 *packbuffersize = packlocn;
220 # if defined(GRAN) && defined(GRAN_CHECK)
222 tot_packet_size += packlocn-PACK_HDR_SIZE ;
224 if ( RTSflags.GranFlags.debug & 0x100 ) {
225 PrintPacket(PackBuffer);
229 return ((P_)PackBuffer);
234 @PackTSO@ and @PackStkO@ are entry points for two special kinds of
235 closure which are used in the parallel RTS. Compared with other
236 closures they are rather awkward to pack because they don't follow the
237 normal closure layout (where all pointers occur before all non-pointers).
238 Luckily, they're only needed when migrating threads between processors.
246 PackTSO(tso,packbuffersize)
251 PackBuffer[0] = PackBuffer[1] = 0;
260 PackStkO(stko,packbuffersize)
265 PackBuffer[0] = PackBuffer[1] = 0;
271 %************************************************************************
273 \subsection[PackClosure]{Packing Closures}
275 %************************************************************************
277 @PackClosure@ is the heart of the normal packing code. It packs a
278 single closure into the pack buffer, skipping over any indirections
279 and globalising it as necessary, queues any child pointers for further
280 packing, and turns it into a @FetchMe@ or revertible black hole
281 (@RBH@) locally if it was a thunk. Before the actual closure is
282 packed, a suitable global address (GA) is inserted in the pack buffer.
283 There is always room to pack a fetch-me to the closure (guaranteed by
284 the RoomToPack calculation), and this is packed if there is no room
285 for the entire closure.
287 Space is allocated for any primitive array children of a closure, and
288 hence a primitive array can always be packed along with it's parent
298 W_ size, ptrs, nonptrs, vhs;
302 while (IS_INDIRECTION(INFO_PTR(closure))) {
303 /* Don't pack indirection closures */
305 fprintf(stderr, "Shorted an indirection at %x", closure);
307 closure = (P_) IND_CLOSURE_PTR(closure);
310 clpacklocn = OffsetFor(closure);
312 /* If the closure's not already being packed */
313 if (NotYetPacking(clpacklocn)) {
317 * PLCs reside on all of the PEs already. Just pack the
318 * address as a GA (a bit of a kludge, since an address may
319 * not fit in *any* of the individual GA fields). Const,
320 * charlike and small intlike closures are converted into
323 switch (INFO_TYPE(INFO_PTR(closure))) {
325 case INFO_CHARLIKE_TYPE:
327 fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
329 PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
332 case INFO_CONST_TYPE:
334 fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
336 PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
339 case INFO_STATIC_TYPE:
340 case INFO_CAF_TYPE: /* For now we ship indirections to CAFs: They are
341 * evaluated on each PE if needed */
343 fprintf(stderr, "Packing a PLC %x\n", closure);
348 case INFO_INTLIKE_TYPE:
350 I_ val = INTLIKE_VALUE(closure);
352 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
354 fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
356 PackPLC(INTLIKE_CLOSURE(val));
360 fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
367 fprintf(stderr, "Not a PLC: ");
371 /* Otherwise it's not Fixed */
373 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
375 if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
376 size = ptrs = nonptrs = vhs = 0;
379 * Now peek ahead to see whether the closure has any primitive array
382 for (i = 0; i < ptrs; ++i) {
384 W_ childSize, childPtrs, childNonPtrs, childVhs;
386 childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
387 &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
388 if (IS_BIG_MOTHER(childInfo)) {
389 reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
390 + childPtrs * PACK_FETCHME_SIZE;
394 /* Record the location of the GA */
397 /* Pack the global address */
398 GlobaliseAndPackGA(closure);
401 * Pack a fetchme to the closure if it's a black hole, or the buffer is full
402 * and it isn't a primitive array. N.B. Primitive arrays are always packed
403 * (because their parents index into them directly)
406 if (IS_BLACK_HOLE(info) ||
407 !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
408 || IS_BIG_MOTHER(info))) {
410 ASSERT(packlocn > PACK_HDR_SIZE);
412 /* Just pack as a FetchMe */
414 for (i = 0; i < FIXED_HS; ++i) {
415 if (i == INFO_HDR_POSN)
416 Pack((W_) FetchMe_info);
421 unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(dummy);
424 /* At last! A closure we can actually pack! */
426 if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
427 fprintf(stderr, "Warning: Replicated a Mutable closure!\n");
429 for (i = 0; i < FIXED_HS + vhs; ++i)
432 for (i = 0; i < ptrs; ++i)
433 QueueClosure(((PP_) (closure))[i + FIXED_HS + vhs]);
435 for (i = 0; i < nonptrs; ++i)
436 Pack(closure[i + FIXED_HS + vhs + ptrs]);
438 unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ? MIN_UPD_SIZE : size);
441 * Record that this is a revertable black hole so that we can fill in
442 * its address from the fetch reply. Problem: unshared thunks may cause
443 * space leaks this way, their GAs should be deallocated following an
447 if (IS_THUNK(info) && IS_UPDATABLE(info)) {
453 convertToRBH(closure);
459 /* Pack an indirection to the original closure! */
461 PackOffset(clpacklocn);
466 /* Fake the packing of a closure */
472 W_ size, ptrs, nonptrs, vhs;
473 W_ childSize, childPtrs, junk; /*size, no. ptrs etc. of a child closure*/
477 W_ PAsize = 0; /*total size + no. ptrs of all child prim arrays*/
479 char str[80], junk_str[80];
480 rtsBool will_be_rbh, no_more_thunks_please;
482 /* In GranSim we don't pack and unpack closures -- we just simulate */
483 /* that by updating the bitmask. So, the graph structure is unchanged */
484 /* i.e. we don't short out indirections here. -- HWL */
486 if (where_is(closure) != where_is(graphroot)) {
487 /* GUM would pack a FETCHME here; simulate that by increasing the */
488 /* unpacked size accordingly but don't pack anything -- HWL */
489 unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(closure);
492 /* clpacklocn = OffsetFor(closure); */
494 /* If the closure's not already being packed */
495 if (NotYetPacking(closure)) {
496 switch (INFO_TYPE(INFO_PTR(closure))) {
497 case INFO_SPEC_RBH_TYPE:
498 case INFO_GEN_RBH_TYPE:
499 # if defined(GRAN) && defined(GRAN_CHECK)
500 if ( RTSflags.GranFlags.debug & 0x100 ) {
501 fprintf(stderr,"************ Avoid packing RBH @ %#lx!\n", closure);
504 /* Just ignore RBHs i.e. they stay where they are */
507 case INFO_CHARLIKE_TYPE:
508 case INFO_CONST_TYPE:
509 case INFO_STATIC_TYPE:
510 case INFO_CAF_TYPE: /* For now we ship indirections to CAFs:
511 * They are evaluated on each PE if needed */
515 case INFO_INTLIKE_TYPE:
517 I_ val = INTLIKE_VALUE(closure);
518 if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
526 /* Just fall through to the rest of the function */
529 /* Otherwise it's not Fixed */
531 info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
532 will_be_rbh = IS_THUNK(info) && IS_UPDATABLE(info);
533 no_more_thunks_please =
534 (RTSflags.GranFlags.ThunksToPack>0) &&
535 (packed_thunks>=RTSflags.GranFlags.ThunksToPack);
537 if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
538 size = ptrs = nonptrs = vhs = 0;
540 /* Now peek ahead to see whether the closure has any primitive */
542 for (i = 0; i < ptrs; ++i) {
544 W_ childSize, childPtrs, childNonPtrs, childVhs;
546 childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
547 &childSize, &childPtrs, &childNonPtrs,
548 &childVhs, junk_str);
549 if (IS_BIG_MOTHER(childInfo)) {
550 reservedPAsize += PACK_GA_SIZE + FIXED_HS +
551 childVhs + childNonPtrs +
552 childPtrs * PACK_FETCHME_SIZE;
553 PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
558 /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
559 * is full and it isn't a primitive array. N.B. Primitive arrays are
560 * always packed (because their parents index into them directly) */
562 if (IS_BLACK_HOLE(info) ||
563 !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
564 || IS_BIG_MOTHER(info)))
567 /* At last! A closure we can actually pack! */
569 if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
570 fprintf(stderr,"Warning: Replicated a Mutable closure!");
572 # if defined(GRAN) && defined(GRAN_CHECK)
573 if (no_more_thunks_please && will_be_rbh) {
575 if ( RTSflags.GranFlags.debug & 0x100 )
576 fprintf(stderr,"PackClosure (w/ RTSflags.GranFlags.ThunksToPack=%d): Cutting tree with root at %#lx\n",
577 RTSflags.GranFlags.ThunksToPack, closure);
578 } else if (will_be_rbh || (closure==graphroot) ) {
583 if (!(no_more_thunks_please && will_be_rbh)) {
584 Pack(closure); /* actual PACKING done here -- HWL */
585 for (i = 0; i < ptrs; ++i)
586 QueueClosure(((StgPtrPtr) (closure))[i + FIXED_HS + vhs]);
588 /* Turn thunk into a revertible black hole. */
593 # if defined(GRAN) && defined(GRAN_CHECK)
594 if ( RTSflags.GranFlags.debug & 0x100 ) {
595 fprintf(stderr,"> RBHing the following closure:\n (%#lx) ",
597 G_PPN(closure); /* see StgDebug */
600 rbh = convertToRBH(closure);
605 else /* !NotYetPacking(clpacklocn) */
606 /* Don't have to do anything in GrAnSim if closure is already */
609 # if defined(GRAN) && defined(GRAN_CHECK)
610 if ( RTSflags.GranFlags.debug & 0x100 )
611 fprintf(stderr,"*** Closure %#lx is already packed and omitted now!\n",
619 %************************************************************************
621 \subsection[simple-pack-routines]{Simple Packing Routines}
623 %************************************************************************
625 About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
626 gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
627 words. In the simulated PackBuffer we only keep the addresses of the
628 closures that would be packed in the parallel system (see Pack). To decide
629 if a packet overflow occurs pack_buffer_size must be compared versus
630 unpackedsize (see RoomToPack). Currently, there is no multi packet
631 strategy implemented, so in the case of an overflow we just stop adding
632 closures to the closure queue. If an overflow of the simulated packet
633 occurs, we just realloc some more space for it and carry on as usual.
639 InstantiatePackBuffer () {
642 /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
643 (P_ *) stgMallocWords(RTSflags.GranFlags.packBufferSize_internal+PACK_HDR_SIZE,
644 "InstantiatePackBuffer") ;
646 PackBuffer[PACK_SIZE_LOCN] = (P_)RTSflags.GranFlags.packBufferSize_internal;
653 @Pack@ is the basic packing routine. It just writes a word of
654 data into the pack buffer and increments the pack location.
662 ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
663 PackBuffer[packlocn++] = data;
670 W_ size, ptrs, nonptrs, vhs;
674 /* This checks the size of the GrAnSim internal pack buffer. The simulated
675 pack buffer is checked via RoomToPack (as in GUM) */
676 if (packlocn >= (int)PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE) {
678 # if defined(GRAN_CHECK)
679 if ( RTSflags.GranFlags.debug & 0x8000 ) {
680 fprintf(stderr, "Increasing size of PackBuffer %#lx to %d words (PE %u @ %d)\n",
681 PackBuffer, PackBuffer[PACK_SIZE_LOCN]+REALLOC_SZ,
682 CurrentProc, CurrentTime[CurrentProc]);
685 PackBuffer = (P_ *) realloc(PackBuffer,
686 sizeof(P_)*(REALLOC_SZ +
687 (int)PackBuffer[PACK_SIZE_LOCN] +
689 if (PackBuffer == NULL) {
690 fprintf(stderr,"Failing to realloc %d more words for PackBuffer %#lx (PE %u @ %d)\n",
691 REALLOC_SZ, PackBuffer, CurrentProc, CurrentTime[CurrentProc]);
694 PackBuffer[PACK_SIZE_LOCN] += REALLOC_SZ;
697 ASSERT(packlocn < PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
700 fprintf(stderr,"Qagh {Pack}Daq: Trying to pack 0\n");
701 PackBuffer[packlocn++] = addr;
702 /* ASSERT: Data is a closure in GrAnSim here */
703 info = get_closure_info(addr, &size, &ptrs, &nonptrs, &vhs, str);
704 unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ?
711 If a closure is local, make it global. Then, divide its weight for export.
712 The GA is then packed into the pack buffer.
718 GlobaliseAndPackGA(closure)
724 if ((ga = LAGAlookup(closure)) == NULL)
725 ga = MakeGlobal(closure, rtsTrue);
726 splitWeight(&packGA, ga);
727 ASSERT(packGA.weight > 0);
730 fprintf(stderr, "Packing (%x, %d, %x)\n",
731 packGA.loc.gc.gtid, packGA.loc.gc.slot, packGA.weight);
733 Pack((W_) packGA.weight);
734 Pack((W_) packGA.loc.gc.gtid);
735 Pack((W_) packGA.loc.gc.slot);
739 @PackPLC@ makes up a bogus GA for a PLC. Weight 0 implies that a PLC
740 address follows instead of PE, slot.
747 Pack(0L); /* weight */
748 Pack((W_) addr); /* address */
752 @PackOffset@ packs a special GA value that will be interpreted as
753 an offset to a closure in the pack buffer. This is used to avoid
754 unfolding the graph structure into a tree.
762 fprintf(stderr,"Packing Offset %d at pack location %u\n",offset,packlocn);
764 Pack(1L); /* weight */
766 Pack(offset); /* slot/offset */
771 %************************************************************************
773 \subsection[pack-offsets]{Offsets into the Pack Buffer}
775 %************************************************************************
777 The offset hash table is used during packing to record the location in
778 the pack buffer of each closure which is packed.
782 static HashTable *offsettable;
785 @InitPacking@ initialises the packing buffer etc.
789 InitPackBuffer(STG_NO_ARGS)
791 if (PackBuffer == NULL) { /* not yet allocated */
793 PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
796 InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
797 AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
803 InitPacking(STG_NO_ARGS)
806 PackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
807 /* NB: free in UnpackGraph */
810 packlocn = PACK_HDR_SIZE;
813 RoomInBuffer = rtsTrue;
816 offsettable = allocHashTable();
823 @DonePacking@ is called when we've finished packing. It releases memory
830 DonePacking(STG_NO_ARGS)
832 freeHashTable(offsettable,NULL);
837 @AmPacking@ records that the closure is being packed. Note the abuse
838 of the data field in the hash table -- this saves calling @malloc@!
846 fprintf(stderr, "Packing %#lx (IP %#lx) at %u\n",
847 closure, INFO_PTR(closure), packlocn);
849 insertHashTable(offsettable, (W_) closure, (void *) (W_) packlocn);
853 @OffsetFor@ returns an offset for a closure which is already being
858 OffsetFor(P_ closure)
860 return (int) (W_) lookupHashTable(offsettable, (W_) closure);
864 @NotYetPacking@ determines whether the closure's already being packed.
865 Offsets $<$ @PACK_HDR_SIZE@ (e.g. 0) mean no.
869 NotYetPacking(offset)
872 return(offset < PACK_HDR_SIZE);
878 NotYetPacking(closure)
881 rtsBool found = rtsFalse;
883 for (i=PACK_HDR_SIZE; (i<packlocn) && !found; i++)
884 found = PackBuffer[i]==closure;
891 @RoomToPack@ determines whether there's room to pack the closure into
892 the pack buffer based on
894 o how full the buffer is already,
895 o the closures' size and number of pointers (which must be packed as GAs),
896 o the size and number of pointers held by any primitive arrays that it points to
898 It has a *side-effect* in assigning RoomInBuffer to False.
902 RoomToPack(size, ptrs)
907 (packlocn + reservedPAsize + size +
908 ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
911 fprintf(stderr, "Buffer full\n");
913 RoomInBuffer = rtsFalse;
917 (unpackedsize + reservedPAsize + size +
918 ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
920 #if defined(GRAN_CHECK)
921 if ( RTSflags.GranFlags.debug & 0x100 )
922 fprintf(stderr, "Buffer full\n");
924 RoomInBuffer = rtsFalse;
927 return (RoomInBuffer);
931 %************************************************************************
933 \subsection[pack-closure-queue]{Closure Queues}
935 %************************************************************************
937 These routines manage the closure queue.
940 static W_ clqpos, clqsize;
942 static P_ *ClosureQueue = NULL; /* HWL: init in main */
945 @InitClosureQueue@ initialises the closure queue.
949 AllocClosureQueue(size)
952 ASSERT(ClosureQueue == NULL);
953 ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
957 InitClosureQueue(STG_NO_ARGS)
959 clqpos = clqsize = 0;
961 if ( ClosureQueue == NULL )
962 AllocClosureQueue(PACK_BUFFER_SIZE);
966 @QueueEmpty@ returns @rtsTrue@ if the closure queue is empty;
967 @rtsFalse@ otherwise.
971 QueueEmpty(STG_NO_ARGS)
973 return(clqpos >= clqsize);
977 @QueueClosure@ adds its argument to the closure queue.
981 QueueClosure(closure)
984 if(clqsize < PACK_BUFFER_SIZE )
985 ClosureQueue[clqsize++] = closure;
988 fprintf(stderr,"Closure Queue Overflow (EnQueueing %lx)\n", (W_)closure);
994 @DeQueueClosure@ returns the head of the closure queue.
998 DeQueueClosure(STG_NO_ARGS)
1001 return(ClosureQueue[clqpos++]);
1007 %************************************************************************
1009 \subsection[pack-ga-types]{Types of Global Addresses}
1011 %************************************************************************
1013 These routines determine whether a GA is one of a number of special types
1022 return (ga->weight == 1 && ga->loc.gc.gtid == 0);
1029 return (ga->weight == 0);
1034 %************************************************************************
1036 \subsection[pack-print-packet]{Printing Packet Contents}
1038 %************************************************************************
1041 #if defined(DEBUG) || defined(GRAN_CHECK)
1048 W_ size, ptrs, nonptrs, vhs;
1055 W_ pptr = 0, pptrs = 0, pvhs;
1057 W_ unpacklocn = PACK_HDR_SIZE;
1058 W_ gastart = unpacklocn;
1059 W_ closurestart = unpacklocn;
1067 /* Unpack the header */
1068 bufsize = buffer[0];
1070 fprintf(stderr, "Packed Packet size %u\n\n--- Begin ---\n", bufsize);
1073 gastart = unpacklocn;
1074 ga.weight = buffer[unpacklocn++];
1075 if (ga.weight > 0) {
1076 ga.loc.gc.gtid = buffer[unpacklocn++];
1077 ga.loc.gc.slot = buffer[unpacklocn++];
1079 ga.loc.plc = (P_) buffer[unpacklocn++];
1080 closurestart = unpacklocn;
1083 fprintf(stderr, "[%u]: PLC @ %#lx\n", gastart, ga.loc.plc);
1084 } else if (isOffset(&ga)) {
1085 fprintf(stderr, "[%u]: OFFSET TO [%d]\n", gastart, ga.loc.gc.slot);
1087 /* Print normal closures */
1089 fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
1090 ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
1092 info = get_closure_info((P_) (buffer + closurestart), &size,
1093 &ptrs, &nonptrs, &vhs, str);
1095 if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
1096 size = ptrs = nonptrs = vhs = 0;
1098 if (IS_THUNK(info)) {
1099 if (IS_UPDATABLE(info))
1100 fputs("SHARED ", stderr);
1102 fputs("UNSHARED ", stderr);
1104 if (IS_BLACK_HOLE(info)) {
1105 fputs("BLACK HOLE\n", stderr);
1108 fprintf(stderr, "FH [%#lx", buffer[unpacklocn++]);
1109 for (i = 1; i < FIXED_HS; i++)
1110 fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1112 /* Variable header */
1114 fprintf(stderr, "] VH [%#lx", buffer[unpacklocn++]);
1116 for (i = 1; i < vhs; i++)
1117 fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1120 fprintf(stderr, "] PTRS %u", ptrs);
1124 fprintf(stderr, " NPTRS [%#lx", buffer[unpacklocn++]);
1126 for (i = 1; i < nonptrs; i++)
1127 fprintf(stderr, " %#lx", buffer[unpacklocn++]);
1134 /* Add to queue for processing */
1135 QueueClosure((P_) (buffer + closurestart));
1138 /* Locate next parent pointer */
1140 while (pptr + 1 > pptrs) {
1141 parent = DeQueueClosure();
1146 (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
1151 } while (parent != NULL);
1153 fprintf(stderr, "--- End ---\n\n");
1160 extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
1161 extern char *info_type(P_ infoptr); /* defined in Threads.lc */
1163 char str1[80], str2[80], junk_str[80];
1165 W_ size, ptrs, nonptrs, vhs;
1167 /* globalAddr ga; */
1169 W_ bufsize, unpackedsize ;
1171 W_ pptr = 0, pptrs = 0, pvhs;
1173 W_ unpacklocn = PACK_HDR_SIZE;
1174 W_ gastart = unpacklocn;
1175 W_ closurestart = unpacklocn;
1184 # if defined(GRAN) && defined(GRAN_CHECK)
1185 if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
1186 fprintf(stderr,"Packet @ 0x%lx hs no flag : 0x%lx\n",
1187 buffer, buffer[PACK_FLAG_LOCN]);
1192 tso = (P_) buffer[PACK_TSO_LOCN];
1194 /* Unpack the header */
1195 unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
1196 bufsize = buffer[PACK_SIZE_LOCN];
1198 fprintf(stderr, "Packed Packet %#lx, size %u (unpacked size is %u); demanded by TSO %#lx (%d)(PE %d)\n--- Begin ---\n",
1199 buffer, bufsize, unpackedsize, tso, TSO_ID(tso), where_is(tso));
1202 closurestart = unpacklocn;
1203 closure = (P_) buffer[unpacklocn++];
1205 fprintf(stderr, "[%u]: (%#lx) ", closurestart, closure);
1207 info = get_closure_info((P_) (closure),
1208 &size, &ptrs, &nonptrs, &vhs,str1);
1209 strcpy(str2,info_type(info));
1210 fprintf(stderr, "(%s|%s) ", str1, str2);
1212 if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
1213 size = ptrs = nonptrs = vhs = 0;
1215 if (IS_THUNK(info)) {
1216 if (IS_UPDATABLE(info))
1217 fputs("SHARED ", stderr);
1219 fputs("UNSHARED ", stderr);
1221 if (IS_BLACK_HOLE(info)) {
1222 fputs("BLACK HOLE\n", stderr);
1225 fprintf(stderr, "FH [%#lx", closure[0]);
1226 for (i = 1; i < FIXED_HS; i++)
1227 fprintf(stderr, " %#lx", closure[i]);
1229 /* Variable header */
1231 fprintf(stderr, "] VH [%#lx", closure[FIXED_HS]);
1233 for (i = 1; i < vhs; i++)
1234 fprintf(stderr, " %#lx", closure[FIXED_HS+i]);
1237 fprintf(stderr, "] PTRS %u", ptrs);
1241 fprintf(stderr, " NPTRS [%#lx", closure[FIXED_HS+vhs]);
1243 for (i = 1; i < nonptrs; i++)
1244 fprintf(stderr, " %#lx", closure[FIXED_HS+vhs+i]);
1250 } while (unpacklocn<bufsize) ; /* (parent != NULL); */
1252 fprintf(stderr, "--- End ---\n\n");
1255 #endif /* DEBUG || GRAN_CHECK */
1258 %************************************************************************
1260 \subsection[pack-get-closure-info]{Closure Info}
1262 %************************************************************************
1264 @get_closure_info@ determines the size, number of pointers etc. for this
1265 type of closure -- see @SMInfoTables.lh@ for the legal info. types etc.
1267 [Can someone please keep this function up to date. I keep needing it
1268 (or something similar) for interpretive code, and it keeps
1269 bit-rotting. {\em It really belongs somewhere else too}. KH @@ 17/2/95]
1273 get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
1275 W_ *size, *ptrs, *nonptrs, *vhs;
1278 P_ ip = (P_) INFO_PTR(closure);
1280 if (closure==NULL) {
1281 fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
1282 *size = *ptrs = *nonptrs = *vhs = 0;
1283 strcpy(type,"ERROR in get_closure_info");
1285 } else if (closure==PrelBase_Z91Z93_closure) {
1286 /* fprintf(stderr, "Qagh {get_closure_info}Daq: PrelBase_Z91Z93_closure closure\n"); */
1287 *size = *ptrs = *nonptrs = *vhs = 0;
1288 strcpy(type,"PrelBase_Z91Z93_closure");
1292 ip = (P_) INFO_PTR(closure);
1294 switch (INFO_TYPE(ip)) {
1295 case INFO_SPEC_U_TYPE:
1296 case INFO_SPEC_S_TYPE:
1297 case INFO_SPEC_N_TYPE:
1298 *size = SPEC_CLOSURE_SIZE(closure);
1299 *ptrs = SPEC_CLOSURE_NoPTRS(closure);
1300 *nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
1301 *vhs = 0 /*SPEC_VHS*/;
1302 strcpy(type,"SPEC");
1305 case INFO_GEN_U_TYPE:
1306 case INFO_GEN_S_TYPE:
1307 case INFO_GEN_N_TYPE:
1308 *size = GEN_CLOSURE_SIZE(closure);
1309 *ptrs = GEN_CLOSURE_NoPTRS(closure);
1310 *nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
1316 *size = DYN_CLOSURE_SIZE(closure);
1317 *ptrs = DYN_CLOSURE_NoPTRS(closure);
1318 *nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
1323 case INFO_TUPLE_TYPE:
1324 *size = TUPLE_CLOSURE_SIZE(closure);
1325 *ptrs = TUPLE_CLOSURE_NoPTRS(closure);
1326 *nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
1328 strcpy(type,"TUPLE");
1331 case INFO_DATA_TYPE:
1332 *size = DATA_CLOSURE_SIZE(closure);
1333 *ptrs = DATA_CLOSURE_NoPTRS(closure);
1334 *nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
1336 strcpy(type,"DATA");
1339 case INFO_IMMUTUPLE_TYPE:
1340 case INFO_MUTUPLE_TYPE:
1341 *size = MUTUPLE_CLOSURE_SIZE(closure);
1342 *ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
1343 *nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
1345 strcpy(type,"(IM)MUTUPLE");
1348 case INFO_STATIC_TYPE:
1349 *size = STATIC_CLOSURE_SIZE(closure);
1350 *ptrs = STATIC_CLOSURE_NoPTRS(closure);
1351 *nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
1353 strcpy(type,"STATIC");
1358 *size = IND_CLOSURE_SIZE(closure);
1359 *ptrs = IND_CLOSURE_NoPTRS(closure);
1360 *nonptrs = IND_CLOSURE_NoNONPTRS(closure);
1362 strcpy(type,"CAF|IND");
1365 case INFO_CONST_TYPE:
1366 *size = CONST_CLOSURE_SIZE(closure);
1367 *ptrs = CONST_CLOSURE_NoPTRS(closure);
1368 *nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
1370 strcpy(type,"CONST");
1373 case INFO_SPEC_RBH_TYPE:
1374 *size = SPEC_RBH_CLOSURE_SIZE(closure);
1375 *ptrs = SPEC_RBH_CLOSURE_NoPTRS(closure);
1376 *nonptrs = SPEC_RBH_CLOSURE_NoNONPTRS(closure);
1378 *nonptrs -= (2 - *ptrs);
1382 *vhs = SPEC_RBH_VHS;
1383 strcpy(type,"SPEC_RBH");
1386 case INFO_GEN_RBH_TYPE:
1387 *size = GEN_RBH_CLOSURE_SIZE(closure);
1388 *ptrs = GEN_RBH_CLOSURE_NoPTRS(closure);
1389 *nonptrs = GEN_RBH_CLOSURE_NoNONPTRS(closure);
1391 *nonptrs -= (2 - *ptrs);
1396 strcpy(type,"GEN_RBH");
1399 case INFO_CHARLIKE_TYPE:
1400 *size = CHARLIKE_CLOSURE_SIZE(closure);
1401 *ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
1402 *nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
1403 *vhs = CHARLIKE_VHS;
1404 strcpy(type,"CHARLIKE");
1407 case INFO_INTLIKE_TYPE:
1408 *size = INTLIKE_CLOSURE_SIZE(closure);
1409 *ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
1410 *nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
1412 strcpy(type,"INTLIKE");
1416 case INFO_FETCHME_TYPE:
1417 *size = FETCHME_CLOSURE_SIZE(closure);
1418 *ptrs = FETCHME_CLOSURE_NoPTRS(closure);
1419 *nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
1421 strcpy(type,"FETCHME");
1424 case INFO_FMBQ_TYPE:
1425 *size = FMBQ_CLOSURE_SIZE(closure);
1426 *ptrs = FMBQ_CLOSURE_NoPTRS(closure);
1427 *nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
1429 strcpy(type,"FMBQ");
1434 *size = BQ_CLOSURE_SIZE(closure);
1435 *ptrs = BQ_CLOSURE_NoPTRS(closure);
1436 *nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
1442 *size = BH_CLOSURE_SIZE(closure);
1443 *ptrs = BH_CLOSURE_NoPTRS(closure);
1444 *nonptrs = BH_CLOSURE_NoNONPTRS(closure);
1450 *size = 0; /* TSO_CLOSURE_SIZE(closure); */
1451 *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
1452 *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
1457 case INFO_STKO_TYPE:
1462 strcpy(type,"STKO");
1466 fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
1467 INFO_TYPE(ip), (W_) closure);
1475 @AllocateHeap@ will bump the heap pointer by @size@ words if the space
1476 is available, but it will not perform garbage collection.
1485 /* Allocate a new closure */
1486 if (SAVE_Hp + size > SAVE_HpLim)
1489 newClosure = SAVE_Hp + 1;
1498 doGlobalGC(STG_NO_ARGS)
1500 fprintf(stderr,"Splat -- we just hit global GC!\n");
1509 #endif /* PAR || GRAN -- whole file */