/* Packing for the Generic RTE: ---------------------------- Graph packing and unpacking code for sending it to another processor and retrieving the original graph structure from the packet. Used in GUM and Eden. (Outdated) Documentation for heap closures can be found at http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects However, the best documentation is includes/Closure*h and rts/sm/Scav.c */ #if defined(PARALLEL_RTS) /* whole file */ //@menu //* Includes:: //* Constants:: //* forward declarations:: //* Packing and helper functions:: //* More prototypes:: //* Variables:: //* Typedefs:: //* Init functions:: //* Packing helper functions:: //* General helper functions (GENERIC):: //* Packing helper functions (TOCHECK):: //* Closure queue helper functions:: //* Main packing functions:: //* Commoning up:: //* Main unpacking functions:: //* Managing packing state (Eden):: //* Packing wrappers:: //* Conversion Functions:: //* Closure conversion functions (GUM):: //* Debugging functions:: //* Sanity checks:: //* debugging functions:: //@end menu //@node Includes, Constants //@section Includes #include "Rts.h" #include "RtsUtils.h" #include "Hash.h" #include "sm/Storage.h" // to have recordMutableGenLock #include "Updates.h" // UPD_IND, which requires Storage.h! #include "Apply.h" // to get stg_arg_bitmaps #include "ParallelRts.h" // par vars etc; stats only? #include "ParTypes.h" // for globalAddr etc # if defined(DEBUG) # include "Sanity.h" # include "ParallelDebug.h" # endif #include "Printer.h" // printing closure info (also non-debug-enabled) #include /* later: #include "RTTables.h" // packet split operates on inports, // needs types and methods */ //@node Constants, forward declarations, Includes //@section Constants // for better reading only... ATTENTION: given in bytes! #define RTS_PACK_BUFFER_SIZE RtsFlags.ParFlags.packBufferSize // size of the (fixed) Closure header in words #define HEADERSIZE sizeof(StgHeader)/sizeof(StgWord) // some sizes for packed parts of closures #define PACK_PLC_SIZE 2 /* Size of a packed PLC in words */ #define PACK_GA_SIZE 3 /* Size of a packed GA in words */ #define PACK_FETCHME_SIZE (PACK_GA_SIZE + HEADERSIZE) /* Size of a packed fetch-me in words */ // markers for packed/unpacked type #define PLC 0L #define OFFSET 1L #define CLOSURE 2L #define END_OF_BUFFER_MARKER 0xedededed // arbitrary maximum size (compile time constant)... only for reverting moved thunks. #define MAX_THUNKS_PER_PACKET 256 //@node forward declarations, Packing and helper functions, Constants //@section forward declarations /* debugging only */ extern rtsBool check_IND_cycle(StgClosure *pT); /* Tagging macros will work for any word-sized type, not only closures. In the packet, we tag info pointers instead of closure pointers. */ #define UNTAG_CAST(type,p) ((type) UNTAG_CLOSURE((StgClosure*) (p))) // ADT of closure queues STATIC_INLINE void InitClosureQueue(void); STATIC_INLINE void StuffClosureQueue(void); STATIC_INLINE rtsBool QueueEmpty(void); STATIC_INLINE nat QueueSize(void); STATIC_INLINE void QueueClosure(StgClosure *closure); STATIC_INLINE StgClosure *DeQueueClosure(void); // Init for packing void InitPackBuffer(void); static void InitPacking(rtsBool unpack); static void ClearPackBuffer(void); // de-init: static void DonePacking(void); // little helpers: STATIC_INLINE void RegisterOffset(StgClosure *closure);// tag-safe STATIC_INLINE nat OffsetFor(StgClosure *closure); // tag-safe STATIC_INLINE rtsBool AlreadyPacked(int offset); // OBSOLETE // STATIC_INLINE rtsBool NotYetPacking(int offset); // declared in Parallel.h // rtsBool IsBlackhole(StgClosure* closure); /* used here and by the primitive which creates new channels: creating a blackhole closure from scratch. Declared in Parallel.h StgClosure* createBH(Capability *cap); used in HLComms: creating a list node Declared in Parallel.h StgClosure* createListNode(Capability *cap, StgClosure *head, StgClosure *tail); */ /* For packet splitting, make RoomToPack a procedure, which always succeeds, by sending partial data away when no room is left. => Omit ptrs argument. */ STATIC_INLINE rtsBool RoomToPack (nat size, nat ptrs); //@node Packing and helper functions, More prototypes, forward declarations //@section Packing and helper functions // external interface, declared in Parallel.h: // rtsPackBuffer* PackNearbyGraph(StgClosure* closure, StgTSO* tso, // nat *msgtag); #if 0 // for the testing primitive: StgClosure* DuplicateNearbyGraph(StgClosure* graphroot, StgTSO* tso) { StgClosure* copy; rtsPackBuffer* buffer; Port noPort = (Port) {0,0,0}; // for wrapping UnpackGraph extern globalAddr *PendingGABuffer; globalAddr *gamap = NULL; nat nGAs; buffer = PackNearbyGraph(graphroot, tso, 0); // HWL TODO: use UnpackGraphWrapper // allocate buffers InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize); gamap = PendingGABuffer; // unpack the graph # warning unwrapped call to UnpackGraph copy = UnpackGraph(buffer, &gamap, &nGAs, noPort, cap); return copy; } #endif //@node More prototypes, Variables, Packing and helper functions //@section More prototypes // packing routine, branches into special cases STATIC_INLINE void PackClosure (StgClosure *closure); // packing static addresses and offsets STATIC_INLINE void PackPLC(StgPtr addr); STATIC_INLINE void PackOffset(int offset); // the standard case: a heap-alloc'ed closure STATIC_INLINE void PackGeneric(StgClosure *closure); STATIC_INLINE void PackFetchMe(StgClosure *closureT); STATIC_INLINE void PackPAP(StgPAP *pap); STATIC_INLINE void PackArray(StgClosure* array); STATIC_INLINE void Pack(StgWord data); // GUM specific routines STATIC_INLINE rtsBool shouldGlobalise(StgClosure *closureT); STATIC_INLINE void GlobaliseAndPackGA (StgClosure *closure); STATIC_INLINE rtsBool isOffset(StgWord *slotptr); STATIC_INLINE rtsBool isFixed(StgWord *slotptr); STATIC_INLINE rtsBool isNotGlobal(StgWord *slotptr); STATIC_INLINE rtsBool isGlobal(StgWord *slotptr); STATIC_INLINE rtsBool isUnglobalised(StgWord *slotptr); STATIC_INLINE rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize); void InitPendingGABuffer(nat size); void CommonUp(StgClosure *src, StgClosure *dst); STATIC_INLINE StgClosure *SetGAandCommonUp(globalAddr *gaP, StgClosure *closure, rtsBool hasGA, Capability* cap); STATIC_INLINE StgClosure *FillInClosure(StgWord **bufptrP, StgClosure **graphP); /* This needs to be declared in includes/Parallel.h for Eden -- HWL StgClosure *UnpackGraph(rtsPackBuffer *packBuffer, globalAddr **gamap, nat *nGAs); */ STATIC_INLINE void UnpackGA(StgWord *bufptr, globalAddr *ga); STATIC_INLINE StgClosure *UnpackFetchMe(StgWord **bufptrP, StgClosure **graphP); STATIC_INLINE StgClosure *UnpackFetchMeWithGA(StgWord **bufptrP, StgClosure **graphP); //@node Variables, Typedefs, More prototypes //@section Variables // TODO: check where needed and move it to a better place nat packed_thunks=0; // stats only nat dest_pe=0; /* destination for message to send */ //@cindex PendingGABuffer globalAddr *PendingGABuffer, *gaga; //@node Typedefs, Init functions, Variables //@section Typedefs // Unpacking routines: // unpacking state (saved & restored) /* this structure saves internal data from Pack.c. * Not used outside, only saved as an StgPtr in the inport structure */ typedef struct UnpackInfo_ { StgClosure *parent; // current parent nat pptr; // current child pointer nat pptrs;// no. of pointers nat pvhs;// var. hdr. size (offset for filling in ptrs.) StgClosure* graphroot; // for GC (hard but true: always evacuate the whole //graph, since following message can contain offset references nat queue_length; StgClosure** queue; // closure queue, variable size nat offsetpadding; // padding to adjust offset between several packets HashTable* offsets; // set of offsets, stored in a Hashtable } UnpackInfo; static StgClosure* restoreUnpackState(UnpackInfo* unpack,StgClosure** graphroot, nat* pptr, nat* pptrs, nat* pvhs); static UnpackInfo* saveUnpackState(StgClosure* graphroot, StgClosure* parent, nat pptr, nat pptrs, nat pvhs); // external interface, declared in Parallel.h: /* StgClosure *UnpackGraph(rtsPackBuffer *packBuffer, Port inPort); */ // unpacks one closure (common prelude + switches to special cases) STATIC_INLINE StgClosure *UnpackClosure (StgWord **bufptrP, Capability* cap); // normal case: STATIC_INLINE void LocateNextParent(StgClosure **parentP, nat *pptrP, nat *pptrsP, nat *pvhsP); // special cases: STATIC_INLINE StgClosure * UnpackOffset(StgWord *ptr); STATIC_INLINE StgClosure * UnpackPLC(StgWord *ptr); static StgClosure *UnpackPAP(StgInfoTable *ip,StgWord **bufptrP, Capability* cap); static StgClosure *UnpackArray(StgInfoTable *info, StgWord **bufptrP, Capability* cap); /* Global (static) variables and declarations: As soon as we allow threaded+parallel, we need a lock, or all will become dynamic. */ /* The pack buffer, space for packing a graph. NB Unpack buffer will later be defined and allocated in HLComms.c */ static rtsPackBuffer *globalPackBuffer = NULL, /* for packing a graph */ *globalUnpackBuffer = NULL; /* for unpacking a graph */ /* packing and unpacking misc: */ static nat pack_locn, /* ptr to first free loc in pack buffer */ buf_id = 1; /* identifier for buffer */ static nat unpacked_size; static rtsBool packing_aborted; // global variable reporting whether // packing was aborted #if 0 // check if used static StgClosure *thunks[MAX_THUNKS_PER_PACKET]; // for reverting thunks (only when *moving*) #endif static int thunks_packed; // number of thunks_packed over all packets static StgClosure *graph_root; // for sending incompletely packed parts static rtsBool roomInBuffer; static OpCode *tagP; // sendertso included in globalPackBuffer /* The offset hash table is used during packing to record the location in the pack buffer of each closure which is packed */ static HashTable *offsetTable; static nat offsetpadding = 0; // padding for offsets in subsequent // packets /* the closure queue */ static StgClosure **ClosureQueue = NULL; static nat clq_size, clq_pos; // ----------------------------------------------------------------------------- // for the testing primitive: StgClosure* DuplicateNearbyGraph(StgClosure* graphroot, StgTSO* tso, Capability* cap) { StgClosure* copy; rtsPackBuffer* buffer; Port noPort = (Port) {0,0,0}; OpCode tag = 0; // for wrapping UnpackGraph // extern globalAddr *PendingGABuffer; globalAddr *gamap = NULL; nat nGAs; // allocate buffers InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize); gamap = PendingGABuffer; InitPackBuffer(); // allocate, if not done yet buffer = PackNearbyGraph(graphroot, tso, &tag); // unpack the graph # warning unwrapped call to UnpackGraph copy = UnpackGraph(buffer, &gamap, &nGAs, noPort, cap); return copy; } // ----------------------------------------------------------------------------- // functionality: //@node Init functions, Packing helper functions, Typedefs //@section Init functions // utilities and helpers /* @initPacking@ initialises the packing buffer etc. */ void InitPackBuffer(void) { ASSERT(RTS_PACK_BUFFER_SIZE > 0); if (globalPackBuffer==(rtsPackBuffer*)NULL) { if ((globalPackBuffer = (rtsPackBuffer *) stgMallocBytes(sizeof(rtsPackBuffer) + RTS_PACK_BUFFER_SIZE + sizeof(StgWord)*DEBUG_HEADROOM, "InitPackBuffer")) == NULL) barf("InitPackBuffer: could not allocate."); } } void freePackBuffer(void) { if (globalPackBuffer) // has been allocated (called from ParInit, so always) stgFree(globalPackBuffer); if (ClosureQueue) // has been allocated stgFree(ClosureQueue); } //@cindex InitPacking static void InitPacking(rtsBool unpack) { if (unpack) { /* allocate a GA-to-GA map (needed for ACK message) */ InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize); } else { /* allocate memory to pack the graph into */ InitPackBuffer(); } /* init queue of closures seen during packing */ InitClosureQueue(); // TODO: maybe init tagP here offsetpadding = 1; // will be modified after sending partial message // We start at 1 for the case that the graph root // (with pack_locn=0) is found again. // we need to store and recall offsets quickly also when unpacking // partially filled packets. offsetTable = allocHashTable(); if (unpack) return; globalPackBuffer->id = buf_id++; /* buffer id are only used for debugging! */ pack_locn = 0; /* the index into the actual pack buffer */ unpacked_size = 0; /* the size of the whole graph when unpacked */ roomInBuffer = rtsTrue; thunks_packed = 0; /* total number of thunks packed so far */ packing_aborted = rtsFalse; /* stops packing (with possibly blocked tso) */ } /* clear buffer, but use the old queue (stuffed) and the old offset table essentially a copy of InitPacking without offsetTable important: recall old pack_location as "offsetpadding" to allow cross-packet offsets. */ static void ClearPackBuffer(void) { // no need to allocate memory again ASSERT(globalPackBuffer != NULL); ASSERT(ClosureQueue != NULL); // stuff the closure queue (would soon be full if we just continue) StuffClosureQueue(); offsetpadding += pack_locn; // set to 1 when started (un)packing... // Buffer remains the same, admin. fields invalidated globalPackBuffer->id = buf_id++; // buffer id are only used for debugging! pack_locn = 0; // the index into the actual pack buffer unpacked_size = 0; // the size of the whole graph when unpacked roomInBuffer = rtsTrue; } /* DonePacking is called when we've finished packing. It releases memory etc. */ static void DonePacking(void) { freeHashTable(offsetTable, NULL); offsetTable = NULL; offsetpadding = 0; // which is invalid. } //@node Packing helper functions, General helper functions (GENERIC), Init functions //@section Packing helper functions /* RegisterOffset records that/where the closure is packed. */ // tag-safe STATIC_INLINE void RegisterOffset(StgClosure *closureT){ insertHashTable(offsetTable, // remove tag for offset UNTAG_CAST(StgWord, closureT), (void *) (StgWord) (pack_locn + offsetpadding)); // note: offset is never 0, padding starts at 1 } /* OffsetFor returns an offset for a closure which is already being packed. */ // tag-safe STATIC_INLINE nat OffsetFor(StgClosure *closureT) { // avoid typecast warnings... void* offset; offset = (lookupHashTable(offsetTable, // remove tag for offset UNTAG_CAST(StgWord, closureT))); return (nat) offset; } /* AlreadyPacked determines whether the closure's already being packed. Offset == 0 means no. */ STATIC_INLINE rtsBool AlreadyPacked(int offset) { // When root is found again, it will have offset 1 (offsetpadding). return(offset != 0); } static nat QueuedClosuresMinSize (nat ptrs) { return (QueueSize() + ptrs) * PACK_FETCHME_SIZE; } //@node General helper functions (GENERIC), Packing helper functions (TOCHECK), Packing helper functions //@section General helper functions (GENERIC) /*************************************************************** * general helper functions used here: * Perhaps find a different home for some of them? * ----------------------------------------------------------- */ /* get_closure_info: returns payload structure/name/... Only used here */ // NO! used in Global.c, too: STATIC_INLINE StgInfoTable* get_closure_info(StgClosure* nodeT, nat *size, nat *ptrs, nat *nonptrs, nat *vhs) { StgClosure *node; StgInfoTable *info; /* We remove the potential tag before doing anything. */ node = UNTAG_CLOSURE(nodeT); info = get_itbl(node); // from Storage.h => included it here! (not part of Rts.h!) *size = closure_sizeW(node); /* Caution: layout field is union, may contain different information according to closure type! see InfoTables.h: THUNK_SELECTOR: selector_offset stack frames, ret. vec.s, whatever: bitmap / ptr. to large_bitmap other closures: ptrs | nptrs */ switch (info->type) { case THUNK_SELECTOR: *ptrs = 1; // selectee is a pointer *vhs = *size - 1 - sizeofW(StgHeader); *nonptrs = 0; break; /* PAP/AP/AP_STACK contain a function field, treat this field as a (= the one single) pointer */ case PAP: *vhs = 1; /* arity/args */ *ptrs = 1; *nonptrs = 0; /* wrong, but not used in the unpacking code! */ break; case AP_STACK: case AP: *vhs = sizeofW(StgThunkHeader) - sizeofW(StgHeader) + 1; *ptrs = 1; *nonptrs = 0; /* wrong, but not used in the unpacking code! */ break; /* For Word arrays, no pointers need to be filled in. * (the default case would work for them as well) */ case ARR_WORDS: *vhs = 1; *ptrs = 0; *nonptrs = ((StgArrWords*) node)->words; break; /* For Arrays of pointers, we need to fill in all the pointers */ case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN0: case MUT_ARR_PTRS_FROZEN: *vhs = 2; *ptrs = ((StgMutArrPtrs*) node)->ptrs; *nonptrs = 0; // could indicate card table... (?) break; /* we do not want to see these here (until thread migration) */ case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: case UPDATE_FRAME: case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: case RET_BIG: case RET_BCO: barf("get_closure_info: stack frame!"); break; default: /* this works for all pointers-first layouts */ *ptrs = (nat) (info->layout.payload.ptrs); *nonptrs = (nat) (info->layout.payload.nptrs); *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader); } return info; } /* quick test for blackholes. Available somewhere else? */ rtsBool IsBlackhole(StgClosure* nodeT) // tag-safe { switch (((StgInfoTable*)get_itbl(UNTAG_CLOSURE(nodeT)))->type) { case BLACKHOLE: case CAF_BLACKHOLE: case RBH: case FETCH_ME: // any others? return rtsTrue; default: return rtsFalse; } } // For direct calls from PrimOps.cmm // HWL TODO: directly call createBH from PrimOps.cmm StgClosure* createBH_(Capability *cap) { return createBH(rtsFalse, cap); } StgClosure* createBH(rtsBool rbh, Capability *cap) { StgClosure *new; lnat size = (rbh==rtsTrue)?(sizeofW(StgRBH)):(sizeofW(StgInd)); // WAS: 2; BETTER: sizeofW(StgInd) -- HWL // a blackhole carries one nonpointer (=> word size) of bogus // payload, see StgMiscClosures.cmm, so we allocate 2 words. // if we have given a capability, we can allocateLocal (cheaper, no lock) if (cap != NULL) { new = (StgClosure*) allocateLocal(cap, size); } else { new = (StgClosure*) allocate(size); } if (rbh==rtsTrue) { SET_HDR(new, &stg_RBH_info, CCS_SYSTEM); // ccs to be checked! } else { SET_HDR(new, &stg_BLACKHOLE_info, CCS_SYSTEM); // ccs to be checked! } return new; } // cons node info pointer, from GHC.Base #define CONS_INFO ghczmprim_GHCziTypes_ZC_con_info // constructor tag for pointer tagging. We return a tagged pointer here! #define CONS_TAG 2 extern const StgInfoTable* CONS_INFO[]; // creating a list node. returns a tagged pointer. StgClosure* createListNode(Capability *cap, StgClosure *head, StgClosure *tail) { StgClosure *new; // a list node (CONS) carries two pointers => 3 words to allocate // if we have given a capability, we can allocateLocal (cheaper, no lock) if (cap != NULL) { new = (StgClosure*) allocateLocal(cap, 3); } else { new = (StgClosure*) allocate(3); } SET_HDR(new, CONS_INFO, CCS_SYSTEM); // to be checked!!! new->payload[0] = head; new->payload[1] = tail; return TAG_CLOSURE(CONS_TAG,new); } //@node Packing helper functions (TOCHECK), Closure queue helper functions, General helper functions (GENERIC) //@section Packing helper functions (TOCHECK) /* RoomToPack determines whether there's room to pack the closure into the pack buffer. The buffer must be able to hold at least more StgWords, plus one StgWord - the type tag (PLC,OFFSET, CLOSURE). Otherwise, it sends partial data away when no room is left. For GUM, we will have to include the queue size (as FETCH_MEs) as well. */ STATIC_INLINE rtsBool RoomToPack(nat size, nat ptrs) { if (/**tagP == 0*/ RtsFlags.ParFlags.globalising>0 ) { // GUM case if (roomInBuffer && ( (pack_locn + // where we are in the buffer right now size + // space needed for the current closure QueuedClosuresMinSize(ptrs/*additional ptrs not yet in queue*/) // space for queued closures as FETCH_MEs + 1)*sizeof(StgWord) // tag >= RTS_PACK_BUFFER_SIZE)) { roomInBuffer = rtsFalse; } } else { // Eden case if (roomInBuffer && ( (pack_locn + // where we are in the buffer right now size + // space needed for the current closure 1)*sizeof(StgWord) // tag >= RTS_PACK_BUFFER_SIZE)) { // HWL FIXIT: currently not sending a packet if this fills up IF_PAR_DEBUG(pack, debugBelch("Pack buffer full (size %d). " "Sending partially to receiver.", pack_locn)); barf(" sendWhilePacking() unimplemented.\n" "Current buffer size is %lu bytes, " "try bigger pack buffer with +RTS -qQ", RTS_PACK_BUFFER_SIZE); ClearPackBuffer(); IF_PAR_DEBUG(pack, debugBelch("Sent partially, now continue packing.")); roomInBuffer = rtsTrue; } } return roomInBuffer; } /* HWL: Eden only code from ghc-6.12-eden STATIC_INLINE void RoomToPack(nat size) { if (roomInBuffer && ( (pack_locn + // where we are in the buffer right now size + // space needed for the current closure // for GUM: // QueueSize * sizeof(FETCH_ME-in-buffer) + 1)*sizeof(StgWord) // tag >= RTS_PACK_BUFFER_SIZE)) { IF_PAR_DEBUG(pack, debugBelch("Pack buffer full (size %d). " "Sending partially to receiver.", pack_locn)); barf(" sendWhilePacking() unimplemented.\n" "Current buffer size is %lu bytes, " "try bigger pack buffer with +RTS -qQ", RTS_PACK_BUFFER_SIZE); ClearPackBuffer(); IF_PAR_DEBUG(pack, debugBelch("Sent partially, now continue packing.")); } return; } */ //@node Tests on GAs, Closure Queues, Pack buffer routines //@section Tests on GAs //@cindex isFixed STATIC_INLINE rtsBool isFixed(StgWord *slotptr) { return (*slotptr == PLC); } STATIC_INLINE rtsBool isOffset(StgWord *slotptr) { return (*slotptr == OFFSET); } //@cindex isGlobal STATIC_INLINE rtsBool isGlobal(StgWord *slotptr) { return (*slotptr > CLOSURE); } //@cindex isNotGlobal STATIC_INLINE rtsBool isNotGlobal(StgWord *slotptr) { return (*slotptr == CLOSURE); } //@node Closure queue helper functions, Main packing functions, Packing helper functions (TOCHECK) //@section Closure queue helper functions // Closure Queue: /* InitClosureQueue allocates and initialises the closure queue. */ STATIC_INLINE void InitClosureQueue(void) { clq_pos = clq_size = 0; if (ClosureQueue==NULL) ClosureQueue = (StgClosure**) stgMallocBytes(RTS_PACK_BUFFER_SIZE, "InitClosureQueue"); } /* PrintClosureQueue prints the whole closure queue. NB: all ptrs in the queue are tagged */ #if defined(DEBUG) static void PrintClosureQueue(void) { StgClosure *closure; nat i; debugBelch("Closure queue:\n"); for (i=clq_pos; i < clq_size; i++) { closure = UNTAG_CLOSURE(ClosureQueue[i]); debugBelch("at %d: %p (%s), \n", clq_size-i, (StgClosure *)closure, info_type(closure)); } } #endif /* StuffClosureQueue moves the enqueued closures to the beginning of the allocated area (could use a modulo instead, easier like this, since not common case) Only used in Eden. TODO: add to GUM, supporting sending multiple packets -- HWL GUM6EDEN */ STATIC_INLINE void StuffClosureQueue(void) { ASSERT(ClosureQueue != NULL); ASSERT(clq_pos<=clq_size); IF_PAR_DEBUG(packet, debugBelch("Stuffing closure queue (length %d).", clq_size - clq_pos); PrintClosureQueue()); if ( clq_pos < clq_size ) { // move content of queue to start of allocated memory (if any content) memmove(ClosureQueue, ClosureQueue + clq_pos, (clq_size - clq_pos) * sizeof(StgClosure*)); } // adjust position and size clq_size=clq_size - clq_pos; clq_pos=0; IF_PAR_DEBUG(packet, debugBelch("Closure queue now:"); PrintClosureQueue()); return; } /* QueueEmpty is rtsTrue if closure queue empty; rtsFalse otherwise */ STATIC_INLINE rtsBool QueueEmpty(void) { ASSERT(clq_pos <= clq_size); return(clq_pos == clq_size); } /* QueueSize is the queue size */ STATIC_INLINE nat QueueSize(void) { ASSERT(clq_pos <= clq_size); return(clq_size - clq_pos); } /* QueueClosure adds its argument to the closure queue. */ STATIC_INLINE void QueueClosure(StgClosure* closureT) { ASSERT(clq_pos <= clq_size); if(clq_size < RTS_PACK_BUFFER_SIZE ) { /* IF_PAR_DEBUG(packet, debugBelch(">__> Q: %p (%s); %ld elems in q\n", UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)), (long)clq_size-clq_pos+1)); */ ClosureQueue[clq_size++] = closureT; } else { barf("Pack.c: Closure Queue Overflow (EnQueueing %p (%s))", UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT))); } } /* DeQueueClosure returns the head of the closure queue. */ // returns a tagged closure STATIC_INLINE StgClosure* DeQueueClosure(void) { if(!QueueEmpty()) { /* IF_PAR_DEBUG(packet, debugBelch(">__> DeQ: %p (%s); %ld elems in q\n", UNTAG_CLOSURE(ClosureQueue[clq_pos]), info_type(UNTAG_CLOSURE(ClosureQueue[clq_pos])), (long)clq_size-clq_pos-1)); */ return(ClosureQueue[clq_pos++]); } else { // IF_PAR_DEBUG(packet, debugBelch("Q empty\n ")); return((StgClosure*)NULL); } } //@node Main packing functions, Commoning up, Closure queue helper functions //@section Main packing functions /******************************************************************* * packing a graph structure: * * The graph is packed breadth-first into a static buffer. * * Interface: PackNearbyGraph(IN graph_root, IN packing_tso, * IN/OUT msgtag) * main functionality: PackClosure (switches over type) * PackGeneric (copies, follows generic layout) * * mid-level packing: a closure is preceded by a marker for its type * 0L - isFixed: closure with static address - PackPLC * 1L - isOffset: offset (closure already in packet) - PackOffset * 2L - isNotGlobal: a heap closure follows - PackGeneric/specialised routines * else - GA + closure - PackGA + PackGeneric * * About the GHC feature "pointer tagging": * Every closure pointer carries a tag in its l.s. bits (those which * are not needed since closures are word-aligned anyway). These * tags should survive packing-sending-unpacking, so we must store * them in the packet somehow. * * Retrieving the tag/closure ptr: the tagged pointers are * *references* to a closure. NB: RTS must ensure that every * occurrence of one and the same pointer has a correct tag (minor, * or same tag)! OTOH, the tag must be inside the packed closure in * the packet. * * => Closure pointers in the closure queue are stored *WITH TAGS*, * and we pack the tags together with the closure. * OTOH, *offsets* (HashTable entries) are stored without tags, in * order to catch the case when two references with different tags * exist (possible?) * (the tag of the first occurrence will win, a problem?) * * a) Could use last bits of info-ptr (stored anyway) ? Is it * aligned just as closure pointers, in word size. * b) spend an extra word on every heap-closure (for 3 bits :-| ) * * We clearly opt for a. * * Anyway, closures are enqueued with tags, and the tag handled in * functions called from PackClosure(): PackGeneric, or specialised * ones. * * Restoring the tags: Tags must be restored at every place where we * put a reference to the closure. Here: when we fill in the * pointers to a closure. The tags are restored right after * unpacking, inside unpackClosure(). See comments there for details. * * About Eden vs GUM-style packing: * In the merged code there is no global distinction between these two. * We only need to distinguish whether we need to handle GAs during * packing (GUM-style). Also, we only have a tso argument for packing * if this code is called from Haskell. * To check with old code, Eden-style packing is characterised by * tso != NULL && RtsFlags.ParFlags.globalising==0 * *******************************************************************/ // helper accessing the pack buffer STATIC_INLINE void Pack(StgWord data) { ASSERT(pack_locn*sizeof(StgWord) < RTS_PACK_BUFFER_SIZE); globalPackBuffer->buffer[pack_locn++] = data; } // packing a static value // IMPORTANT: this is not tagged in general but needs to be; FIXIT -- HWL GUM6EDEN STATIC_INLINE void PackPLC(StgPtr addr) { Pack(PLC); /* marker */ // pointer tag of addr still present, packed as-is Pack((StgWord) addr); /* address */ } // packing an offset (repeatedly packed same closure) STATIC_INLINE void PackOffset(int offset) { Pack(OFFSET); /* marker */ Pack(offset); /* offset */ } //@cindex InitPendingGABuffer void InitPendingGABuffer(nat size) { if (PendingGABuffer==(globalAddr *)NULL) PendingGABuffer = (globalAddr *) stgMallocBytes(size*2*sizeof(globalAddr), "InitPendingGABuffer"); /* current location in the buffer */ gaga = PendingGABuffer; } #if 0 //@node Commoning up, Main unpacking functions, Main packing functions //@section Commoning up /* @CommonUp@ commons up two closures which we have discovered to be variants of the same object. One is made an indirection to the other. */ // Taken directly from -- HWL GUM6EDEN //@cindex CommonUp void CommonUp(StgClosure *srcT, StgClosure *dstT) { // TODO: do we need to keep the tag!?? -- HWL GUM6EDEN StgClosure *src = UNTAG_CLOSURE(srcT); StgClosure *dst = UNTAG_CLOSURE(dstT); StgInfoTable *info; nat size, ptrs, nonptrs, vhs, i; StgWord tag=0; /* get info about basic layout of the closure */ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs); ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL); ASSERT(src != dst); IF_PAR_DEBUG(pack, debugBelch("*___ CommonUp %p (%s) --> %p (%s)\n", src, info_type(src), dst, info_type(dst))); /* TODO: assertion on which closure types we may common up -- HWL GUM6EDEN */ /* TODO: check that this is necessary; could avoid UPD_IND altogehter!! -- HWL GUM6EDEN */ /* closure must be big enough to permit update with ind */ ASSERT(size>=HEADERSIZE+MIN_UPD_SIZE); /* no more awakening of BQs; at next checkBH iteration TSOs waiting for src will be re-awoken -- HWL GUM6EDEN */ SORT_OF_SAFE_UPD_IND(src, dst); } #endif /* * Common up the new closure with any existing closure having the same GA * About tagging: closureT is expected to be tagged */ //@cindex SetGAandCommonUp // Input: tagged // Output: tagged STATIC_INLINE StgClosure * SetGAandCommonUp(globalAddr *ga, StgClosure *closureT, rtsBool hasGA, Capability* cap) { StgClosure *existingT; StgInfoTable *ip, *oldip; globalAddr *newGA, *ga0; /* should we already have a local copy? */ if (ga->weight==0xFFFFFFFF) { ASSERT(ga->pe==thisPE); //sanity ga->weight=0; /* probably should also ASSERT that a commonUp takes place...*/ } ip = get_itbl(UNTAG_CLOSURE(closureT)); // first check if local closure is a FETCH_ME and fill in GA if necessary if (ip->type == FETCH_ME || ip->type == REMOTE_REF) { if ((existingT = GALAlookup(ga)) == NULL) { newGA = setRemoteGA(closureT, ga, rtsTrue); ((StgFetchMe *)UNTAG_CLOSURE(closureT))->ga = newGA; IF_DEBUG(sanity, ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)UNTAG_CLOSURE(closureT))->ga))); IF_PAR_DEBUG(pack, { char str[MAX_GA_STR_LEN]; showGA(((StgFetchMe *)UNTAG_CLOSURE(closureT))->ga, str); debugBelch("*<## FETCH_ME at %p is pointing to %s\n", UNTAG_CLOSURE(closureT), str);};); return closureT; } else { // closure represented by ga is local! no need for FM, create IND instead // we don't overwrite the FM to keep it intact for unpacking (see below) StgClosure *new_ind; new_ind = createBH(rtsFalse/*RBH?*/, (Capability *) NULL); // HWL TODO: could use cap here; // allocate a closure for indirection SORT_OF_SAFE_UPD_IND(new_ind, existingT); // this should take care of all upd admin // TODO: check whether this needs the tag of the existing closure return new_ind; // TAG_CLOSURE(GET_TAG(existingT), new_ind); } } ASSERT(!(ip->type == FETCH_ME || ip->type == REMOTE_REF)); if ((existingT = GALAlookup(ga)) == NULL) { /* Just keep the new object */ IF_PAR_DEBUG(pack, { char str0[MAX_GA_STR_LEN]; showGA(ga, str0); debugBelch("*<## New local object for GA %s is %p (%s)\n", str0, UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)));}); // make an entry binding closure to ga in the RemoteGA table newGA = setRemoteGA(closureT, ga, rtsTrue); } else { /* If the old closure is a FM, update with an indirection to the new closure */ IF_PAR_DEBUG(pack, { char str0[MAX_GA_STR_LEN]; showGA(ga, str0); debugBelch("*<## Local object for GA %s exists at %p (%s)\n", str0, UNTAG_CLOSURE(existingT), info_type(UNTAG_CLOSURE(existingT)));}); oldip = get_itbl(UNTAG_CLOSURE(existingT)); if (oldip->type == FETCH_ME || IsBlackhole(UNTAG_CLOSURE(existingT)) /* try to share evaluated closures oldip->type == CONSTR || oldip->type == CONSTR_1_0 || oldip->type == CONSTR_0_1 || oldip->type == CONSTR_2_0 || oldip->type == CONSTR_1_1 || oldip->type == CONSTR_0_2 */ ) { IF_PAR_DEBUG(pack, { char str0[MAX_GA_STR_LEN]; showGA(ga, str0); debugBelch("*<#- Duplicate local object for GA %s; redirecting %p (%s) -> %p (%s)\n", str0, UNTAG_CLOSURE(existingT), info_type(UNTAG_CLOSURE(existingT)), UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)));}); /* * What we had wasn't worth keeping, so make the old closure an * indirection to the new closure (copying BQs if necessary) and * make sure that the old entry is not the preferred one for this * closure. */ if (existingT == closureT) { // ToDo: assertion that they are different!! barf("PANIC: SetGAAndCommonUp: trying to update with an indirection to itself: %p (%s)\n", UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT))); } else { /* IF_PAR_DEBUG(verbose, */ /* debugBelch("____ Before Upd %p (%s) ; Target %p (%s)\n", */ /* existingT, info_type(UNTAG_CLOSURE(existingT)),closureT, info_type(UNTAG_CLOSURE(closureT)))); */ SORT_OF_SAFE_UPD_IND(UNTAG_CLOSURE(existingT), UNTAG_CLOSURE(closureT)); // was: CommonUp(existing, closure); //GALAdeprecate(ga); /* IF_PAR_DEBUG(verbose, */ /* debugBelch("____ After Upd %p (%s) ; Target %p (%s)\n", */ /* existingT, info_type(UNTAG_CLOSURE(existingT)),closureT, info_type(UNTAG_CLOSURE(closureT)))); */ } } else { /* * Either we already had something worthwhile by this name or * the new thing is just another FetchMe. However, the thing we * just unpacked has to be left as-is, or the child unpacking * code will fail. Remember that the way pointer words are * filled in depends on the info pointers of the parents being * the same as when they were packed. */ IF_PAR_DEBUG(pack, { char str0[MAX_GA_STR_LEN]; showGA(ga, str0); debugBelch("*<#@ Duplicate local object for GA %s; keeping %p (%s) nuking unpacked %p (%s)\n", str0, UNTAG_CLOSURE(existingT), info_type(UNTAG_CLOSURE(existingT)), UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)));}); /* overwrite 2nd word; indicates that the closure is garbage */ IF_DEBUG(sanity, ((StgFetchMe*)UNTAG_CLOSURE(closureT))->ga = (globalAddr*)GARBAGE_MARKER; IF_PAR_DEBUG(pack, debugBelch("++++ unpacked closure %p (%s) is garbage\n", UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT))))); closureT = existingT; } /* We don't use this GA after all, so give back the weight */ ga0 = addWeight(ga); } /* if we have unpacked a FETCH_ME, we have a GA, too */ ASSERT(get_itbl(UNTAG_CLOSURE(closureT))->type!=FETCH_ME || LOOKS_LIKE_GA(((StgFetchMe*)UNTAG_CLOSURE(closureT))->ga)); /* Sort out the global address mapping */ /* TODO: this should depend on RTS flag, controlling what we globalise -- HWL GUM6EDEN */ if (ip_THUNK(ip)){ // || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) || //(ip_MUTABLE(ip) && ip->type != FETCH_ME)) { /* Make up new GAs for single-copy closures */ // StgWord tag = GET_CLOSURE_TAG(closureT); globalAddr *newGA = makeGlobal(closureT, rtsTrue); // tag-safe // It's a new GA and therefore has the full weight #warning "HACK: low GA weight to track GA-as-ptr bug" // ASSERT(newGA->weight==0); // HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK /* Create an old GA to new GA mapping */ *gaga++ = *ga; splitWeight(gaga, newGA); // splitWeight(to, from) /* inlined splitWeight; we know that newGALA has full weight newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1); gaga->payload = newGA->payload; */ #warning "HACK: low GA weight to track GA-as-ptr bug" // ASSERT(gaga->weight == 1U << (BITS_IN(unsigned) - 1)); // HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK HACK gaga++; } return closureT; } /*------------------------------------------------------- About (un-)tagging: All Pack* routines MUST BE TAG-SAFE. By default, all aux fcts using StgClosure* arguments should also be tag-safe. If not, the fct name should end with _TAG_UNSAFE. An argument name such as closureT says, that it is tagged. -- HWL GUM6EDEN ------------------------------------------------------- */ /* Packing Sections of Nearby Graph Argument closureT is TAGGED in general PackNearbyGraph packs a closure and associated graph into a static buffer (PackBuffer). It returns the address of this buffer (which includes the size of the data packed into it, buffer->size !). The associated graph is packed in a breadth-first manner, hence it uses an explicit queue of closures to be packed rather than simply using a recursive algorithm. A request for packing is accompanied by the actual TSO. The TSO can be enqueued, if packing hits a Black Hole. Hitting a black hole means we have to retry after evaluation. We only have a TSO as arg, if the packing routine is called from Haskell (i.e. Eden-style), but not if the packing routine is called from the RTS (as response to a Fish, i.e. GUM-style). We use globalPackBuffer to pack the graph into. For sending, this will be moved into another send buffer (see HLComms.c). The latter, should be simplified and integrated into DataComms. TODO TODO TODO If the packet is full, the packing routine sends a packet on itself (using TSO->receiver, TODO which current Msg.? */ rtsPackBuffer* PackNearbyGraph(StgClosure* closureT, StgTSO* tso, OpCode *msgtagP) { #if defined(PAR_TICKY) packed_thunks=0; // init counter; global in Pack.c (set in PackGeneric) #endif InitPacking(rtsFalse); IF_PAR_DEBUG(verbose, debugBelch("Packing subgraph @ %p\n", closureT)); IF_PAR_DEBUG(pack, debugBelch("packing:"); debugBelch("id <%ld> (buffer @ %p); graph root @ %p [PE %d]\n", (long)globalPackBuffer->id, globalPackBuffer, closureT, thisPE); { char fingerPrintStr[MAX_FINGER_PRINT_LEN]; GraphFingerPrint(closureT, fingerPrintStr); debugBelch(" demanded by TSO %d (%p); Fingerprint is\n" "\t{%s}\n", (int)tso->id, tso, fingerPrintStr);};); IF_PAR_DEBUG(pack, IF_PAR_DEBUG(packet, debugBelch("** PrintGraph of %p is:", UNTAG_CLOSURE(closureT)); debugBelch("** pack_locn=%d\n", pack_locn); PrintGraph(UNTAG_CLOSURE(closureT),0))); #if defined(PAR_TICKY) PAR_TICKY_PACK_NEARBY_GRAPH_START(); #endif // HWL TOCHECK: INDs as graphroots may generate IND cycles after unpacking // graph_root = UNTAG_CLOSURE(closureT); graph_root = UNWIND_IND(UNTAG_CLOSURE(closureT)); // save the packing TSO (to block/enqueue it and for partial sending) // TODO: check that this is still needed for Eden -- HWL GUM6EDEN ASSERT(globalPackBuffer != NULL); globalPackBuffer->tso = tso; // save pointer to message tag for this message, // we will need to change it when we send a partial message. tagP = msgtagP; QueueClosure(closureT); do { PackClosure(DeQueueClosure()); if (packing_aborted) return ((rtsPackBuffer *)NULL); } while (!QueueEmpty()); /* Check for buffer overflow (again) */ ASSERT((pack_locn - DEBUG_HEADROOM) * sizeof(StgWord) <= RTS_PACK_BUFFER_SIZE); IF_DEBUG(sanity, // write magic end-of-buffer word globalPackBuffer->buffer[pack_locn++] = END_OF_BUFFER_MARKER); /* Record how much space the graph needs in packet and in heap */ globalPackBuffer->unpacked_size = unpacked_size; globalPackBuffer->size = pack_locn; DonePacking(); #if defined(PAR_TICKY) PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks); #endif IF_PAR_DEBUG(pack, debugBelch("\n** Finished <<%ld>> packing graph %p (%s); closures packed: %ld; thunks packed: %d; size of graph: %ld\n", (long)globalPackBuffer->id, UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)), (long)globalPackBuffer->size, thunks_packed, (long)globalPackBuffer->unpacked_size));; /* TODO: fix the checkPacket function and enable this sanity check! IF_DEBUG(sanity, // do a sanity check on the packet we just generated checkPacket(globalPackBuffer)); */ return (globalPackBuffer); } // must be tag-safe -- HWL // used in Global.c, too StgClosure* UNWIND_IND(StgClosure *closureT) { StgClosure *startT = closureT; while (closure_IND(startT)) startT = ((StgInd*) UNTAG_CLOSURE(startT))->indirectee; return startT; } /* Check whether we should globalise this closure. Globalisation scheme is set via an RTS flag. */ STATIC_INLINE rtsBool shouldGlobalise(StgClosure *closureT) { // tag-safe return (RtsFlags.ParFlags.globalising>1 || // this means globalise everything (RtsFlags.ParFlags.globalising==1 && // this means globalise thunks (closure_THUNK(closureT))) ); // TODO: check if this is also needed: !closure_UNPOINTED(closure) } /* If a closure is local, make it global. Then, divide its weight for export. The GA is then packed into the pack buffer. */ //@cindex GlobaliseAndPackGA // this needs tag info STATIC_INLINE void GlobaliseAndPackGA(StgClosure *closureT) { globalAddr *ga; globalAddr packGA; StgClosure *closure = UNTAG_CLOSURE(closureT); /* IF_DEBUG(sanity, */ /* packGA.pe=ILLEGAL_PE); */ if ((ga = LAGAlookup(closure)) == NULL) { ga = makeGlobal(closureT, rtsTrue); // must be tag-safe -- HWL GUM6EDEN // Global statistics: increase amount of global data by closure-size #if defined(PAR_TICKY) if (RtsFlags.ParFlags.ParStats.Global && RtsFlags.GcFlags.giveStats > NO_GC_STATS) { StgInfoTable *info; nat size, ptrs, nonptrs, vhs; // stats only!! // char str[MAX_INFO_STR_SIZE]; // TODO: FIX all calls like this -- HWL GUM6EDEN info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs); // str = info_type_by_ip(info); globalParStats.tot_global += size; } #endif } // TODO: check invariants on weight values // ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2); ASSERT(LOOKS_LIKE_GA(ga)); if (dest_pe==ga->pe) { // TODO: nuke evil global variable dest_pe -- HWL packGA.pe = ga->pe; packGA.slot = ga->slot; packGA.weight = 0xFFFFFFFF; // 0,1,2 are used already } else { splitWeight(&packGA, ga); // splitWeight(to,from) ASSERT(packGA.weight > 0); } IF_PAR_DEBUG(pack, { char str[MAX_GA_STR_LEN]; showGA(&packGA, str); debugBelch("*>## %p (%s): Globalising (%s) closure with GA %s\n", closure, info_type(closure), ( (ga->pe==dest_pe)?"returning": ( (ga->pe==thisPE)?"creating":"sharing" ) ), str);};); // mustafa ASSERT(LOOKS_LIKE_GA(&packGA)); Pack((StgWord) packGA.weight); Pack((StgWord) packGA.pe); Pack((StgWord) packGA.slot); } STATIC_INLINE rtsPackBuffer* PackTSO(StgTSO *tso, nat *packBufferSize) { barf("{PackTSO}Daq Qagh: trying to pack a TSO %d (%p) of size %d; thread migrations not supported, yet", tso->id, tso, packBufferSize); } //@cindex PackFetchMe STATIC_INLINE void PackFetchMe(StgClosure *closureT) // , StgWord tag) { StgInfoTable *ip; nat i; nat offset; StgWord tag =GET_CLOSURE_TAG(closureT); StgClosure *closure = UNTAG_CLOSURE(closureT); offset = OffsetFor(closureT); // tag-safe if (AlreadyPacked(offset)) { IF_PAR_DEBUG(packet, debugBelch("*>.. Packing FETCH_ME for closure %p (s) as OFFSET to %d", closure, info_type(closure), offset)); PackOffset(offset); // unpacked_size += 0; // unpacked_size unchanged (closure is shared!!) return; } /* Need a GA even when packing a constructed FETCH_ME (cruel world!) */ RegisterOffset(closureT); // tag-safe /* FMs must be always globalised */ GlobaliseAndPackGA(closureT); // this needs tagging info IF_PAR_DEBUG(packet, { char str[MAX_GA_STR_LEN]; globalAddr packGA; UnpackGA(&(globalPackBuffer->buffer[pack_locn-3]), &packGA); showGA(&packGA, str); debugBelch("*>.. Packing FETCH_ME for closure %p (%s) with GA %s", closure, info_type(closure), str);}); /* Pack a FetchMe closure instead of closure */ /* this assumes that the info ptr is always the first word in a closure*/ ip = &stg_FETCH_ME_info; // we store the tag of the pointer to the current closure in the info pointer of the packed closure! Pack((StgWord)TAG_CLOSURE(tag, (StgClosure*)ip)); for (i = 1; i < HEADERSIZE; ++i) // pack rest of fixed header Pack((StgWord)*(((StgPtr)closure)+i)); unpacked_size += sizeofW(StgFetchMe); /* size of FETCHME in packed is the same as that constant */ // TODO: re-enable: ASSERT(pack_locn-x==PACK_FETCHME_SIZE); /* In the pack buffer the pointer to a GA (in the FetchMe closure) is expanded to the full GA; this is a compile-time const */ //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE); } /* @PackClosure@ is the heart of the normal packing code. It packs a single closure into the pack buffer, skipping over any indirections, queues any child pointers for further packing. */ STATIC_INLINE void PackClosure(StgClosure* closureT) { StgInfoTable *info; nat offset; nat size, ptrs, nonptrs, vhs, i; char str[80]; // Ensure we can always pack this closure as an offset/PLC. /* get info about basic layout of the closure */ info = get_closure_info(UNTAG_CLOSURE(closureT), &size, &ptrs, &nonptrs, &vhs); // str = info_type_by_ip(info); // TODO: add // make sure we have enough room in the pack buffer; otw abandon packing -- HWL GUM6EDEN if (!RoomToPack(PACK_GA_SIZE + HEADERSIZE + vhs + nonptrs,ptrs )) { // GUM only IF_PAR_DEBUG(packet, debugBelch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)", UNTAG_CLOSURE(closureT), info_type(UNTAG_CLOSURE(closureT)))); PackFetchMe(closureT); return; } closureT = UNWIND_IND(closureT); // must be tag-safe; result must be tagged /* now closure is the thing we want to pack */ // ... but might still be tagged. offset = OffsetFor(closureT); /* If the closure has been packed already, just pack an indirection to it to guarantee that the graph doesn't become a tree when unpacked */ if (AlreadyPacked(offset)) { PackOffset(offset); return; } // remove the tag (temporary, subroutines will handle tag as needed) info = get_itbl(UNTAG_CLOSURE(closureT)); // we rely on info-pointers being word-aligned! // ??? HWL ??? ASSERT(info == UNTAG_CAST(StgInfoTable*, info)); switch (info->type) { // follows order of ClosureTypes.h... case INVALID_OBJECT: barf("Found invalid object"); case CONSTR: case CONSTR_1_0: case CONSTR_0_1: case CONSTR_2_0: case CONSTR_1_1: case CONSTR_0_2: PackGeneric(closureT); return; case CONSTR_STATIC: case CONSTR_NOCAF_STATIC: // For now we ship indirections to CAFs: They are // evaluated on each PE if needed case FUN_STATIC: // ToDo: check whether that's ok case THUNK_STATIC: // ToDo: check whether that's ok // TODO: based on discussion with SimonM we need to // re-construct the tag for these closures -- HWL GUM6EDEN IF_PAR_DEBUG(packet, debugBelch("*>~~ Packing a %p (%s) as a PLC\n", closureT, info_type_by_ip(info))); PackPLC((StgPtr)closureT); // NB: unpacked_size of a PLC is 0 return; case FUN: case FUN_1_0: case FUN_0_1: case FUN_2_0: case FUN_1_1: case FUN_0_2: PackGeneric(closureT); return; case THUNK: case THUNK_1_0: case THUNK_0_1: case THUNK_2_0: case THUNK_1_1: case THUNK_0_2: // !different layout! (smp update field, see Closures.h) // the update field should better not be shipped... PackGeneric(closureT); return; case THUNK_SELECTOR: { /* a thunk selector means we want to extract one of the * arguments of another closure. See GC.c::eval_thunk_selector: * selectee might be CONSTR*, or IND*, or unevaluated (THUNK*, * AP, AP_STACK, BLACKHOLE). * * GC tries to evaluate and eliminate THUNK_SELECTORS by * following them. For packing, we could include them in * UNWIND_IND, but this is fatal in case of a loop (UNWIND_IND * will loop). So we just pack the selectee as well * instead. get_closure_info treats the selectee in this closure * type as a pointer field. */ IF_PAR_DEBUG(packet, StgClosure *closure = UNTAG_CLOSURE(closureT); StgClosure *selectee = ((StgSelector *)closure)->selectee; debugBelch("*>** Found THUNK_SELECTOR at %p (%s)" "pointing to %p (%s)\n", closure, info_type_by_ip(info), selectee, info_type(UNTAG_CLOSURE(selectee)))); PackGeneric(closureT); return; } case BCO: barf("Packing: BCO, not implemented"); case AP: case PAP: PackPAP((StgPAP *)closureT); // also handles other stack-containing types return; case AP_STACK: // TODO: add migration code here barf("Pack: unable to pack a stack"); case IND: case IND_OLDGEN: case IND_PERM: case IND_OLDGEN_PERM: case IND_STATIC: barf("Pack: found IND_... after shorting out indirections %d (%s)", (nat)(info->type), info_type_by_ip(info)); // return vectors case RET_BCO: case RET_SMALL: case RET_BIG: case RET_DYN: case RET_FUN: barf("{Pack}Daq Qagh: found return vector %p (%s) when packing", UNTAG_CLOSURE(closureT), info_type_by_ip(info)); // stack frames case UPDATE_FRAME: case CATCH_FRAME: case STOP_FRAME: barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)", UNTAG_CLOSURE(closureT), info_type_by_ip(info)); case CAF_BLACKHOLE: case BLACKHOLE: case FETCH_ME: case RBH: { StgTSO* tso = globalPackBuffer->tso; if (tso != NULL && RtsFlags.ParFlags.globalising==0 /* Eden-style packing */ ) { // called from Haskell // I think this should never be entered in GUM, but it looks like tso will be != NULL in some situations; add an assertion here -- HWL GUM6 IF_PAR_DEBUG(packet, debugBelch("TSO %d hit blackhole (type %s) at %p while packing.\n", (int)tso->id, info_type_by_ip(info), UNTAG_CLOSURE(closureT))); // If a TSO called a primOp, it must be blocked on this BH // until the BH gets updated/data arrives. On the awakening of // the BlockingQueue, the PrimOp calls packClosure again. tso->why_blocked = BlockedOnBlackHole; // TODO: is this the right flag; better use a specific one -- HWL GUM6EDEN tso->block_info.closure = closureT; // tags should be preserved; see checkBlackHoles, where block_info.closure is untagged -- HWL GUM6EDEN packing_aborted = rtsTrue; // packing failed, will return NULL buffer // rest to be done by caller // (MUST put TSO in blackhole_queue!!! or error, if no BH expected) } else { // called from RTS // this is the normal case for GUM IF_PAR_DEBUG(pack, debugBelch("*>.. Packing a BH-like closure at %p (%s) as a FETCH_ME\n", closureT, info_type(UNTAG_CLOSURE(closureT)))); /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs; phps short-cut the GA here */ PackFetchMe(closureT); } return; } case MVAR_CLEAN: case MVAR_DIRTY: barf("MVAR packing not implemented; closure @ %p (%s)", closureT, info_type(UNTAG_CLOSURE(closureT))); case REMOTE_REF: // TODO: check that this is the right branch -- HWL GUM6EDEN barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)", closureT, info_type(UNTAG_CLOSURE(closureT))); case ARR_WORDS: PackArray(closureT); return; case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN0: case MUT_ARR_PTRS_FROZEN: /* We use the same routine as for ARR_WORDS The implementation of (immutable!) arrays uses these closure types, as well as that of mutable arrays. => perhaps impossible to find out from the RTS whether we should allow duplication of the array or not. */ IF_PAR_DEBUG(packet, debugBelch("Packing pointer array @ %p!", closureT)); // TODO: check array-packing code for GUM -- HWL GUM6EDEN PackArray(closureT); return; case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: barf("MUT_VAR packing, not imlemented yet.\n (DEBUG: packing %s @ %p)", info_type_by_ip(info),closureT); case WEAK: case STABLE_NAME: debugBelch("Pack: found foreign thingy in %d (%s); aborting packing", (nat)(info->type), info_type_by_ip(info)); packing_aborted = rtsTrue; return; case TSO: PackTSO((StgTSO*)closureT, /*pack buffer size*/0); // don't get your hopes up; not supported, yet return; case TVAR_WATCH_QUEUE: case INVARIANT_CHECK_QUEUE: case ATOMIC_INVARIANT: case TVAR: case TREC_CHUNK: case TREC_HEADER: barf("Pack: packing type %s (%p) not implemented", info_type_by_ip(info), closureT); // more stack frames: case ATOMICALLY_FRAME: case CATCH_RETRY_FRAME: case CATCH_STM_FRAME: barf("{Pack}Daq Qagh: found stack frame %p (%s) when packing (thread migration not implemented)", closureT, info_type_by_ip(info)); case WHITEHOLE: /* something's very wrong */ barf("Pack: found %s (%p) when packing", info_type_by_ip(info), closureT); default: barf("Pack: strange closure %d", (nat)(info->type)); packing_aborted = rtsTrue; // not reached... return; } /* switch */ } STATIC_INLINE void PackGeneric(StgClosure* closureT) { StgInfoTable *info; StgClosure *rbh; nat size, ptrs, nonptrs, vhs, i; StgWord tag=0; StgClosure* closure; /* store tag separately, pack with info ptr. */ tag = GET_CLOSURE_TAG(closureT); closure = UNTAG_CLOSURE(closureT); /* get info about basic layout of the closure */ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs); ASSERT(!IsBlackhole(closure)); IF_PAR_DEBUG(pack, debugBelch("*>== %p (%s): generic packing" "(size=%d, ptrs=%d, nonptrs=%d, and tag %d)\n", closure, info_type(closure), size, ptrs, nonptrs, (nat)tag)); /* make sure we can pack this closure into the current buffer (otherwise this routine sends a message and resets the buffer) */ // GUM specific /* packing strategies: how many thunks to add to a packet; default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */ if (RtsFlags.ParFlags.thunksToPack && thunks_packed >= RtsFlags.ParFlags.thunksToPack && closure_THUNK(closure)) { IF_PAR_DEBUG(pack, debugBelch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)\n", thunks_packed, closure, info_type(closure))); PackFetchMe(closureT); return; } #if defined(PARALLEL_RTS) && defined(PAR_TICKY) if (closure_THUNK(closure)) { packed_thunks++; } #endif /* Record the location of the GA */ RegisterOffset(closure); /* Allocate a GA for this closure and put it into the buffer Checks for globalisation scheme; default: globalise everything thunks */ if (shouldGlobalise(closureT)) { GlobaliseAndPackGA(closureT); } else { Pack((StgWord) CLOSURE); /* marker for unglobalised closure */ } /* At last! A closure we can actually pack! */ /* Remember, the generic closure layout is as follows: +-------------------------------------------------+ | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS | +-------------------------------------------------+ */ /* pack fixed and variable header */ // store the tag inside the first word (==infopointer) Pack((StgWord) (TAG_CLOSURE(tag, (StgClosure*) *((StgPtr) closure )))); // pack the rest of the header (variable header) for (i = 1; i < HEADERSIZE + vhs; ++i) Pack((StgWord)*(((StgPtr)closure)+i)); /* register all ptrs for further packing */ for (i = 0; i < ptrs; ++i) QueueClosure(((StgClosure *) *(((StgPtr)closure)+(HEADERSIZE+vhs)+i))); /* pack non-ptrs */ for (i = 0; i < nonptrs; ++i) Pack((StgWord)*(((StgPtr)closure)+(HEADERSIZE+vhs)+ptrs+i)); ASSERT(HEADERSIZE+vhs+ptrs+nonptrs==size); // no slop in closure, all packed unpacked_size += size; /* Record that this is a revertable black hole so that we can fill in its address from the fetch reply. Problem: unshared thunks may cause space leaks this way, their GAs should be deallocated following an ACK. */ if (shouldGlobalise(closure)) { rbh = convertToRBH(closure); // UNTAGGED // ASSERT(size>=HEADERSIZE+MIN_UPD_SIZE); // min size for any updatable closure ASSERT(rbh == closure); // rbh at the same position (minced version) thunks_packed++; } else { // for reversion, enable this code // record the thunk that has been packed so that we may abort and revert // thunks_packed[no_thunks_packed++] = closure; } } /* Packing PAPs: a PAP (partial application) represents a function * which has been given too few arguments for complete evaluation * (thereby defining a new function with fewer arguments). PAPs are * packed by packing the function and the argument stack, where both * can point to static or dynamic (heap-allocated) closures which must * be packed later, and enqueued here. */ STATIC_INLINE void PackPAP(StgPAP *pap) { nat i; nat hsize; // StgHeader size StgPtr p; // stack object currently packed... nat args; // no. of arguments StgWord bitmap; // ptr indicator nat size; // size of bitmap StgFunInfoTable *funInfo; // where to get bitmap... nat msize, mptrs, mnonptrs, mvhs; //TODO : check this // JB 08/2007: remove, and store the tag separately... StgWord tag=0; tag = GET_CLOSURE_TAG((StgClosure*) pap); pap = (StgPAP*) UNTAG_CLOSURE((StgClosure*) pap); ASSERT(LOOKS_LIKE_CLOSURE_PTR(pap)); ASSERT(get_itbl(pap)->type == PAP || get_itbl(pap)->type == AP); /* PAP/AP closure layout in GHC-6.x (see Closures.h): * +--------------------------------------------------------------+ * | Header | (arity | n_args) | Function | Stack.|Stack.|Stack...| * +--------------------------------------------------------------+ * particularities: * ---------------- * PAP : as described, normal Header * AP : Thunk Header (1 extra word, see Closures.h) * * In previous versions, we treated AP_STACK in the same way. This * is wrong, AP_STACK closures can contain update frames and other * stack-only objects. */ switch (get_itbl(pap)->type) { case PAP: size = pap_sizeW(pap); args = pap->n_args; hsize = HEADERSIZE+1; break; case AP: size = ap_sizeW((StgAP *)pap); args = ((StgAP*) pap)->n_args; hsize = sizeofW(StgThunkHeader)+1; break; default: barf("PackPAP: strange info pointer, type %d ", get_itbl(pap)->type); } IF_PAR_DEBUG(packet, debugBelch("Packing Closure with stack (%s) @ %p," "stack size %d\n", info_type((StgClosure*) pap), pap, args)); StgInfoTable *ip = get_closure_info((StgClosure*) pap , &msize, &mptrs, &mnonptrs, &mvhs); /* check that we have enough room in the pack buffer */ if (RtsFlags.ParFlags.globalising>0 && !RoomToPack(PACK_GA_SIZE + size - 1/*fun ptr*/ + args, mptrs)) { // GUM only IF_PAR_DEBUG(pack, debugBelch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)", (StgClosure *)pap, info_type((StgClosure *)pap))); //PackFetchMe((StgClosure *)pap); PackFetchMe( TAG_CLOSURE(tag, (StgClosure*) pap ) ); return; } // preliminaries: register closure, check for enough space... RegisterOffset((StgClosure*) pap); if (RtsFlags.ParFlags.globalising==0) { // Eden only case RoomToPack(size - 1 + args, 0/*#ptrs: unused in Eden*/); // double stack size, but no function field } /* Checks for globalisation scheme; default: globalise every thunk */ if (shouldGlobalise((StgClosure*)pap)) { GlobaliseAndPackGA((StgClosure *)pap); // TODO: check whether we need a tag here } else { Pack((StgWord) CLOSURE); // marker for unglobalised closure } /* * first pack the header, which starts with non-ptrs: * { StgHeader , (arity,args) } * StgHeader is where AP (ThunkHeader) differs from * PAP. Besides, both have one extra StgWord containing * (arity|n_args) resp. size. hsize got adjusted above, now pack * exactly this amount of StgWords. * And store tag in first word of header (==infopointer) */ Pack((StgWord) (TAG_CLOSURE(tag, (StgClosure*) *((StgPtr) pap )))); for(i = 1; i < hsize; i++) { Pack((StgWord) *(((StgWord*)pap)+i)); } /* Next, we find the function, which might be heap-allocated. * Instead of checking if it is heap_alloc.ed, we always queue it * and pack it later, unpacking is the reverse (needs to treat the * field as a pointer arg.). * Queue fun closure with tags, analyse without them... */ funInfo = get_fun_itbl(UNTAG_CLOSURE(pap->fun)); QueueClosure(pap->fun); unpacked_size += pap_sizeW(pap); // minimum: unpack only the PAP /* Now the payload, which is the argument stack of the function. A * packed bitmap inside the function closure indicates which stack * addresses are pointers(0 for ptr). See GC:scavenge_PAP_payload() * and InfoTables.h,Constants.h for details... * * Saving the bitmap in the packet does not work easily, since it * can vary in size (bitmap/large bitmap). So we tag every stack * element with its type for unpacking (tags: PLC/CLOSURE), doubling * the stack size. We could pack only the tag for pointers, but then * we do not know the size in the buffer, so we pack the tag twice * for a pointer. * * Unpacking a PAP is the counterpart, which * creates an extra indirection for every pointer on the stack and * puts the indirection on the stack. */ switch(funInfo->f.fun_type) { // these two use a large bitmap. case ARG_GEN_BIG: case ARG_BCO: // TODO: cover this case -- HWL GUM6EDEN barf("PackPAP: large bitmap, not implemented"); // should be sort of: // packLargeBitmapStack(pap->payload,GET_FUN_LARGE_BITMAP(funInfo),args); // return; break; // another clever solution: fields in info table different for // some cases... and referring to autogenerated constants (Apply.h) case ARG_GEN: bitmap = funInfo->f.b.bitmap; break; default: bitmap = stg_arg_bitmaps[funInfo->f.fun_type]; } p = (StgPtr) pap->payload; // points to first stack element args = pap->n_args;// tells how many slots we find on the stack // extract bits and size from bitmap (see Constants.h): size = BITMAP_SIZE(bitmap); // not always n_args == BITMAP_SIZE(bitmap) ?!? // ASSERT(size == args); bitmap = BITMAP_BITS(bitmap); IF_PAR_DEBUG(packet, debugBelch("Packing stack chunk, size %d (PAP.n_args=%d), bitmap %#o\n", size, (int)args, (nat)bitmap)); /* now go through the small bitmap (its size should be == args???) * The bitmap contains 5/6 bit size, which should AFAICT be * identical to args. Not ones, but zeros indicate pointers on the * stack! According to Scav.c, the "direction" of the bitmap traversal * is least to most significant ( bitmap>>1 corresponds to p++). */ size = 0; while (args > 0) { if ((bitmap & 1)== 0) { /* Zero: a pointer*/ ASSERT(LOOKS_LIKE_CLOSURE_PTR((StgClosure*) *p)); Pack((StgWord) CLOSURE); // pointer tag Pack((StgWord) CLOSURE); // padding for constant size... QueueClosure((StgClosure*) *p); // closure will be packed later unpacked_size += sizeofW(StgInd);// unpacking creates add. IND size++; } else { Pack((StgWord) PLC); // constant tag Pack((StgWord) *p); // and the argument } p++; // advance in payload, next bit, next arg bitmap = bitmap>>1; args--; } /* PAP/AP in the pack buffer: * +-----------------------------------------------------------------+ * | Header | (arity | n_args) | Tag | Arg/Tag | Tag | Arg/Tag | ... | * +-----------------------------------------------------------------+ * Header can be 1 (normal) or 2 StgWords (Thunk Header) */ IF_PAR_DEBUG(packet, debugBelch("packed PAP, stack contained %d pointers\n", size)); } /* Packing Arrays. * * An Array in the heap can contain StgWords or Pointers (to * closures), and is thus of type StgArrWords or StgMutArrPtrs. * * Array layout in heap/buffer is the following: * +------------------------------------------------------------+ * | Header | size(StgWord) | word1 | word2 | ... | word_(size) | * +------------------------------------------------------------+ * * Packing ArrWords means to just pack all the words (as non-ptrs). * * MutArrPtrs (MUT_ARRAY_PTRS_* types) contain pointers to other * closures instead of words. * Packing MutArrPtrs means to enqueue/pack all pointers found. * OTOH, packing=copying a mutable array is not a good idea at all. * We implement it even though, leave it to higher levels to restrict. * */ STATIC_INLINE void PackArray(StgClosure *closureT) { StgInfoTable *info; StgClosure *closure; nat i, payloadsize, packsize; /* remove tag, store it in infopointer (same as above) */ StgWord tag=0; tag = GET_CLOSURE_TAG(closureT); closure = UNTAG_CLOSURE(closureT); /* get info about basic layout of the closure */ info = get_itbl(closure); ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS_CLEAN || info->type == MUT_ARR_PTRS_DIRTY || info->type == MUT_ARR_PTRS_FROZEN0 || info->type == MUT_ARR_PTRS_FROZEN); if (info->type == ARR_WORDS) { payloadsize = ((StgArrWords *)closure)->words; packsize = payloadsize + 2; } else { // MUT_ARR_PTRS_* {info,(no. of)ptrs,size(total incl.card table)} // Only pack header, not card table which follows the data. packsize = 3; payloadsize = ((StgMutArrPtrs *)closure)->ptrs; } // the function in ClosureMacros.h would include the header: // arr_words_sizeW(stgCast(StgArrWords*,q)); IF_PAR_DEBUG(pack, debugBelch("*>== %p (%s): packing array" "(%d words) (size=%d)\n", closure, info_type(closure), payloadsize, (int)closure_sizeW(closure))); /* TODO: make enough room in the pack buffer, see PackPAP code */ if (RtsFlags.ParFlags.globalising==0) { // Eden only RoomToPack(packsize, 0/*ptrs: unused in Eden?*/); } /* record offset of the closure */ RegisterOffset(closure); /* global stats about arrays sent TODO: add ParStats if (RtsFlags.ParFlags.ParStats.Global && RtsFlags.GcFlags.giveStats > NO_GC_STATS) { globalParStats.tot_arrs++; globalParStats.tot_arr_size += ((StgArrWords *)closure)->words; } */ /* Checks for globalisation scheme; default: globalise everything thunks */ if (shouldGlobalise(closureT)) { GlobaliseAndPackGA(closureT); // must carry tag } else { Pack((StgWord) CLOSURE); // marker for unglobalised closure } /* Pack the header (2 words: info ptr and the number of words to follow) */ Pack((StgWord) (TAG_CLOSURE(tag, (StgClosure*) *((StgPtr) closure )))); Pack((StgWord) ((StgArrWords *)closure)->words); if (info->type == ARR_WORDS) { /* pack the payload of the closure (all non-ptrs) */ /* for (i=0; ipayload[i]); */ memcpy((globalPackBuffer->buffer) + pack_locn, ((StgArrWords *)closure)->payload, payloadsize * sizeof(StgWord)); pack_locn += payloadsize; } else { // MUT_ARR_PTRS_*: pack total size, enqueue pointers Pack((StgWord) ((StgMutArrPtrs*)closure)->size); for (i=0; ipayload[i]); } // this should be correct for both ARR_WORDS and MUT_ARR_* unpacked_size += closure_sizeW(closure); } //@node Main unpacking functions, Managing packing state (Eden), Commoning up //@section Main unpacking functions /******************************************************************* * unpacking a graph structure: *******************************************************************/ /* @UnpackGraph@ unpacks the graph contained in a message buffer. It returns a pointer to the new graph. The inPort parameter restores the unpack state when the sent graph is sent in more than one message. Formerly, we also had a globalAddr** @gamap@ parameter: set to point to an array of (oldGA,newGA) pairs which were created as a result of unpacking the buffer; and nat* @nGAs@ set to the number of GA pairs which were created. Could have a new parameter Capability* for allocation (and might be good for modelling Processes) for "pointer tagging", we assume here that all stored info pointers (each first word of a packed closure) also carry the tag found at the sender side when enqueueing it (for the first time!). When closures are unpacked, the tag must be added before inserting the result of unpacking into other closures as a pointer. Done by UnpackClosure(), see there. */ StgClosure * UnpackGraph(rtsPackBuffer *packBuffer, globalAddr **gamap, nat *nGAs, // GUM only Port inPort, Capability* cap) { StgWord *bufptr, *slotptr; StgClosure *closureT, *graphroot, *parent; nat heapsize, bufsize, pptr= 0, pptrs= 0, pvhs= 0; nat unpacked_closures= 0, unpacked_thunks= 0; // stats only // GUM only StgWord **main_bufptr, **new_bufptr, **tmp_bufptr; globalAddr gaS; StgClosure *graph; /* to save and restore the unpack state (future use...) */ UnpackInfo *unpackState = NULL; nat currentOffset; ASSERT(packBuffer != NULL); /* Initialisation */ InitPacking(rtsTrue); // same as in PackNearbyGraph /* TODO: fix the checkPacket function and enable this sanity check! IF_DEBUG(sanity, // do a sanity check on the incoming packet checkPacket(packBuffer));*/ graphroot = (StgClosure *)NULL; globalUnpackBuffer = packBuffer; // -- HWL GUM6EDEN /* Unpack the header */ bufsize = packBuffer->size; heapsize = packBuffer->unpacked_size; bufptr = packBuffer->buffer; main_bufptr = packBuffer->buffer; IF_PAR_DEBUG(pack, debugBelch("Packing: Header unpacked. (bufsize=%d, heapsize=%d)\n" "Unpacking closures now...\n", bufsize, heapsize)); #if defined(PAR_TICKY) PAR_TICKY_UNPACK_GRAPH_START(); #endif /* starting point */ bufptr = packBuffer->buffer; // check if an incomplete subgraph is pending for this inport // if there is any, we should unpack a PART Message here. // we remembered state from previous receive in a sequence thereof /* TODO! Inport* inport = findInportByP(inPort); unpackState = inport->unpackState; inport->unpackState = NULL; // invalidate, will be deallocated! */ if (unpackState!=NULL) { // Eden only IF_PAR_DEBUG(pack, debugBelch("Unpack state found, partial message on inport %d.\n", (int)inPort.id)); // restore data for unpacking: inverse analogon to saveUnpackState(...) parent = restoreUnpackState(unpackState, &graphroot, &pptr, &pptrs, &pvhs); ASSERT(RtsFlags.ParFlags.globalising==0); // should only be executed in Eden-style RTS } else { IF_PAR_DEBUG(pack, debugBelch("Unpack state not found, normal message on inport %d\n.", (int)inPort.id)); parent = (StgClosure *) NULL; } do { /* check that we aren't at the end of the buffer, yet */ IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER)); /* This is where we will ultimately save the closure's address */ tmp_bufptr = main_bufptr; // GUM only /* pointer to the type marker (Offset, PLC, or Closure) */ slotptr = bufptr; currentOffset = (offsetpadding /* ...which is at least 1! */ + ((nat) (bufptr - (packBuffer->buffer)))); /* this allocates heap space, checks for PLC/offset etc * The "pointer tag" found at sender side is added * inside this routine, nothing special to do here. */ closureT = UnpackClosure (/*in/out*/&bufptr, cap); // TAGGED unpacked_closures++; // stats only // TODO: add this for stats // unpacked_thunks += (closure_THUNK(UNTAG_CLOSURE(closureT))) ? 1 : 0; // stats only /* common up with other graph unless the closure came without a GA; GUM only */ if (isGlobal(slotptr)) { // &gaS)) { UnpackGA(slotptr, &gaS); ASSERT(LOOKS_LIKE_GA(&gaS)); closureT = SetGAandCommonUp(&gaS, closureT, isGlobal(slotptr), cap); } /* * Set parent pointer to point to chosen closure. If we're at the top of * the graph (our parent is NULL), then we want to arrange to return the * chosen closure to our caller (possibly in place of the allocated graph * root.) */ if (parent == NULL) { /* we are at the root. Do not remove the tag here (old code did)! */ // graphroot = UNTAG_CLOSURE(closure); graphroot = closureT; IF_PAR_DEBUG(pack, debugBelch("Graph root %x, with tag %x", closureT, GET_CLOSURE_TAG(closureT))); } else { if (RtsFlags.ParFlags.globalising==0) { // Eden-style RTS // if we restored the queue, we must update temporary blackholes // instead of just writing a pointer into the parent StgClosure* childP = (StgClosure*) ((StgPtr) parent)[HEADERSIZE + pvhs + pptr]; if (childP && // perhaps invalid ptr IsBlackhole(childP)) { // We will not hit a "tagged" childP here, it is always a BH created by us. SORT_OF_SAFE_UPD_IND(childP, closureT); // UPD_IND(childP, closureT); } else { ((StgPtr) parent)[HEADERSIZE + pvhs + pptr] = (StgWord) closureT; } } else { // GUM version ASSERT(RtsFlags.ParFlags.globalising>0); // should only be executed in GUM-style RTS ((StgPtr) parent)[HEADERSIZE + pvhs + pptr] = (StgWord) closureT; } } // store closure for offsets, (special var. for offsets to other packets) if (!((StgWord) *slotptr == OFFSET || (StgWord) *slotptr == PLC )) { // HWL CHECK: do we need a special check for static closures? // avoid duplicate entries for static closures or indirections // HEAP_ALLOCED(closure)) { IF_PAR_DEBUG(pack, debugBelch("---> Entry in Offset Table: (%d, %p)\n", currentOffset, UNTAG_CLOSURE(closureT))); /* note that we store the address WITH TAG here! */ insertHashTable(offsetTable, currentOffset, (void*) closureT); } /* Locate next parent pointer */ IF_PAR_DEBUG(pack, if (*main_bufptr==END_OF_BUFFER_MARKER) { debugBelch(".. seen END_OF_BUFFER_MARKER %x @ %x while unpacking\n",*main_bufptr,main_bufptr);};); /* Locate next parent pointer */ LocateNextParent(&parent, &pptr, &pptrs, &pvhs); // stop when buffer size has been reached or end of graph } while ((parent != NULL) && (bufsize > (nat) (bufptr-(packBuffer->buffer)))); if (parent != NULL) { // prepare all for next part if graph not complete StgClosure* tempBH; StgPtr childP; IF_PAR_DEBUG(packet, debugBelch("bufptr - (packBuffer->buffer) = %d, bufsize = %d, parent = %p\n", (nat) (bufptr-(packBuffer->buffer)), bufsize, parent); debugBelch("Queue not empty, packet entirely unpacked.\n" "Expecting rest on same inport.\n")); ASSERT(RtsFlags.ParFlags.globalising==0); // should only be executed in Eden-style RTS offsetpadding += bufsize; // to save it in unpackState... unpackState = saveUnpackState(graphroot, parent, pptr, pptrs, pvhs);// also saves queue and offsets/padding // TODO // inport->unpackState = unpackState; // set field in inport (implies "pendingMsg" inport state) // Eden only // queue has been saved, now fill in temporary QueueMe closures (destroying queue and unpack state) while (parent != NULL) { // it can be that there are already QMs hanging on the queued parent closures (restored queue) // in this case, we do not create new QMs (possibly already blocked TSOs) childP = (StgPtr) ((StgPtr) parent)[HEADERSIZE + pvhs + pptr]; if (childP == NULL) { // invalid ptr, was set to NULL when filling in a new closure tempBH = createBH(rtsFalse/*RBH?*/, (Capability *) NULL); ((StgPtr)parent)[HEADERSIZE + pvhs + pptr] = (StgWord) tempBH; IF_PAR_DEBUG(packet, debugBelch("Inserted temporary QueueMe child at %p in parent closure %p.\n", tempBH, parent)); } else { ASSERT(IsBlackhole((StgClosure*) childP)); } LocateNextParent(&parent, &pptr, &pptrs, &pvhs); // until the queue is empty and the last parent filled } // while } else { /* PARENT == NULL: whole graph has arrived, offset table can be dropped */ freeHashTable(offsetTable, NULL); offsetTable = NULL; } IF_PAR_DEBUG(pack, debugBelch("Packing: Unpacking done. \n")); IF_PAR_DEBUG(pack, { char fingerPrintStr[MAX_FINGER_PRINT_LEN]; GraphFingerPrint(graphroot, fingerPrintStr); debugBelch(">>> Fingerprint of graph rooted at %p (after unpacking <<%ld>>:\n" "\t{%s}\n", graphroot, (long)packBuffer->id, fingerPrintStr);};); /* check for magic end-of-buffer word (+ increment bufptr */ IF_DEBUG(sanity, ASSERT(*(bufptr++) == END_OF_BUFFER_MARKER)); /* we unpacked exactly as many words as there are in the buffer */ ASSERT(bufsize == (nat) (bufptr-(packBuffer->buffer))); /* we filled no more heap closure than we allocated at the beginning; ideally this should be a ==; NB: test is only valid if we unpacked anything at all (graphroot might end up to be a PLC!), therefore the strange test for HEAP_ALLOCED */ /* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */ ASSERT(graphroot!=NULL); // TODO: enable this code ASSERT(PendingGABuffer!=(globalAddr *)NULL); *gamap = PendingGABuffer; *nGAs = (gaga - PendingGABuffer)/2; // TODO: check this Hans MKA // TODO: update tag-names IF_PAR_DEBUG(tables, debugBelch("** LAGA table after unpacking closure %p:", graphroot); printLAGAtable()); IF_DEBUG(sanity, { StgPtr p; /* check the unpacked graph */ // HWL TODO: enable sanity check // checkHeapChunk(graphroot, UNTAG_CLOSURE(closureT)); // graph-sizeof(StgWord)); // debugBelch(".. unpacked graph @ %p sanity checked OK\n", graphroot); // if we do sanity checks, then wipe the pack buffer after unpacking for (p=(StgPtr)packBuffer->buffer; p<(StgPtr)(packBuffer->buffer)+(packBuffer->size); ) *p++ = 0xdeadbeef; }); IF_DEBUG(sanity, check_IND_cycle(graphroot)); #if defined(PAR_TICKY) PAR_TICKY_UNPACK_GRAPH_END(unpacked_closures, unpacked_thunks); totPackets++; // totUnpacked+=packBuffer->size; #endif IF_PAR_DEBUG(pack, IF_PAR_DEBUG(packet, PrintGraph(graphroot,0))); // IF_DEBUG(sanity, PrintGraph(graphroot, 0)); /* reset the global variable */ globalUnpackBuffer = (rtsPackBuffer*)NULL; return (graphroot); } //@cindex UnpackGA STATIC_INLINE void UnpackGA(StgWord *bufptr, globalAddr *ga) // doesn't move ptr anymore { if (ga->weight >= 0) { // ALWAYS!! marker-check is done in top unpack-loop (UnpackGraph) ga->weight = (rtsWeight) *(bufptr); ga->pe = (nat) *(bufptr+1); ga->slot = (nat) *(bufptr+2); ASSERT(LOOKS_LIKE_GA(ga)); /* TODO: this should be the right order; CHECK!! ga->pe = (nat) *(bufptr); ga->slot = (int) *(bufptr+1); ga->weight = (rtsWeight) *(bufptr+2); */ } // if it's not a GA, don't do anything here; UnpackClosure will unpack PLC or OFFSETUnpackGra } /* Find the next pointer field in the parent closure, retrieve information about its variable header size and no. of pointers. If the current parent has been completely unpacked already, get the next closure from the global closure queue, and register the new variable header size and no. of pointers. Example situation: *parentP | V +--------------------------------------------------------------------+ |hdr| variable hdr | ptr1 | ptr2 | ptr3 | ... | ptrN | non-pointers | +--------------------------------------------------------------------+ <--- *vhsP=2 ---> A | *pptrs = N *pptr=3 */ //@cindex LocateNextParent STATIC_INLINE void LocateNextParent(parentP, pptrP, pptrsP, pvhsP) StgClosure **parentP; nat *pptrP, *pptrsP, *pvhsP; { StgInfoTable *ip; // debugging nat size, nonptrs; /* pptr as an index into the current parent; find the next pointer field in the parent by increasing pptr; if that takes us off the closure (i.e. *pptr + 1 > *pptrs) grab a new parent from the closure queue */ (*pptrP)++; while (*pptrP + 1 > *pptrsP) { /* *parentP has been constructed (all pointer set); so check it now */ IF_DEBUG(sanity, if (*parentP != (StgClosure*)NULL) // not root checkClosure(*parentP)); *parentP = DeQueueClosure(); if (*parentP == NULL) break; else { ip = get_closure_info(*parentP, &size, pptrsP, &nonptrs, pvhsP); *pptrP = 0; } } /* *parentP points to the new (or old) parent; */ /* *pptr, *vhsP, and *pptrs have been updated referring to the new parent */ } /* UnpackClosure is the heart of the unpacking routine. It is called for every closure found in the packBuffer. Any prefix such as GA, PLC marker etc has been unpacked into the *ga structure. UnpackClosure does the following: - check for the kind of the closure (PLC, Offset, std closure) - copy the contents of the closure from the buffer into the heap - update LAGA tables (in particular if we end up with 2 closures having the same GA, we make one an indirection to the other) - set the GAGA map in order to send back an ACK message At the end of this function, *bufptrP points to the next word in the pack buffer to be unpacked. "pointer tagging": When unpacking, UnpackClosure() we add the tag to its return value, but enqueue the closure address WITHOUT A TAG, so we can access the unpacked closure directly by the enqueued pointer. The closure WITH TAG is saved as offset value in the offset hash table (key=offset, value=address WITH TAG), to be filled in other closures as a pointer field. When packing, we did the reverse: saved the closure address WITH TAG in the queue, but stored it WITHOUT TAG in the offset table (as a key, value was the offset). */ STATIC_INLINE StgClosure* UnpackClosure (StgWord **bufptrP, Capability* cap) { // StgWord **main_bufptr, **new_bufptr, **tmp_bufptr; globalAddr gaS; StgClosure *graph; StgClosure *closure; nat size,ptrs,nonptrs,vhs,i; StgInfoTable *info, *infoT; char name[80]; // remove and store the tag added to the info pointer, // before doing anything else! StgWord tag=0; // ptr to the TAG field in the current closure StgWord *slotptr; /* Now unpack the closure body, if there is one; three cases: - PLC: closure is just a pointer to a static closure - OFFSET: closure has been unpacked already - CLOSURE: a constructor or unglobalised thunk; a full closure starts right after the marker Assertions checking closure types etc are in the Unpack... routines. */ slotptr = *bufptrP; if (isFixed(slotptr)) { closure = UnpackPLC(slotptr); (*bufptrP)++; // skip marker (*bufptrP)++; // skip PLC return TAG_CLOSURE(tag,closure); } else if (isOffset(slotptr)) { closure = UnpackOffset(slotptr); // tag comes from offset-table/packet (*bufptrP)++; // skip marker (*bufptrP)++; // skip offset return TAG_CLOSURE(tag,closure); } else if (isNotGlobal(slotptr)) { (*bufptrP)++; // skip marker } else { // GA plus closure /* fill in gaS from buffer */ UnpackGA(*bufptrP, /*out*/&gaS); // bufptrP does not move here! (*bufptrP)++; // skip GA (*bufptrP)++; // skip GA (*bufptrP)++; // skip GA } /* remove and store the tag added to the info pointer. (*bufptrP) points to a packed closure, first word has been tagged before packing, we read and remove the tag before doing anything! We get the tag from the info-pointer in the packet. */ infoT = **bufptrP; tag = GET_CLOSURE_TAG((StgClosure*) infoT); **bufptrP = UNTAG_CAST(StgWord, infoT); /* HWL TODO: add specific tag-sanity-checks IF_PAR_DEBUG(packet, debugBelch("pointer tagging: removed tag %d " "from info pointer %p in packet\n", (int) tag, (void*) **bufptrP)); */ /* ************************************************************* The essential part: Here, we allocate heap space, fill in the closure and queue it to get the pointer payload filled later. Formerly get_req_heap_space + FillInClosure + QueueClosure, with an additional size check, now merged in order to be more flexible with the order of actions. */ ASSERT(LOOKS_LIKE_INFO_PTR((StgWord) ((StgClosure*)*bufptrP)->header.info)); /* * Close your eyes. You don't want to see where we're * looking. You can't get closure info until you've unpacked the * variable header, but you don't know how big it is until you've * got closure info. So...we trust that the closure in the buffer * is organized the same way as they will be in the heap...at * least up through the end of the variable header. */ info = get_closure_info((StgClosure *) *bufptrP, &size, &ptrs, &nonptrs, &vhs); // name = info_type_by_ip(info); switch (info->type) { // branch into new special routines: case PAP: case AP: closure = UnpackPAP(info, bufptrP, cap); // returns a un-tagged pointer /* see below, might create/enQ some INDs */ break; case ARR_WORDS: case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN0: case MUT_ARR_PTRS_FROZEN: // not needed... could also tweak get_closure_info closure = UnpackArray(info, bufptrP, cap); // returns a un-tagged pointer break; /* other special cases will go here... */ case AP_STACK: // TODO: check whether that's the same as AP case barf("Unpack: found AP_STACK"); case FETCH_ME: case REMOTE_REF: // ASSERT(size>=HEADERSIZE+MIN_UPD_SIZE); // size of the FM in the heap /* IF_PAR_DEBUG(packet, debugBelch("*>== Allocating %d heap words for %s-closure:\n" "(%d ptrs, %d non-ptrs, vhs = %d)\n" , size, "???", // name, ptrs, nonptrs, vhs)); */ /* HWL TODO: check (here and below) whether this is safe if (cap!=NULL) { closure = (StgClosure*) allocateLocal(cap, size); } else { closure = (StgClosure*) allocate(size); } */ closure = (StgClosure*) allocate(size); return TAG_CLOSURE(tag,UnpackFetchMe(bufptrP, &closure)); default: /* the pointers-first layout */ /* IF_PAR_DEBUG(packet, debugBelch("Allocating %d heap words for %s-closure:\n" "(%d ptrs, %d non-ptrs, vhs = %d)\n" , size, info_type_by_ip(info), ptrs, nonptrs, vhs)); */ closure = (StgClosure*) allocate(size); /* Remember, the generic closure layout is as follows: +-------------------------------------------------+ | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS | +-------------------------------------------------+ */ /* Fill in the fixed header */ for (i = 0; i < HEADERSIZE; i++) ((StgPtr)closure)[i] =(StgWord) *(*bufptrP)++; /* Fill in the packed variable header */ for (i = 0; i < vhs; i++) ((StgPtr)closure)[HEADERSIZE + i] = (StgWord)*(*bufptrP)++; /* Pointers will be filled in later, but set zero here to easily check if there is a temporary BH. */ for (i = 0; i < ptrs; i++) ((StgPtr)closure)[HEADERSIZE + vhs + i] = 0; /* Fill in the packed non-pointers */ for (i = 0; i < nonptrs; i++) ((StgPtr)closure)[HEADERSIZE + i + vhs + ptrs] = (StgWord) *(*bufptrP)++; ASSERT(HEADERSIZE+vhs+ptrs+nonptrs == size); /* if it is unglobalised, it may not be a thunk!! */ // ToDo: re-enable: ASSERT(IMPLIES(hasGA, closure_THUNK(closure)));QueueClosure(closure); QueueClosure(closure); } // switch(ip->type) return TAG_CLOSURE(tag,closure); } /*static*/ StgClosure * UnpackPAP(StgInfoTable *info, StgWord **bufptrP, Capability* cap) { StgPAP *pap; nat args, size, hsize, i; #if defined(DEBUG) // for "manual sanity check" with debug flag "packet" only StgWord bitmap = 0; #endif /* Unpacking a PAP/AP * * in the buffer: * +----------------------------------------------------------------+ * | Header | (arity , n_args) | Tag | Arg/Tag | Tag | Arg/Tag | ...| * +----------------------------------------------------------------+ * * Header size is 1 (normal) for PAP or 2 StgWords (Thunk Header) for AP. * Tag is PLC or CLOSURE constant, repeated if it is CLOSURE, * followed by the arg otherwise. Unpacking creates indirections and * inserts references to them when tag CLOSURE is found, otherwise * just unpacks the arg. * * should give in the heap: * +---------------------------------------------------------------+ * | Header | (arity , n_args) | Fct. | Arg/&Ind1 | Arg/&Ind2 | ...| * +---------------------------------------------------------------+ * followed by <= n_args indirections pointed at from the stack */ /* calc./alloc. needed closure space in the heap. * We are using the common macros provided. */ switch (info->type) { case PAP: hsize = HEADERSIZE + 1; args = ((StgPAP*) *bufptrP)->n_args; size = PAP_sizeW(args); break; case AP: hsize = sizeofW(StgThunkHeader) + 1; args = ((StgAP*) *bufptrP)->n_args; size = AP_sizeW(args); break; /* case AP_STACK: hsize = sizeofW(StgThunkHeader)+1; args = ((StgAP_STACK*) *bufptrP)->size; size = AP_STACK_sizeW(args); break; */ default: barf("UnpackPAP: strange info pointer, type %d ", info->type); } IF_PAR_DEBUG(packet, debugBelch("allocating %d heap words for a PAP(%d args)\n", size, args)); pap = (StgPAP *) allocate(size); /* fill in sort-of-header fields (real header and (arity,n_args)) */ for(i=0; i < hsize; i++) { ((StgPtr) pap)[i] = (StgWord) *(*bufptrP)++; } // enqueue to get function field filled (see get_closure_info) QueueClosure((StgClosure*) pap); // zero out the function field (for BH check in UnpackGraph) pap->fun = (StgClosure*) 0; // unpack the stack (size == args), starting at pap[hsize] // make room for fct. pointer, thus start at hsize+1 for(i=hsize+1; i < size; i++) { StgClosure* ind; switch((long) **bufptrP) { case PLC: // skip marker, unpack data into stack (*bufptrP)++; ((StgPtr) pap)[i] = (StgWord) *(*bufptrP)++; IF_PAR_DEBUG(packet, bitmap |= 1); // set bit in bitmap break; case CLOSURE: // skip 2 markers, create/enqueue indirection, put it on the stack (*bufptrP)+=2; ind = (StgClosure*) allocate(sizeofW(StgInd)); SET_HDR(ind, &stg_IND_info, CCS_SYSTEM); // ccs to be checked... ((StgInd*)ind)->indirectee = 0; // for BH-check in UnpackGraph ((StgPtr) pap)[i] = (StgWord) ind; QueueClosure(ind); break; default: barf("UnpackPAP: strange tag %d, should be %d or %d.", **bufptrP, PLC, CLOSURE); } IF_PAR_DEBUG(packet, bitmap = bitmap << 1); // shift to next bit } IF_PAR_DEBUG(packet, debugBelch("unpacked a %s @ address %p\n", info_type((StgClosure*) pap),pap)); return (StgClosure*) pap; } /*static*/ StgClosure* UnpackArray(StgInfoTable* info, StgWord **bufptrP, Capability* cap) { nat size; StgMutArrPtrs *array; // can also be StgArrWords, but fields not // used in this case. /* * We have to distinguish pointer arrays from word arrays. In the * case of pointers, we enqueue the unpacked closure for filling in * pointers, otherwise we just unpack the words (doing a memcpy). * * Since GHC-6.13, ptr arrays additionally carry a "card table" for * generational GC (to indicate mutable/dirty elements). For * unpacking, allocate the card table and fill it with zero. * * With this change, probably split into two methods?? */ switch(info->type) { case ARR_WORDS: /* Array layout in heap and buffer is the following: * +-----------------------------------------------------+ * | Header | size | word1 | word2 | ... | word_(size) | * +-----------------------------------------------------+ * * but we better read the additional size to allocate from the struct field */ size = sizeofW(StgArrWords) + ((StgArrWords*) *bufptrP)->words; IF_PAR_DEBUG(packet, debugBelch("Unpacking word array, size %d\n", size)); array = (StgMutArrPtrs *) allocate(size); /* copy header and payload words in one go */ memcpy(array, *bufptrP, size*sizeof(StgWord)); *bufptrP += size; /* for(i = 0; i < size; i++) ((StgPtr) array)[i] = (StgWord) *(*bufptrP)++; */ break; case MUT_ARR_PTRS_CLEAN: case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN0: case MUT_ARR_PTRS_FROZEN: /* Array layout in buffer: * +----------------------+......................................+ * | Header | ptrs | size | ptr1 | ptr2 | .. | ptrN | card space | * +----------------------+......................................+ * (added in heap when unpacking) * ptrs indicates how many pointers to come (N). Size field gives * total size for pointers and card table behind (to add). */ // size = sizeofW(StgMutArrPtrs) + (StgWord) *((*bufptrP)+2); size = closure_sizeW((StgClosure*) *bufptrP); ASSERT(size == sizeofW(StgMutArrPtrs) + ((StgMutArrPtrs*) *bufptrP)->size); IF_PAR_DEBUG(packet, debugBelch("Unpacking ptrs array, %ld ptrs, size %d\n", (StgWord) *((*bufptrP)+1), size)); array = (StgMutArrPtrs *) allocate(size); // set area 0 (Blackhole-test in unpacking and card table) memset(array, 0, size*sizeof(StgWord)); /* write header and enqueue it, pointers will be filled in */ for (size=0;size<(sizeof(StgMutArrPtrs)/sizeof(StgWord)); size++) ((StgPtr) array)[size] = (StgWord) *(*bufptrP)++; QueueClosure((StgClosure*)array); break; default: barf("UnpackArray: unexpected closure type %d", info->type); } IF_PAR_DEBUG(packet, debugBelch(" Array created @ %p.\n",array)); return (StgClosure*) array; } /* FETCH_MEs and friends are slightly special. Fill in only the header; it has no nonptrs; the ga field of the FETCH_ME is filled in in SetGAandCommonUp This is embarrasingly simple for a function; but after another late night debugging session and with a couple of grey hair more I am rather paranoid. */ STATIC_INLINE StgClosure * UnpackFetchMe(StgWord **bufptrP, StgClosure **graphP) { nat i; StgClosure *unpacked_closure = *graphP; /* We only have a fixed header in a FETCH_ME */ ASSERT(HEADERSIZE == 1); for (i = 0; i < HEADERSIZE; i++) *((StgWord*)*graphP+i) = *(*bufptrP)++; *graphP += sizeofW(StgFetchMe); return unpacked_closure; } //@cindex UnpackPLC STATIC_INLINE StgClosure * UnpackPLC(StgWord *ptr) { StgClosure* plc; ASSERT(isFixed(ptr)); plc = (StgClosure*)*(ptr+1); ASSERT(closure_STATIC(plc)); // check that what follows is a static closure IF_PAR_DEBUG(packet, debugBelch("*<__ Unpacked PLC %p", plc)); return plc; } //@cindex UnpackOffset STATIC_INLINE StgClosure * UnpackOffset(StgWord *ptr) { StgClosure* existingT; int offset; ASSERT(isOffset(ptr)); offset = (nat) *(ptr+1); // (nat) ga->slot; // find this closure in an offset hashtable (we can have several packets) existingT = (StgClosure *) lookupHashTable(offsetTable, offset); IF_PAR_DEBUG(packet, debugBelch("*<__ Unpacked indirection to closure %p (was OFFSET %d, current padding %d)", existingT, offset, offsetpadding)); // we should have found something... ASSERT(existingT); return existingT; } //@node Managing packing state (Eden), Packing wrappers, Main unpacking functions //@section Managing packing state (Eden) /* functions to save and restore the unpacking state from a * saved format (including queue and offset table). * Format is defined as type "UnpackInfo". */ static StgClosure* restoreUnpackState(UnpackInfo* unpack,StgClosure** graphroot, nat* pptr, nat* pptrs, nat* pvhs) { nat size, i; StgClosure* parent; IF_PAR_DEBUG(pack, debugBelch("restore unpack state")); ASSERT(unpack != NULL); parent = unpack->parent; *pptr = unpack->pptr; *pptrs = unpack->pptrs; *pvhs = unpack->pvhs; *graphroot = unpack->graphroot; size = unpack->queue_length; for (i = 0; i < size; i++) // if no queue (size == 0): no action. QueueClosure(*(unpack->queue + i)); // if we restore an unpack state, we use an existing hashtable: freeHashTable(offsetTable, NULL); offsetTable = (HashTable *) unpack->offsets; offsetpadding = unpack->offsetpadding; // free allocated memory: stgFree(unpack->queue); stgFree(unpack); IF_PAR_DEBUG(pack, debugBelch("unpack state restored (graphroot: %p, current " "parent: %p (ptr %d of %d, vhs= %d, offset %d).", *graphroot, parent, *pptr, *pptrs, *pvhs, offsetpadding)); return parent; } static StgClosure** saveQueue(nat* size) { StgClosure** queue; // closures are saved as StgPtr in the queue... ASSERT(clq_pos <= clq_size); // we want to have a positive size *size = clq_size - clq_pos; if (*size == 0) return NULL; // no queue to save // queue to save: IF_PAR_DEBUG(packet, debugBelch("saveQueue: saving "); PrintClosureQueue()); queue = (StgClosure **) stgMallocBytes(*size * sizeof(StgClosure*), "saveQueue: Queue"); memcpy(queue, ClosureQueue+clq_pos, *size * sizeof(StgClosure*)); IF_PAR_DEBUG(packet, { nat j; debugBelch("saveQueue: saved this queue:\n"); for (j = 0; j < *size; j++) debugBelch("\tClosure %d: %p\n",*size - j,queue[j]); }); return queue; } static UnpackInfo* saveUnpackState(StgClosure* graphroot, StgClosure* parent, nat pptr, nat pptrs, nat pvhs) { UnpackInfo* save; nat size; save = stgMallocBytes(sizeof(UnpackInfo),"saveUnpackState: UnpackInfo"); IF_PAR_DEBUG(pack, debugBelch("saving current unpack state at %p",save); debugBelch("graphroot: %p, current parent: %p (ptr %d of %d, vhs= %d)", graphroot, parent, pptr, pptrs, pvhs)); // simple tasks: save numbers save->parent = parent; save->pptr = pptr; save->pptrs = pptrs; save->pvhs = pvhs; save->graphroot = graphroot; // complicated tasks: save queue and offset table save->queue = saveQueue(&size); save->queue_length = size; save->offsetpadding = offsetpadding; // padding for keys in offsetTable save->offsets = offsetTable; // hashtable remains allocated IF_PAR_DEBUG(pack, debugBelch("unpack state saved (offsetpadding %d in " "hashtable at %p, %d closures in queue at %p).", save->offsetpadding, save->offsets, save->queue_length, save->queue)); return save; } /* Experimental feature: serialisation into a Haskell Byte Array and * respective deserialisation. * */ //@node Packing wrappers, Conversion Functions, Managing packing state (Eden) //@section Packing wrappers // pack, then copy the buffer into newly (Haskell-)allocated space // (unless packing was blocked, in which case we return NULL StgClosure* PackToMemory(StgClosure* graphroot, StgTSO* tso, Capability* cap) { rtsPackBuffer* buffer; StgArrWords* wordArray; // Port noPort = (Port) {0,0,0}; buffer = PackNearbyGraph(graphroot, tso, 0); if (buffer == NULL) { // packing hit a black hole, return NULL to caller. return NULL; } /* allocate space to hold an array (size in words, like buffer size) +---------+----------+------------------------+ |ARR_WORDS| n_words | data (array of words) | +---------+----------+------------------------+ */ wordArray = (StgArrWords*) allocateLocal(cap, 2 + buffer->size); SET_HDR(wordArray, &stg_ARR_WORDS_info, CCS_SYSTEM); // ccs to be checked! wordArray->words = buffer->size; memcpy((void*) &(wordArray->payload), (void*) (buffer->buffer), (buffer->size)*sizeof(StgWord)); return ((StgClosure*) wordArray); } // unpacking from a Haskell array (note we are using the pack buffer) StgClosure* UnpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap) { Port noPort = (Port) {0,0,0}; StgClosure* newGraph; // for wrapping UnpackGraph // extern globalAddr *PendingGABuffer; globalAddr *gamap = NULL; nat nGAs; InitPackBuffer(); // allocate, if not done yet // set the fields straight... globalPackBuffer->sender = globalPackBuffer->receiver = noPort; globalPackBuffer->id = -1; globalPackBuffer->size = packBufferArray->words; globalPackBuffer->unpacked_size = -1; // copy the data into the buffer memcpy((void*) &(globalPackBuffer->buffer), (void*) packBufferArray->payload, (globalPackBuffer->size)* sizeof(StgWord)); // HWL TODO: use UnpackGraphWrapper // allocate buffers InitPendingGABuffer(RtsFlags.ParFlags.packBufferSize); gamap = PendingGABuffer; // unpack the graph newGraph = UnpackGraph(globalPackBuffer, &gamap, &nGAs, noPort, cap); return newGraph; } // --------------------------------------------------------------------------- //@node Conversion Functions, Closure conversion functions (GUM), Packing wrappers //@section Conversion Functions //@node Closure conversion functions (GUM), Debugging functions, Conversion Functions //@section Closure conversion functions (GUM) /* Note: in GUM 4.xx this used to be in RBH.c. -- HWL GUM6 For now, in GUM6 this implements NON-REVERTIBLE black HOLES!!!!!!!!!!!!!!!! We only update the info pointer, and take no measures to be able to revert the closure to its original state. Thus, if communication fails, and a SCHEDULE message is not answered with an ACK message, the whole computation will fail. -- HWL GUM6 */ /* Note: in GUM 4.xx this used to be in RBH.c. -- HWL GUM6 For now, in GUM6 this implements NON-REVERTIBLE black HOLES!!!!!!!!!!!!!!!! We only update the info pointer, and take no measures to be able to revert the closure to its original state. Thus, if communication fails, and a SCHEDULE message is not answered with an ACK message, the whole computation will fail. -- HWL GUM6 */ /* A closure is turned into an RBH upon packing it (see PackClosure in Pack.c). This is needed in case we have to do a GC before the packet is turned into a graph on the PE receiving the packet. NB: this function is not tag-safe */ //@cindex convertToRBH StgClosure * convertToRBH(closure) StgClosure *closure; { StgInfoTable *info_ptr, *rbh_info_ptr, *old_info; /* Closure layout before this routine runs amuck: +------------------- | HEADER | DATA ... +------------------- | FIXEDHEADERSIZE | */ /* Turn closure into an RBH. This is done by modifying the info_ptr, grabbing the info_ptr of the RBH for this closure out of its ITBL. Additionally, we have to save the words from the closure, which will hold the link to the blocking queue. For this purpose we use the RBH_Save_N closures, with N being the number of pointers for this closure. */ IF_PAR_DEBUG(pack, debugBelch("*>:: %p (%s): Converting closure into an RBH\n", closure, info_type(closure))); // with RtsFlags.ParFlags.globalising==1 we globalise only thunks ASSERT(RtsFlags.ParFlags.globalising!=1 || shouldGlobalise(closure)); SET_HDR(closure, &stg_RBH_info, CCS_SYSTEM); // ccs to be checked! return closure; } /* An RBH closure is turned into a FETCH_ME when reveiving an ACK message indicating that the transferred closure has been unpacked on the other PE (see processAck in HLComms.c). The ACK also contains the new GA of the closure to which the FETCH_ME closure has to point. Converting a closure to a FetchMe is trivial, unless the closure has acquired a blocking queue. If that has happened, we first have to awaken the blocking queue. What a nuisance! Fortunately, @AwakenBlockingQueue@ should now know what to do. A note on GrAnSim: In GrAnSim we don't have FetchMe closures. However, we have to turn a RBH back to its original form when the simulated transfer of the closure has been finished. Therefore we need the @convertFromRBH@ routine below. After converting the RBH back to its original form and awakening all TSOs, the first TSO will reenter the closure which is now local and carry on merrily reducing it (the other TSO will be less merrily blocked on the now local closure; we're costing the difference between local and global blocks in the BQ code). -- HWL */ //@cindex convertToFetchMe void convertToFetchMe(rbh, ga) StgRBH *rbh; globalAddr *ga; { // StgInfoTable *ip = get_itbl(rbh); // StgBlockingQueueElement *bqe = rbh->blocking_queue; ASSERT(get_itbl(rbh)->type==RBH); IF_PAR_DEBUG(weight, { char str0[MAX_GA_STR_LEN]; showGA(ga, str0); debugBelch("**:: Converting RBH %p (%s) into a FETCH_ME for GA %s\n", rbh, info_type((StgClosure*)rbh), str0);};); /* put closure on mutables list, while it is still a RBH */ // recordMutable((StgMutClosure *)rbh); /* actually turn it into a FETCH_ME */ SET_INFO((StgClosure *)rbh, &stg_FETCH_ME_info); //mustafa /* set the global pointer in the FETCH_ME closure to the given value */ ((StgFetchMe *)rbh)->ga = ga; /* IF_PAR_DEBUG(pack, if (get_itbl(bqe)->type==TSO || get_itbl(bqe)->type==BLOCKED_FETCH) debugBelch("**:: Awakening non-empty BQ of RBH closure %p (first TSO is %d (%p)", rbh, ((StgTSO *)bqe)->id, ((StgTSO *)bqe))); */ /* we don't need to awaken anything now; next time checkBlackholes is run, TSOs previously blocked on this closure will wake up and send a message, then block again, now on the FM rather than the RBH, and wait for the data to arrive -- HWL GUM6 */ // if (get_itbl(bqe)->type==TSO || get_itbl(bqe)->type==BLOCKED_FETCH) // awakenBlockedQueue(bqe, (StgClosure *)rbh); } //@node Debugging functions, Sanity checks, Closure conversion functions (GUM) //@section Debugging functions // debugging functions now in ParallelDebug.c //@node Sanity checks, debugging functions, Debugging functions //@section Sanity checks void checkPacket(rtsPackBuffer *packBuffer ) { StgWord *bufptr, *slotptr; Port inPort; Capability* cap; StgClosure *closureT, *graphroot, *parent; nat size, heapsize, bufsize, pptr= 0, pptrs= 0, pvhs= 0; nat unpacked_closures= 0, unpacked_thunks= 0; // stats only // GUM only StgWord **main_bufptr, **new_bufptr, **tmp_bufptr, **tmp_plc ; globalAddr gaS; StgClosure *graph; /* to save and restore the unpack state (future use...) */ UnpackInfo *unpackState = NULL; nat currentOffset; char str[1024]; // debugging only StgInfoTable *ip; // debugging only nat ptrs, nonptrs, vhs; // debugging only ASSERT(packBuffer != NULL); /* Initialisation */ InitPacking(rtsTrue); // same as in PackNearbyGraph graphroot = (StgClosure *)NULL; //globalUnpackBuffer = packBuffer; // -- HWL GUM6EDEN /* Unpack the header */ bufsize = packBuffer->size; heapsize = packBuffer->unpacked_size; bufptr = packBuffer->buffer; main_bufptr = packBuffer->buffer; tmp_plc = packBuffer->buffer; IF_PAR_DEBUG(pack, debugBelch("Packing: check Header unpacked. (bufsize=%d, heapsize=%d)\n" "Unpacking closures check packet function now...\n", bufsize, heapsize)); /* starting point */ //bufptr = packBuffer->buffer; // check if an incomplete subgraph is pending for this inport // if there is any, we should unpack a PART Message here. // we remembered state from previous receive in a sequence thereof /* TODO! Inport* inport = findInportByP(inPort); unpackState = inport->unpackState; inport->unpackState = NULL; // invalidate, will be deallocated! */ /*if (unpackState!=NULL) { IF_PAR_DEBUG(pack, debugBelch("Unpack state found, partial message on inport %d.\n", (int)inPort.id)); // restore data for unpacking: inverse analogon to saveUnpackState(...) parent = restoreUnpackState(unpackState, &graphroot, &pptr, &pptrs, &pvhs); } else { IF_PAR_DEBUG(pack, debugBelch("Unpack state not found, normal message on inport %d\n.", (int)inPort.id)); parent = (StgClosure *) NULL; } */ do { /* check that we aren't at the end of the buffer, yet */ IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER)); /* This is where we will ultimately save the closure's address */ tmp_bufptr = main_bufptr; // GUM only /* pointer to the type marker (Offset, PLC, or Closure) */ slotptr = bufptr; //currentOffset = (offsetpadding /* ...which is at least 1! */ // + ((nat) (bufptr - (packBuffer->buffer)))); IF_PAR_DEBUG(pack, debugBelch("Unpack: TAG=%d\n", *slotptr)); /* this allocates heap space, checks for PLC/offset etc * The "pointer tag" found at sender side is added * inside this routine, nothing special to do here. */ // closureT = UnpackClosure (/*in/out*/&bufptr, cap); // TAGGED slotptr = tmp_plc; if (isFixed(slotptr)) { closureT = UnpackPLC(slotptr); (*tmp_plc)++; // skip marker (*tmp_plc)++; // skip PLC IF_PAR_DEBUG(pack, debugBelch("Unpack: PLC OK \n")); //return TAG_CLOSURE(tag,closureT); } else if (isOffset(slotptr)) { closureT = UnpackOffset(slotptr); // tag comes from offset-table/packet (*tmp_plc)++; // skip marker (*tmp_plc)++; // skip offset IF_PAR_DEBUG(pack, debugBelch("Unpack: Offset OK \n")); //return TAG_CLOSURE(tag,closureT); } else if (isNotGlobal(slotptr)) { (*tmp_plc)++; // skip marker } else { // GA plus closure /* fill in gaS from buffer */ UnpackGA(tmp_plc, /*out*/&gaS); // bufptrP does not move here! IF_PAR_DEBUG(pack, debugBelch("Unpack: Gala weight = %d \nGala pe = %d\nGala slot=%d\n ",(long) gaS.weight,(nat) gaS.pe, (nat) gaS.slot )); ASSERT(LOOKS_LIKE_GA(&gaS)); (*tmp_plc)++; // skip GA (*tmp_plc)++; // skip GA (*tmp_plc)++; // skip GA } //unpacked_closures++; // stats only // TODO: add this for stats // unpacked_thunks += (closure_THUNK(UNTAG_CLOSURE(closureT))) ? 1 : 0; // stats only /* now we actually have a closure in the buffer */ main_bufptr = main_bufptr+3; ASSERT(LOOKS_LIKE_CLOSURE_PTR((StgClosure*)main_bufptr)); //main_bufptr = main_bufptr+3; ip = get_closure_info((StgClosure*)main_bufptr,&size,&ptrs ,&nonptrs,&vhs); /* ToDo: check whether this is really needed */ if (ip->type == FETCH_ME || ip->type == REMOTE_REF) { size = HEADERSIZE; ptrs = nonptrs = vhs = 0; } /* ToDo: check whether this is really needed */ if (ip->type == ARR_WORDS) { ptrs = vhs = 0; nonptrs = ((StgArrWords *)main_bufptr)->words+1; // payload+words size = arr_words_sizeW((StgArrWords *)main_bufptr); ASSERT(size==HEADERSIZE+vhs+nonptrs); } /* special code for printing a PAP in a buffer */ if (ip->type == PAP || ip->type == AP || ip->type == AP_STACK) { /* NB: the pap->fun field (1 word) expands to a FetchMe in pack buffer */ vhs = 2; ptrs = 0; /* NB: the size of the payload is included as this pos in the buffer */ nonptrs = *(main_bufptr+HEADERSIZE+1); /* 1 for this size field itself */ size = HEADERSIZE+vhs+nonptrs; } /* no checks on contents of closure (pointers aren't packed anyway) */ // ASSERT(HEADERSIZE+vhs+nonptrs>=MIN_NONUPD_SIZE); main_bufptr += HEADERSIZE+vhs+nonptrs; /* no common up needed */ unpacked_closures++; // stats only; doesn't count FMs in PAP!!! unpacked_thunks += (ip_THUNK(ip)) ? 1 : 0; // stats only if (parent == NULL) { /* remove the tag for the graph root. */ graphroot = packBuffer->buffer; } else { /* Save closure pointer for resolving offsets */ /* tmp_bufptr replaced by slotptr */ // *tmp_bufptr = (StgWord*) closureT; // *(tmp_bufptr)++; // if we restored the queue, we must update temporary blackholes // instead of just writing a pointer into the parent StgClosure* childP = (StgClosure*) ((StgPtr) parent)[HEADERSIZE + pvhs + pptr]; // Eden only code return; // TODO enable this code agian MkA if (childP && // perhaps invalid ptr IsBlackhole(childP)) { // We will not hit a "tagged" childP here, it is always a BH // created by us. SORT_OF_SAFE_UPD_IND(childP, closureT); } else { ((StgPtr) parent)[HEADERSIZE + pvhs + pptr] = (StgWord) closureT; } } // store closure for offsets, (special var. for offsets to other // packets) if (!((StgWord) *slotptr == OFFSET || (StgWord) *slotptr == PLC )) { // avoid duplicate entries for static closures or indirections // HEAP_ALLOCED(closure)) { IF_PAR_DEBUG(pack, debugBelch("---> Entry in Offset Table: (%d, %p)\n", currentOffset, UNTAG_CLOSURE(closureT))); /* note that we store the address WITH TAG here! */ insertHashTable(offsetTable, currentOffset, (void*) closureT); } /* Locate next parent pointer */ IF_PAR_DEBUG(pack, if (*main_bufptr==END_OF_BUFFER_MARKER) { debugBelch(".. seen END_OF_BUFFER_MARKER %x @ %x while unpacking\n",*main_bufptr,main_bufptr);};); /* Locate next parent pointer */ LocateNextParent(&parent, &pptr, &pptrs, &pvhs); // stop when buffer size has been reached or end of graph } while ((parent != NULL) && (bufsize > (nat) (bufptr-(packBuffer->buffer)))); if (parent != NULL) { // prepare all for next part if graph not complete StgClosure* tempBH; StgPtr childP; IF_PAR_DEBUG(packet, debugBelch("bufptr - (packBuffer->buffer) = %d, bufsize = %d, parent = %p\n", (nat) (bufptr-(packBuffer->buffer)), bufsize, parent); debugBelch("Queue not empty, packet entirely unpacked.\n" "Expecting rest on same inport.\n")); offsetpadding += bufsize; // to save it in unpackState... unpackState = saveUnpackState(graphroot, parent, pptr, pptrs, pvhs);// also saves queue and offsets/padding // TODO // inport->unpackState = unpackState; // set field in inport (implies "pendingMsg" inport state) // Eden only // queue has been saved, now fill in temporary QueueMe closures (destroying queue and unpack state) while (parent != NULL) { // it can be that there are already QMs hanging on the queued parent closures (restored queue) // in this case, we do not create new QMs (possibly already blocked TSOs) childP = (StgPtr) ((StgPtr) parent)[HEADERSIZE + pvhs + pptr]; if (childP == NULL) { // invalid ptr, was set to NULL when filling in a new closure tempBH = createBH(rtsFalse/*RBH?*/, cap); // WAS: (Capability *) NULL); -- fails in createBH! -- HWL ((StgPtr)parent)[HEADERSIZE + pvhs + pptr] = (StgWord) tempBH; IF_PAR_DEBUG(packet, debugBelch("Inserted temporary QueueMe child at %p in parent closure %p.\n", tempBH, parent)); } else { ASSERT(IsBlackhole((StgClosure*) childP)); } LocateNextParent(&parent, &pptr, &pptrs, &pvhs); // until the queue is empty and the last parent filled } // while } else { /* PARENT == NULL: whole graph has arrived, offset table can be dropped */ freeHashTable(offsetTable, NULL); offsetTable = NULL; } IF_PAR_DEBUG(pack, debugBelch("Packing: Unpacking done. \n")); IF_PAR_DEBUG(pack, { char fingerPrintStr[MAX_FINGER_PRINT_LEN]; GraphFingerPrint(graphroot, fingerPrintStr); debugBelch(">>> Fingerprint of graph rooted at %p (after unpacking <<%ld>>:\n" "\t{%s}\n", graphroot, (long)packBuffer->id, fingerPrintStr);};); /* check for magic end-of-buffer word (+ increment bufptr */ IF_DEBUG(sanity, ASSERT(*(bufptr++) == END_OF_BUFFER_MARKER)); IF_PAR_DEBUG(pack, debugBelch("checkPacket: main_bufptr=%x *main_bufptr=???; alleged size=%d real size=%d\n", main_bufptr, packBuffer->size, packBuffer->size)); return; } /* --------------------------------------------------------------------------- most debugging functions have been moved to ParallelDebug.c */ //@node debugging functions, , Sanity checks //@section debugging functions /* Doing a sanity check on a packet. This does a full iteration over the packet, as in PrintPacket. */ #endif /* PARALLEL_HASKELL */