packman 0.3.0 → 0.4.0
raw patch · 4 files changed
+234/−141 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- cbits/Pack.c +232/−129
- dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs +0/−5
- dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs +0/−5
- packman.cabal +2/−2
cbits/Pack.c view
@@ -46,6 +46,18 @@ #include <string.h> // memset #endif +// programming against internal types is great, isn't it? :-P+#if __GLASGOW_HASKELL__ < 711+#define StgArrBytes StgArrWords+#endif+// and sometimes they did not appear very internal, just old...+#if __GLASGOW_HASKELL__ < 801+#define bool rtsBool+#define true rtsTrue+#define false rtsFalse+#endif++ #ifdef DEBUG #define DBG_HEADROOM 1 #define END_OF_BUFFER_MARKER 0xdededeee@@ -112,17 +124,17 @@ // Could use WSDeQue from the RTS, but we don't need its thread-safety typedef struct ClosureQ_ { StgClosure** queue;- nat size; // all in units of StgClosure*- nat head;- nat tail;+ uint32_t size; // all in units of StgClosure*+ uint32_t head;+ uint32_t tail; } ClosureQ; // packing state: buffer, queue, offset table typedef struct PackState_ { StgWord *buffer;- nat size; // buffer size in StgWords- nat position; // position in buffer, in StgWords- // nat unpacked_size; // record unpacked size? only interesting to debug+ uint32_t size; // buffer size in StgWords+ uint32_t position; // position in buffer, in StgWords+ // uint32_t unpacked_size;// record unpacked size? only interesting to debug #ifndef LIBRARY_CODE StgTSO *tso; // in-RTS version: may block when accessing a blackhole #endif@@ -137,17 +149,17 @@ // init/destruct pack data structure #ifdef LIBRARY_CODE-static PackState* initPacking(StgArrWords *mutArr);+static PackState* initPacking(StgArrBytes *mutArr); #else-static PackState* initRtsPacking(StgWord *buffer, nat size, StgTSO *tso);+static PackState* initRtsPacking(StgWord *buffer, uint32_t size, StgTSO *tso); #endif static void donePacking(PackState *state); // closure queue-static ClosureQ* initClosureQ(nat size);+static ClosureQ* initClosureQ(uint32_t size); static void freeClosureQ(ClosureQ* q);-STATIC_INLINE rtsBool queueEmpty(ClosureQ* q);-STATIC_INLINE nat queueSize(ClosureQ* q);+STATIC_INLINE bool queueEmpty(ClosureQ* q);+STATIC_INLINE uint32_t queueSize(ClosureQ* q); static void queueClosure(ClosureQ* q, StgClosure *closure); static StgClosure *deQueueClosure(ClosureQ* q); @@ -158,19 +170,19 @@ // little helpers: STATIC_INLINE void registerOffset(PackState* p, StgClosure *closure); STATIC_INLINE StgWord offsetFor(PackState* p, StgClosure *closure);-STATIC_INLINE rtsBool roomToPack(PackState* p, nat size);+STATIC_INLINE bool roomToPack(PackState* p, uint32_t size); // closure information STATIC_INLINE StgInfoTable* getClosureInfo(StgClosure* node, StgInfoTable* info,- nat *size, nat *ptrs,- nat *nonptrs, nat *vhs);+ uint32_t *size, uint32_t *ptrs,+ uint32_t *nonptrs, uint32_t *vhs); #ifdef LIBRARY_CODE // remains local when code is stand-alone for the library-STATIC_INLINE rtsBool pmIsBlackhole(StgClosure* node);+STATIC_INLINE bool pmIsBlackhole(StgClosure* node); #define isBlackhole pmIsBlackhole #else // if compiling for the RTS: used in other files, declared in Parallel.h-// rtsBool isBlackhole(StgClosure* node);+// bool isBlackhole(StgClosure* node); #endif /************************@@ -179,11 +191,11 @@ #ifdef LIBRARY_CODE // interface function used in foreign primop: pack graph to given array, return // size in bytes (offset by P_ERRCODEMAX) or an error code-int pmtryPackToBuffer(StgClosure* closure, StgArrWords* mutArr);+int pmtryPackToBuffer(StgClosure* closure, StgArrBytes* mutArr); #else // in-RTS version: packToBuffer, declared in Parallel.h // int packToBuffer(StgClosure* closure,-// StgWord *buffer, nat bufsize, StgTSO *caller);+// StgWord *buffer, uint32_t bufsize, StgTSO *caller); // serialisation into a Haskell Byte array, returning error codes on failure // StgClosure* tryPackToMemory(StgClosure* graphroot, StgTSO* tso, // Capability* cap);@@ -214,12 +226,12 @@ #ifdef LIBRARY_CODE // interface unpacking from a Haskell array (using the Haskell Byte Array) // may return error code P_GARBLED-StgClosure* pmUnpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap);+StgClosure* pmUnpackGraphWrapper(StgArrBytes* packBufferArray, Capability* cap); #else // in-RTS unpacking: unpacks from rtsPackBuffer and wipes it, aborts on failure // declared in Parallel.h // StgClosure* unpackGraph(rtsPackBuffer *packBuffer, Capability* cap);-// StgClosure* unpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap);+// StgClosure* unpackGraphWrapper(StgArrBytes* packBufferArray, Capability* cap); #endif // internal function working on the raw data buffer@@ -227,7 +239,8 @@ // helper function to find next pointer (filling in pointers) STATIC_INLINE void locateNextParent(ClosureQ* q, StgClosure **parentP,- nat* pptrP, nat* pptrsP, nat* pvhsP);+ uint32_t* pptrP, uint32_t* pptrsP,+ uint32_t* pvhsP); // core unpacking function static StgClosure* UnpackClosure (ClosureQ* q, HashTable* offsets,@@ -278,7 +291,7 @@ #define MAX_FINGER_PRINT_LEN 1023 static void graphFingerPrint(char* fp, StgClosure *graphroot); -static void checkPacket(StgWord* buffer, nat size);+static void checkPacket(StgWord* buffer, uint32_t size); #endif /***************************************************************@@ -287,7 +300,7 @@ static void init(void) { // we must retain all CAFs, as packet data might refer to it. // This variable lives in Storage.c, inhibits GC for CAFs.- keepCAFs = rtsTrue;+ keepCAFs = true; } /***************************************************************@@ -298,7 +311,7 @@ #ifdef LIBRARY_CODE // A mutable array is passed as the buffer space. Note that its size comes in // bytes, while internally all is managed in units of StgWord.-static PackState* initPacking(StgArrWords *mutArr) {+static PackState* initPacking(StgArrBytes *mutArr) { PackState *ret; ret = (PackState*) stgMallocBytes(sizeof(PackState), "pack state");@@ -319,7 +332,7 @@ } #else // in-RTS version uses a raw buffer instead of an array, and carries a tso-static PackState* initRtsPacking(StgWord *buffer, nat size, StgTSO *tso) {+static PackState* initRtsPacking(StgWord *buffer, uint32_t size, StgTSO *tso) { PackState *ret; ret = (PackState*) stgMallocBytes(sizeof(PackState), "pack state");@@ -350,7 +363,7 @@ } // initialise a closure queue for "size" many closures-static ClosureQ* initClosureQ(nat size) {+static ClosureQ* initClosureQ(uint32_t size) { ClosureQ* ret; ret = (ClosureQ*) stgMallocBytes(sizeof(ClosureQ), "cl.queue"); ret->queue = (StgClosure**)@@ -367,19 +380,19 @@ } // queue empty if head == tail-STATIC_INLINE rtsBool queueEmpty(ClosureQ* q) {+STATIC_INLINE bool queueEmpty(ClosureQ* q) { return (q->head == q->tail); } // compute size from distance between head and tail (with wrap-around)-STATIC_INLINE nat queueSize(ClosureQ* q) {+STATIC_INLINE uint32_t queueSize(ClosureQ* q) { // queue can wrap around int span = q->head - q->tail; ASSERT(span < (int) q->size && 0 - (int) q->size < span); if (span >= 0) {- return (nat) span;+ return (uint32_t) span; } else { // wrapped around return (q->size - span);@@ -390,7 +403,7 @@ static void queueClosure(ClosureQ* q, StgClosure *closure) { // next index, wrapping around when required- nat idx = (q->head == q->size - 1) ? 0 : q->head + 1;+ uint32_t idx = (q->head == q->size - 1) ? 0 : q->head + 1; if (idx == q->tail) { // queue full, stop (should not happen with sizes used here)@@ -409,9 +422,9 @@ if (!queueEmpty(q)) { StgClosure* c = q->queue[q->tail]; q->tail = (q->tail == q->size-1) ? 0 : (q->tail + 1);- PACKETDEBUG(debugBelch(">__> DeQ: %p (%s); %ld elems in q\n",+ PACKETDEBUG(debugBelch(">__> DeQ: %p (%s); %d elems in q\n", c, info_type(UNTAG_CLOSURE(c)),- (long) queueSize(q)));+ queueSize(q))); return c; } else { PACKETDEBUG(debugBelch("Q empty\n "));@@ -446,7 +459,7 @@ // roomToPack checks if the buffer has enough space to pack the given size (in // StgWords). For GUM, it would also include queue size * FETCHME-size.-STATIC_INLINE rtsBool roomToPack(PackState* p, nat size)+STATIC_INLINE bool roomToPack(PackState* p, uint32_t size) { if ((p->position + // where we are in the buffer right now size + // space needed for the current closure@@ -456,9 +469,9 @@ 1) // closure tag >= p->size) { PACKDEBUG(debugBelch("Pack buffer full (size %d). ", p->position));- return rtsFalse;+ return false; }- return rtsTrue;+ return true; } // quick test for blackholes. Available somewhere else?@@ -466,7 +479,7 @@ #ifdef LIBRARY_CODE STATIC_INLINE #endif-rtsBool isBlackhole(StgClosure* node) {+bool isBlackhole(StgClosure* node) { // since ghc-7.0, blackholes are used as indirections. inspect indirectee. if(((StgInfoTable*)get_itbl(UNTAG_CLOSURE(node)))->type == BLACKHOLE) { StgClosure* indirectee = ((StgInd*)node)->indirectee;@@ -474,12 +487,12 @@ switch (((StgInfoTable*)get_itbl(UNTAG_CLOSURE(indirectee)))->type) { case TSO: case BLOCKING_QUEUE:- return rtsTrue;+ return true; default:- return rtsFalse;+ return false; } }- return rtsFalse;+ return false; } // unwind (chains of) indirections, return the actual data closure@@ -511,10 +524,12 @@ */ STATIC_INLINE StgInfoTable* getClosureInfo(StgClosure* node, StgInfoTable* info,- nat *size, nat *ptrs, nat *nonptrs, nat *vhs) {+ uint32_t *size, uint32_t *ptrs,+ uint32_t *nonptrs, uint32_t *vhs) {+ // We remove the potential tag before doing anything. node = UNTAG_CLOSURE(node);-+ if (info == NULL) { // Supposed to compute info table by ourselves. This will go very wrong // if we use an info _offset_ instead (if we are supposed to look at a@@ -522,7 +537,7 @@ // something tagged. ASSERT(!GET_CLOSURE_TAG((StgClosure*) node->header.info)); // not tagged, OK- info = get_itbl(node);+ info = (StgInfoTable*) get_itbl(node); } // ClosureMacros.h. NB relies on variable header for PAP, AP, Arrays *size = closure_sizeW_(node, info);@@ -563,7 +578,7 @@ case ARR_WORDS: *vhs = 1; *ptrs = 0;- *nonptrs = (((StgArrWords*) node)->bytes) / sizeof(StgWord);+ *nonptrs = (((StgArrBytes*) node)->bytes) / sizeof(StgWord); break; /* For Arrays of pointers, we need to fill in all the pointers and@@ -579,7 +594,7 @@ // NB nonptrs field for array closures is only used in checkPacket break; -#if __GLASGOW_HASKELL__ > 708+#if __GLASGOW_HASKELL__ >= 709 // Small arrays do not have card tables, straightforward case SMALL_MUT_ARR_PTRS_CLEAN: case SMALL_MUT_ARR_PTRS_DIRTY:@@ -604,11 +619,16 @@ case RET_BCO: barf("getClosureInfo: stack frame!"); break;+#if __GLASGOW_HASKELL__ >= 801+ case COMPACT_NFDATA:+ barf("compact nfdata not supported");+ break;+#endif default: // this works for all pointers-first layouts- *ptrs = (nat) (info->layout.payload.ptrs);- *nonptrs = (nat) (info->layout.payload.nptrs);+ *ptrs = (uint32_t) (info->layout.payload.ptrs);+ *nonptrs = (uint32_t) (info->layout.payload.nptrs); *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader); } @@ -623,9 +643,9 @@ * The graph is packed breadth-first into a given buffer of StgWords. * * In the buffer, 3 different types of entities are packed- * 0L - closure with static address - PackPLC- * 1L - offset (closure already in packet) - PackOffset- * 2L - a heap closure follows - PackGeneric/specialised routines+ * 1L - closure with static address - PackPLC+ * 2L - offset (closure already in packet) - PackOffset+ * 3L - a heap closure follows - PackGeneric/specialised routines * * About "pointer tagging": * Every closure pointer carries a tag in its l.s. bits (those which@@ -699,10 +719,10 @@ // pmtryPackToBuffer: interface function called by the foreign primop. // Returns packed size (in bytes!) + P_ERRCODEMAX when successful, or // error codes upon failure-int pmtryPackToBuffer(StgClosure* closure, StgArrWords* mutArr) {+int pmtryPackToBuffer(StgClosure* closure, StgArrBytes* mutArr) { int errcode = P_SUCCESS; // error code returned by PackClosure PackState* p;- nat size;+ uint32_t size; PACKDEBUG( { char fpstr[MAX_FINGER_PRINT_LEN];@@ -751,10 +771,10 @@ // Returns packed size (in bytes!) + P_ERRCODEMAX when successful, or // error codes upon failure int packToBuffer(StgClosure* closure,- StgWord *buffer, nat bufsize, StgTSO *caller) {+ StgWord *buffer, uint32_t bufsize, StgTSO *caller) { int errcode = P_SUCCESS; // error code returned by PackClosure PackState* p;- nat size;+ uint32_t size; PACKDEBUG( { char fpstr[MAX_FINGER_PRINT_LEN];@@ -806,7 +826,7 @@ StgTSO* tso, Capability* cap) { StgWord *buffer; StgWord packedSize, trySize;- StgArrWords* wordArray;+ StgArrBytes* wordArray; #define ONEMEGABYTE 1048576 trySize = ONEMEGABYTE; // start with 1MB buffer, increase if it fails@@ -844,7 +864,7 @@ // +---------+----------+------------------------+ // |ARR_WORDS| n_bytes | data (array of words) | // +---------+----------+------------------------+- wordArray = (StgArrWords*) allocate(cap, 2 + packedSize / sizeof(StgWord));+ wordArray = (StgArrBytes*) allocate(cap, 2 + packedSize / sizeof(StgWord)); SET_HDR(wordArray, &stg_ARR_WORDS_info, CCS_SYSTEM); wordArray->bytes = packedSize; memcpy((void*) &(wordArray->payload), buffer, packedSize);@@ -885,7 +905,7 @@ } // remove the tag (temporary, subroutines will handle tag as needed)- info = get_itbl(UNTAG_CLOSURE(closure));+ info = (StgInfoTable*) get_itbl(UNTAG_CLOSURE(closure)); // code relies on info-pointers being word-aligned (they are tagged) ASSERT(info == UNTAG_CAST(StgInfoTable*, info));@@ -902,17 +922,43 @@ case CONSTR_2_0: case CONSTR_1_1: case CONSTR_0_2:+#if __GLASGOW_HASKELL__ >= 801+ // Between GHC 8.01 and (forthcoming) 8.02 the _STATIC constr.+ // variants were removed, and the new CONSTR_NOCAF type added.+ // Static constructors now have to be discovered using the+ // HEAP_ALLOCED macro on the address.+ case CONSTR_NOCAF:++ // While it should be OK to execute the code below in older+ // GHCs, the new type is not, and we separate it to make + // differences apparent.++ if (!HEAP_ALLOCED(closure)) {+ // (see code below for other *_STATIC closures)+ PACKETDEBUG(debugBelch("*>~~ Found static constr %p (%s),"+ " packing as a PLC\n",+ closure, info_type_by_ip(info)));+ PackPLC(p, (StgPtr)closure);+ // PLCs are packed with their tag (closure is still tagged)+ return P_SUCCESS;+ }+ // otherwise fall through to old code and pack heap-allocated+#endif return PackGeneric(p, closure); - case CONSTR_STATIC: // We pack indirections to CAFs:- case CONSTR_NOCAF_STATIC: // Therefore, we need keepCAFs==rtsTrue- case FUN_STATIC: // (otherwise GC leaves dangling pointers- case THUNK_STATIC: // from original CAF site to the heap)- // all these are packed with their tag (closure is still tagged)+#if __GLASGOW_HASKELL__ < 801+ case CONSTR_STATIC:+ case CONSTR_NOCAF_STATIC:+#endif+ case FUN_STATIC:+ case THUNK_STATIC:+ // We pack indirections to CAFs: Therefore, we need+ // keepCAFs==true (otherwise GC leaves dangling pointers+ // from original CAF site to the heap) PACKETDEBUG(debugBelch("*>~~ Packing a %p (%s) as a PLC\n", closure, info_type_by_ip(info)));- PackPLC(p, (StgPtr)closure);+ // PLCs are packed with their tag (closure is still tagged) // NB: unpacked_size of a PLC is 0 return P_SUCCESS; @@ -962,11 +1008,13 @@ goto unsupported; case IND:+#if __GLASGOW_HASKELL__ < 801 case IND_PERM:+#endif case IND_STATIC: // clearly a bug! barf("Pack: found IND_... after shorting out indirections %d (%s)",- (nat)(info->type), info_type_by_ip(info));+ (uint8_t)(info->type), info_type_by_ip(info)); // return vectors case RET_BCO:@@ -1112,7 +1160,7 @@ goto loop; // valid only for the threaded RTS... cannot distinguish here -#if __GLASGOW_HASKELL__ > 708+#if __GLASGOW_HASKELL__ >= 709 case SMALL_MUT_ARR_PTRS_CLEAN: case SMALL_MUT_ARR_PTRS_DIRTY: case SMALL_MUT_ARR_PTRS_FROZEN:@@ -1125,6 +1173,16 @@ return PackGeneric(p, closure); #endif +#if __GLASGOW_HASKELL__ >= 801+ case COMPACT_NFDATA:+ // a chain of blocks full of self-contained NFData. We could+ // choose to serialise the entire chain of blocks, but would+ // then have to fix all included intra-region pointers. There+ // is support for doing this in CNF.[ch], but using CNF here+ // would be like a bus pulling a passenger train.+ goto unsupported;+#endif+ unsupported: PACKDEBUG(errorBelch("Pack: packing type %s (%p) not implemented", info_type_by_ip(info), closure));@@ -1136,7 +1194,7 @@ return P_IMPOSSIBLE; default:- barf("Pack: strange closure %d", (nat)(info->type));+ barf("Pack: strange closure %d", (uint8_t)(info->type)); } // closure type switch }@@ -1150,7 +1208,7 @@ // the info pointer. It is tagged and offset to a known base. static StgWord PackGeneric(PackState* p, StgClosure* closure) {- nat size, ptrs, nonptrs, vhs, i;+ uint32_t size, ptrs, nonptrs, vhs, i; StgWord tag=0; StgClosure* infoptr; // actually just a pointer... @@ -1265,15 +1323,15 @@ // this version packs the btimap instead. static StgWord PackPAP(PackState *p, StgPAP *pap) { - nat i;- nat hsize; // header size+ uint32_t i;+ uint32_t hsize; // header size StgWord bitmap; // small bitmap StgLargeBitmap *lbm;// large bitmap- nat bsize; // bitmap size- nat bsizeW; // bitmap size in words- StgFunInfoTable *funInfo; // to get bitmap+ uint32_t bsize; // bitmap size+ uint32_t bsizeW; // bitmap size in words+ const StgFunInfoTable *funInfo; // to get bitmap - nat n_args; // arg. count on stack+ uint32_t n_args; // arg. count on stack StgClosure *fun; // function in PAP/AP StgPtr ptr; // stack object currently packed StgWord tag = 0;@@ -1446,7 +1504,7 @@ return P_UNSUPPORTED; // XXX following code UNCHECKED! // written to closely match Scav.c::scavenge_large_bitmap- nat j, b;+ uint32_t j, b; b = 0; bsize = lbm->size; for(i = 0; i < bsize; b++) {@@ -1471,7 +1529,7 @@ // Packing Arrays. // An Array in the heap can contain StgWords or Pointers (to-// closures), and is thus of type StgArrWords or StgMutArrPtrs.+// closures), and is thus of type StgArrWords/Bytes or StgMutArrPtrs. // // Array layout in heap/buffer is the following: //@@ -1483,8 +1541,8 @@ // // The array size is stored in bytes, but will always be word-aligned. //-// Historically, this routine was also packing ArrWords, but they can-// equally well be treated as "pointers-first" generic layout (with no+// Historically, this routine was also packing StgArrWords/Bytes, but they+// can equally well be treated as "pointers-first" generic layout (with no // pointers), and are packed simply by copying all words (as non-ptrs). // // MutArrPtrs (MUT_ARRAY_PTRS_* types) contain pointers to other@@ -1495,7 +1553,7 @@ static StgWord PackArray(PackState *p, StgClosure *closure) { StgClosure *infoptr;- nat i, payloadsize, packsize;+ uint32_t i, payloadsize, packsize; /* remove tag, store it in infopointer (same as above) */ StgWord tag=0;@@ -1505,7 +1563,7 @@ #if DEBUG /* get info about basic layout of the closure */- StgInfoTable *info = get_itbl(closure);+ const StgInfoTable *info = get_itbl(closure); ASSERT( info->type == MUT_ARR_PTRS_CLEAN || info->type == MUT_ARR_PTRS_DIRTY@@ -1519,7 +1577,7 @@ payloadsize = ((StgMutArrPtrs *)closure)->ptrs; // the function in ClosureMacros.h would include the header:- // arr_words_sizeW(stgCast(StgArrWords*,q));+ // arr_words_sizeW(stgCast(StgArrBytes*,q)); PACKETDEBUG(debugBelch("*>== %p (%s): packing array" "(%d words) (size=%d)\n", closure, info_type(closure), payloadsize,@@ -1563,8 +1621,8 @@ Formerly, there was also 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.+ of unpacking the buffer; and uint32_t* @nGAs@ set to the number of GA+ pairs which were created. for "pointer tagging", we assume here that all stored info pointers (each first word of a packed closure) also carry the@@ -1577,12 +1635,12 @@ #ifdef LIBRARY_CODE // unpacking from a Haskell array (using the Haskell Byte Array) // may return error code P_GARBLED-StgClosure* pmUnpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap)+StgClosure* pmUnpackGraphWrapper(StgArrBytes* packBufferArray, Capability* cap) #else-StgClosure* unpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap)+StgClosure* unpackGraphWrapper(StgArrBytes* packBufferArray, Capability* cap) #endif {- nat size;+ uint32_t size; StgWord *buffer; StgClosure* newGraph; @@ -1635,8 +1693,8 @@ static StgClosure* unpackGraph_(StgWord *buffer, StgInt size, Capability* cap) { StgWord* bufptr; StgClosure *closure, *parent, *graphroot;- nat pptr = 0, pptrs = 0, pvhs = 0;- nat currentOffset;+ uint32_t pptr = 0, pptrs = 0, pvhs = 0;+ uint32_t currentOffset; HashTable* offsets; ClosureQ* queue; @@ -1659,7 +1717,7 @@ if (*bufptr == OFFSET || *bufptr == PLC) { currentOffset = 0; } else {- currentOffset = ((nat) (bufptr - buffer)) + PADDING;+ currentOffset = ((uint32_t) (bufptr - buffer)) + PADDING; // ...which is at least 1 (PADDING) } @@ -1723,7 +1781,7 @@ IF_DEBUG(sanity, ASSERT(*(bufptr++) == END_OF_BUFFER_MARKER)); // assert we unpacked exactly as many words as there are in the buffer- ASSERT(size == (nat) (bufptr-buffer));+ ASSERT(size == (uint32_t) (bufptr-buffer)); // ToDo: are we *certain* graphroot has been set??? WDP 95/07 ASSERT(graphroot!=NULL);@@ -1756,8 +1814,9 @@ // | // *pptrs = N *pptr=3 STATIC_INLINE void locateNextParent(ClosureQ* q, StgClosure** parentP,- nat* pptrP, nat* pptrsP, nat* pvhsP) {- nat size, nonptrs;+ uint32_t* pptrP, uint32_t* pptrsP,+ uint32_t* pvhsP) {+ uint32_t 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@@ -1811,7 +1870,7 @@ UnpackClosure (ClosureQ* q, HashTable* offsets, StgWord **bufptrP, Capability* cap) { StgClosure *closure;- nat size,ptrs,nonptrs,vhs,i;+ uint32_t size,ptrs,nonptrs,vhs,i; StgInfoTable *ip; StgWord tag = 0; @@ -1894,6 +1953,9 @@ case CONSTR_2_0: case CONSTR_1_1: case CONSTR_0_2:+#if __GLASGOW_HASKELL__ >= 801+ case CONSTR_NOCAF:+#endif case FUN: case FUN_1_0: case FUN_0_1:@@ -1907,7 +1969,7 @@ case THUNK_1_1: case THUNK_0_2: case THUNK_SELECTOR:-#if __GLASGOW_HASKELL__ > 708+#if __GLASGOW_HASKELL__ >= 709 case SMALL_MUT_ARR_PTRS_CLEAN: case SMALL_MUT_ARR_PTRS_DIRTY: case SMALL_MUT_ARR_PTRS_FROZEN0:@@ -1982,8 +2044,8 @@ ASSERT((long) **bufptrP == OFFSET); (*bufptrP)++; // skip marker- // unpack nat; find closure for this offset- offset = (nat) **bufptrP;+ // unpack uint32_t; find closure for this offset+ offset = (uint32_t) **bufptrP; (*bufptrP)++; // skip offset ASSERT(offset != 0);@@ -2018,7 +2080,7 @@ static StgClosure * UnpackPAP(ClosureQ *queue, StgInfoTable *info, StgWord **bufptrP, Capability* cap) { - nat n_args, size, hsize, i;+ uint32_t n_args, size, hsize, i; StgWord bsizeW; StgPtr pap; // PAP/AP is constructed here, but untyped (would need // to distinguish the AP case all the time)@@ -2118,7 +2180,7 @@ return (StgClosure*) NULL; // need to repeatedly read a new bitmap and proceed StgPtr bitmapPos;- nat j;+ uint32_t j; StgWord bitmap; // ... walk through the bitmap until n_args have been unpacked@@ -2160,10 +2222,10 @@ // unpacking arrays. Returns NULL in case of errors. static StgClosure* UnpackArray(ClosureQ *queue, StgInfoTable* info, StgWord **bufptrP, Capability* cap) {- nat size;+ uint32_t size; StgMutArrPtrs *array; - nat type = INFO_PTR_TO_STRUCT(info)->type;+ uint32_t type = INFO_PTR_TO_STRUCT(info)->type; // refuse to work if not an array if (type != MUT_ARR_PTRS_CLEAN && type != MUT_ARR_PTRS_DIRTY &&@@ -2261,28 +2323,57 @@ Will only be called inside this module. */ -/* this array has to be kept in sync with includes/ClosureTypes.h */+/* this array has to be kept in sync with includes/ClosureTypes.h.+ * For backwards compatibility of packman, changes need to be worked in+ * via CPP (or multipurpose code where possible).+ * + * Changes are identified by minor version, we cannot be more precise than+ * that, but non-released version numbers (odd minor version) are included.+ *+ * Change log:+ * 7.08.x - start state+ * 7.09 - addition of small array closures (61-64)+ * 8.01 - removal of IND_PERM (was 30), subsequent numbers shifting up+ * 8.01 - addition of COMPACT_NFDATA (65). Prior 801 cannot be supported.+ */ #if __GLASGOW_HASKELL__ == 708 # if !(N_CLOSURE_TYPES == 61 ) # error Wrong closure type count in fingerprint array. Check code. # endif-#elif __GLASGOW_HASKELL__ > 708+#elif __GLASGOW_HASKELL__ >= 709 && __GLASGOW_HASKELL__ <= 800 # if !(N_CLOSURE_TYPES == 65 ) # error Wrong closure type count in fingerprint array. Check code. # endif+#elif __GLASGOW_HASKELL__ >= 801+ // no CONSTR_NOCAF_STATIC, CONSTR_STATIC, but CONSTR_NOCAF+# if !(N_CLOSURE_TYPES == 64 )+# error Wrong closure type count in fingerprint array. Check code.+# endif #endif static char* fingerPrintChar =- "0ccccccCC" /* INVALID CONSTRs (0-8) */- "fffffff" /* FUNs (9-15) */- "ttttttt" /* THUNKs (16-23) */- "TBAPP___" /* SELECTOR BCO AP PAP AP_STACK INDs (24-31) */- "RRRRFFFF" /* RETs FRAMEs (32-39) */- "*@MMT" /* BQ BLACKHOLE MVARs TVAR (40-43) */- "aAAAAmmwppXS" /* ARRAYs MUT_VARs WEAK PRIM MUT_PRIM TSO STACK (44-55) */- "&FFFW" /* TREC (STM-)FRAMEs WHITEHOLE (56-60)*/+#if __GLASGOW_HASKELL__ >= 801+ "0ccccccC" // INVALID CONSTRs (0-7) (incl. C._NOCAF)+#else+ "0ccccccCC" // INVALID CONSTRs (0-8) (incl. 2 C.*_STATIC)+#endif+ "fffffff" // FUNs (9-15/8-14)+ "ttttttt" // THUNKs (16-22/15-21)+ "TBAPP" // SELECTOR BCO AP PAP AP_STACK+#if __GLASGOW_HASKELL__ >= 801+ "__" // INDs (2)+#else+ "___" // INDs (3)+#endif+ "RRRRFFFF" // RETs (4) FRAMEs (4)+ "*@MMT" // BQ BLACKHOLE MVARs TVAR+ "aAAAAmmwppXS" // ARRAYs(1+4) MUT_VARs(2) WEAK PRIM MUT_PRIM TSO STACK+ "&FFFW" // TREC (STM-)FRAMEs(3) WHITEHOLE #if __GLASGOW_HASKELL__ >= 708- "ZZZZ" /* SmallArr (61-64) */+ "ZZZZ" // SmallArr(4) #endif+#if __GLASGOW_HASKELL__ >= 801+ "Ø" // Compact NF block+#endif ; @@ -2314,7 +2405,7 @@ All recursive calls should be made to this function. */ static void graphFingerPrint_(char* fp, HashTable* visited, StgClosure *p) {- nat i, len, args, arity;+ uint32_t i, len, args, arity; const StgInfoTable *info; StgWord *payload; @@ -2327,7 +2418,7 @@ return; /* at most 7 chars added immediately (unchecked) for this node */ if (len+7 >= MAX_FINGER_PRINT_LEN) {- strcat(fp, "--end");+ strcat(fp, "--"); return; } /* check whether we have met this node already to break cycles */@@ -2337,10 +2428,16 @@ } /* record that we are processing this closure */- insertHashTable(visited, (StgWord) p, (void *)rtsTrue/*non-NULL*/);+ insertHashTable(visited, (StgWord) p, (void *) 1 /*non-NULL*/); ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); +#if __GLASGOW_HASKELL__ >= 801+ // GHC 8.1 and younger do not use CONSTR_*_STATIC any more,+ // therefore we need this different case exit.+ if ( ! HEAP_ALLOCED(p)) return;+#endif+ info = get_itbl((StgClosure *)p); // append char for this node@@ -2350,13 +2447,17 @@ switch (info -> type) { // simple and static objects+#if __GLASGOW_HASKELL__ < 801 case CONSTR_STATIC: case CONSTR_NOCAF_STATIC:+#endif case FUN_STATIC: case THUNK_STATIC:+ // NB should never be reached in GHC > 801 break; /* CONSTRs, THUNKs, FUNs are written with arity */+ // NB no static constructors should be around in GHC > 801 case THUNK_2_0: // append char for this node strcat(fp, "20(");@@ -2439,6 +2540,9 @@ case FUN: case CONSTR:+#if __GLASGOW_HASKELL__ >= 801+ case CONSTR_NOCAF:+#endif { char str[6]; sprintf(str,"%d?(",info->layout.payload.ptrs);@@ -2482,7 +2586,8 @@ graphFingerPrint_(fp, visited, (StgClosure *) (p)); if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) { StgWord bitmap;- StgFunInfoTable *funInfo = get_fun_itbl(UNTAG_CLOSURE(p));+ const StgFunInfoTable *funInfo + = get_fun_itbl(UNTAG_CLOSURE(p)); strcat(fp, "|"); switch (funInfo->f.fun_type) { /* these two use a large bitmap. We do not follow...*/@@ -2517,7 +2622,9 @@ break; case IND:+#if __GLASGOW_HASKELL__ < 801 case IND_PERM:+#endif case IND_STATIC: /* do not print the '_' for indirections */ fp[len] = '\0';@@ -2571,7 +2678,7 @@ case ARR_WORDS: { // record size only (contains StgWords, not pointers) char str[6];- sprintf(str, "%ld", (long) arr_words_words((StgArrWords*)p));+ sprintf(str, "%ld", (long) arr_words_words((StgArrBytes*)p)); strcat(fp, str); } break;@@ -2584,7 +2691,7 @@ char str[6]; sprintf(str, "%ld", (long)((StgMutArrPtrs*)p)->ptrs); strcat(fp, str);- nat i;+ uint32_t i; for (i = 0; i < ((StgMutArrPtrs*)p)->ptrs; i++) { //contains closures... follow graphFingerPrint_(fp, visited,@@ -2614,7 +2721,7 @@ case WHITEHOLE: break; -#if __GLASGOW_HASKELL__ > 708+#if __GLASGOW_HASKELL__ >= 709 case SMALL_MUT_ARR_PTRS_CLEAN: case SMALL_MUT_ARR_PTRS_DIRTY: case SMALL_MUT_ARR_PTRS_FROZEN0:@@ -2623,7 +2730,7 @@ char str[6]; sprintf(str,"%ld",(long)((StgSmallMutArrPtrs*)p)->ptrs); strcat(fp,str);- nat i;+ uint32_t i; for (i = 0; i < ((StgSmallMutArrPtrs*)p)->ptrs; i++) { //contains closures... follow graphFingerPrint_(fp, visited,@@ -2632,7 +2739,11 @@ break; } #endif-+#if __GLASGOW_HASKELL__ >= 801+ case COMPACT_NFDATA:+ // an opaque block of NF data, nothing to follow+ break;+#endif default: barf("graphFingerPrint_: unknown closure %d", info -> type);@@ -2643,9 +2754,9 @@ // Sanity check on a packet. // This does a full iteration over the packet, as in UnpackGraph. // Arguments: buffer data ptr, buffer size in words-static void checkPacket(StgWord* buffer, nat size) {+static void checkPacket(StgWord* buffer, uint32_t size) { StgInt packsize, openptrs;- nat clsize, ptrs, nonptrs, vhs;+ uint32_t clsize, ptrs, nonptrs, vhs; StgWord *bufptr; HashTable *offsets; @@ -2704,7 +2815,7 @@ // HEADERSIZE, vhs, ptrs, nonptrs, clsize)); // This is rather a test for getClosureInfo...but used here- if (clsize != (nat) HEADERSIZE + vhs + ptrs + nonptrs) {+ if (clsize != HEADERSIZE + vhs + ptrs + nonptrs) { barf("size mismatch in packed closure at %p :" "(%d + %d + %d +%d != %d)", bufptr, HEADERSIZE, vhs, ptrs, nonptrs, clsize);@@ -2781,11 +2892,3 @@ /* END OF DEBUG */ #endif--// Local Variables:-// mode: C++-// fill-column: 80-// indent-tabs-mode: nil-// c-basic-offset: 4-// buffer-file-coding-system: utf-8-unix-// End:
− dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs
@@ -1,5 +0,0 @@-module Main ( main ) where-import Distribution.Simple.Test.LibV09 ( stubMain )-import AllTests ( tests )-main :: IO ()-main = stubMain tests
− dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs
@@ -1,5 +0,0 @@-module Main ( main ) where-import Distribution.Simple.Test.LibV09 ( stubMain )-import QCTest ( tests )-main :: IO ()-main = stubMain tests
packman.cabal view
@@ -1,5 +1,5 @@ name: packman-version: 0.3.0+version: 0.4.0 synopsis: Serialization library for GHC description:@@ -68,7 +68,7 @@ GHC.Packing.PackException GHC.Packing.Type GHC.Packing.Core- build-depends: base >= 4.7 && < 5,+ build-depends: base >= 4.7 && < 4.10, ghc-prim >= 0.3, array >= 0.5, binary >= 0.7,