diff --git a/cbits/Pack.c b/cbits/Pack.c --- a/cbits/Pack.c +++ b/cbits/Pack.c @@ -46,6 +46,18 @@ #include // 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: diff --git a/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs b/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs deleted file mode 100644 --- a/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import AllTests ( tests ) -main :: IO () -main = stubMain tests diff --git a/dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs b/dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs deleted file mode 100644 --- a/dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import QCTest ( tests ) -main :: IO () -main = stubMain tests diff --git a/packman.cabal b/packman.cabal --- a/packman.cabal +++ b/packman.cabal @@ -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,