diff --git a/GHC/Packing.hs b/GHC/Packing.hs index fa4931f..03268f0 100644 --- a/GHC/Packing.hs +++ b/GHC/Packing.hs @@ -1,23 +1,21 @@ -{-# OPTIONS -XScopedTypeVariables -XRecordWildCards -XBangPatterns - -XMagicHash -XUnboxedTuples - -XDeriveDataTypeable - -cpp #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE UnliftedFFITypes #-} - +{-# LANGUAGE RecordWildCards, BangPatterns, DeriveDataTypeable, CPP, + ScopedTypeVariables #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# LANGUAGE GHCForeignImportPrim, ForeignFunctionInterface, + UnliftedFFITypes #-} {-# OPTIONS_HADDOCK prune #-} {- | Module : GHC.Packing -Copyright : (c) Jost Berthold, 2010-2013, +Copyright : (c) Jost Berthold, 2010-2014, License : probably BSD3 (soon) Maintainer : berthold@diku.dk Stability : experimental -Portability : no (depends on GHC runtime support) +Portability : no (depends on GHC internals) -Serialisation of Haskell data structures using runtime system support. +Serialisation of Haskell data structures TODO REWRITE TECH PARTS FOR +FOREIGNPRIMOP VERSION. Haskell heap structures can be serialised, capturing their current state of evaluation, and deserialised later during the same program @@ -78,8 +76,8 @@ module GHC.Packing -- could make a compatibility layer for Eden-GHC-7.x (supports -- serialize#) but we rather bail out here. -#if __GLASGOW_HASKELL__ != 708 -#error This module assumes GHC-7.8 +#if __GLASGOW_HASKELL__ < 708 +#error This module assumes GHC-7.8 or above #endif import GHC.IO ( IO(..) ) @@ -114,6 +112,8 @@ import Control.Monad( when ) import qualified Control.Exception as E -- Typeable is also required for this +import Control.Concurrent.MVar -- for a global lock + ---------------------------------------------- -- replacement for the old GHC.Constants.TargetWord. This is a cheap @@ -146,7 +146,7 @@ foreign import prim "stg_unpack" unpack# :: ByteArray# -> State# s -> (# State# -- This should ensure (as of GHC.7.8) that types with the same name -- but different definition get different hashes. (however, we also -- require the executable to be exactly the same, so this is not --- "strictly necessary" anyway. +-- "strictly necessary" anyway). ----------------------------------------------- -- Typeable context for dynamic type checks. @@ -186,35 +186,47 @@ prgHash = unsafePerformIO $ -- but only when /externalising/ data (writing to disk, for instance). data Serialized a = Serialized { packetData :: ByteArray# } +-- serialisation and deserialisation code are not thread-safe and need +-- exclusive access (for now). This CAF-based solution is fragile but +-- at least easily portable. Essential: should never be inlined! +{-# NOINLINE globalLock #-} +globalLock :: MVar () +globalLock = unsafePerformIO (newMVar ()) + + +withLockHeld :: IO a -> IO a +withLockHeld = E.bracket_ (takeMVar globalLock) (putMVar globalLock ()) + -- | Non-blocking serialisation routine using @'PackException'@s to -- signal errors. This version does not block the calling thread when -- a black hole is found, but instead signals the condition by the -- @'P_BLACKHOLE'@ exception. trySerialize :: a -> IO (Serialized a) -- throws PackException (RTS) -trySerialize x = do r <- trySer_ x -- a more verbose way of writing it... - case r of - Left err -> E.throw err - Right packed -> return packed +trySerialize x = withLockHeld $ trySer_ x >>= either E.throw return + -- using a helper function trySer_ :: a -> IO (Either PackException (Serialized a)) trySer_ x = IO (\s -> case tryPack# (unsafeCoerce# x :: Any) s of (# s', 0#, bArr# #) -> (# s', Right (Serialized { packetData=bArr# }) #) - (# s', n#, _ #) -> (# s', Left (tagToEnum# n# ) #) + (# s', n#, _ #) -> (# s', Left (decodeEx n# ) #) ) -- | Deserialisation function. May throw @'PackException'@ @'P_GARBLED'@ -deserialize :: Serialized a -> IO a -- throws PackException (garbled) -deserialize ( Serialized{..} ) = IO $ - \s -> case unpack# packetData s of - (# s', 0#, x #) -> (# s', x #) - (# s', n#, _ #) -> (# s', E.throw ((tagToEnum# n#)::PackException) #) +deserialize :: Serialized a -> IO a +deserialize = withLockHeld . deser_ + +deser_ :: Serialized a -> IO a -- throws PackException (garbled) +deser_ ( Serialized{..} ) + = IO $ \s -> case unpack# packetData s of + (# s', 0#, x #) -> (# s', x #) + (# s', n#, _ #) -> (# s', E.throw (decodeEx n#) #) -------------------------------------------------------- -- | Packing exception codes, matching error codes implemented in the -- runtime system or describing errors which can occur within Haskell. -data PackException = P_SUCCESS -- | all fine, ==0. We do not expect this one to occur. - -- Error codes from the runtime system: (how can I teach haddock to make this a heading?) +data PackException = P_SUCCESS -- | no error, ==0. We do not expect this one to occur. + -- Error codes from the runtime system: | P_BLACKHOLE -- ^ RTS: packing hit a blackhole (not blocking thread) | P_NOBUFFER -- ^ RTS: buffer too small (increase RTS buffer with -qQ) | P_CANNOT_PACK -- ^ RTS: found a closure that cannot be packed (MVar, TVar) @@ -226,7 +238,18 @@ data PackException = P_SUCCESS -- | all fine, ==0. We do not expect this on | P_BinaryMismatch -- ^ Haskell: Executable binaries do not match | P_TypeMismatch -- ^ Haskell: Packet data encodes unexpected type deriving (Eq, Ord, Typeable) --- enum.. we will use tagtoenum# later + +-- | decode an 'Int#' to a @'PackException'@ +decodeEx :: Int# -> PackException +-- with hsc2hs: #include "Errors.h"; #define DECODE(ex) decode #{const ex} = ex +decodeEx 0# = P_SUCCESS -- unexpected +decodeEx 1# = P_BLACKHOLE +decodeEx 2# = P_NOBUFFER +decodeEx 3# = P_CANNOT_PACK +decodeEx 4# = P_UNSUPPORTED +decodeEx 5# = P_IMPOSSIBLE +decodeEx 6# = P_GARBLED +decodeEx i# = error $ "Error value " ++ show (I# i#) ++ " not defined!" instance Show PackException where show P_SUCCESS = "No error." -- we do not expect to see this diff --git a/cbits/GHCFunctions.h b/cbits/GHCFunctions.h new file mode 100644 index 0000000..a61a388 --- /dev/null +++ b/cbits/GHCFunctions.h @@ -0,0 +1,39 @@ +/* Packing as a library: + * + * GHC functions linked into the C code we use + * + */ + +#include +// This brings in a lot of declared functions. + +// All these are internal functions of the GHC runtime. While their +// functionality is usually very stable, future versions might need to +// #ifdef-out or modify some of these declarations. + + +// Internal functions in the GHC runtime +extern char* info_type(StgClosure*); +extern char* info_type_by_ip(StgInfoTable*); + +// Internal hash table implementation +typedef struct hashtable HashTable; +extern HashTable *allocHashTable(void); +extern void *lookupHashTable(HashTable *table, StgWord key); +extern void insertHashTable(HashTable *table, StgWord key, void *data); +extern void *removeHashTable(HashTable *table, StgWord key, void *data); +extern void freeHashTable(HashTable *table, void (*freeDataFun)(void *)); + +// Internal malloc wrapper functions +extern void *stgMallocBytes(int n, char *msg) GNUC3_ATTRIBUTE(__malloc__); +extern void stgFree(void* p); + +// a fixed reference point when using relocatable binaries, to offset +// info pointers and plc pointers. +// See "relocatable binaries" before "PackNearbyGraph" routine for use. +#define BASE_SYM ZCMain_main_info // base symbol for offset +extern const StgInfoTable BASE_SYM[]; + +#ifdef DEBUG +extern void checkClosure(StgClosure*); +#endif diff --git a/cbits/Pack.c b/cbits/Pack.c index fb58d9c..018c17c 100644 --- a/cbits/Pack.c +++ b/cbits/Pack.c @@ -4,11 +4,13 @@ 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. + Derived from RTS code used in GUM and Eden. - (Outdated) Documentation for heap closures can be found at + 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 + However, the best documentation is includes/rts/storage/Closure*h + and rts/sm/Scav.c + */ #include @@ -16,24 +18,13 @@ #include "Types.h" #include "Errors.h" +#include "GHCFunctions.h" -#define DEBUG_HEADROOM 2 - -/* Internal functions in the GHC runtime, but very stable */ -extern char* info_type(StgClosure*); -extern char* info_type_by_ip(StgInfoTable*); - -/* Internal hash table implementation */ -typedef struct hashtable HashTable; -extern HashTable *allocHashTable(void); -extern void *lookupHashTable(HashTable *table, StgWord key); -extern void insertHashTable(HashTable *table, StgWord key, void *data); -extern void *removeHashTable(HashTable *table, StgWord key, void *data); -extern void freeHashTable(HashTable *table, void (*freeDataFun)(void *)); - -/* Internal malloc wrapper functions */ -extern void *stgMallocBytes(int n, char *msg) GNUC3_ATTRIBUTE(__malloc__); -extern void stgFree(void* p); +#ifdef DEBUG +#define DBG_HEADROOM 2 +#else +#define DBG_HEADROOM 0 +#endif // for better reading only... ATTENTION: given in bytes! /* #define RTS_PACK_BUFFER_SIZE RtsFlags.ParFlags.packBufferSize */ @@ -68,8 +59,6 @@ extern void stgFree(void* p); /* Info pointer <--> Info offset (also for PLC pointers) See "relocatable binaries" before "PackNearbyGraph" routine for use. */ -#define BASE_SYM ZCMain_main_info // base symbol for offset -extern const StgInfoTable BASE_SYM[]; // use this one on info pointers before they go into a packet #define P_OFFSET(ip) ((StgWord) ((StgWord) (ip)) - (StgWord) BASE_SYM) @@ -187,7 +176,9 @@ static StgClosure *UnpackArray(StgInfoTable *info, StgWord **bufptrP, Given the amount of static variables in this code, we go with the lock solution as a first version. -*/ + + IMPORTANT: Note that this is not active in the packman code. + Packman uses a lock at the Haskell level instead (for now). */ #if defined(THREADED_RTS) Mutex pack_mutex; #endif @@ -217,7 +208,7 @@ static char fingerPrintStr[MAX_FINGER_PRINT_LEN]; static void GraphFingerPrint(StgClosure *graphroot); static HashTable *tmpClosureTable; // used in GraphFingerPrint and PrintGraph -void checkPacket(pmPackBuffer *packBuffer); +void pmcheckPacket(pmPackBuffer *packBuffer); #endif // functionality: @@ -233,7 +224,7 @@ void pmInitPackBuffer(void) if ((globalPackBuffer = (pmPackBuffer *) stgMallocBytes(sizeof(pmPackBuffer) + RTS_PACK_BUFFER_SIZE - + sizeof(StgWord)*DEBUG_HEADROOM, + + sizeof(StgWord)*DBG_HEADROOM, "InitPackBuffer")) == NULL) { barf("InitPackBuffer: could not allocate."); } @@ -409,15 +400,17 @@ get_closure_info(StgClosure* node, StgInfoTable* info, // NB nonptrs field for array closures is only used in checkPacket break; - /* Small arrays do not have card tables, straightforward. */ - /* case SMALL_MUT_ARR_PTRS_CLEAN: */ - /* case SMALL_MUT_ARR_PTRS_DIRTY: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN0: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN: */ - /* *vhs = 1; // ptrs field */ - /* *ptrs = ((StgSmallMutArrPtrs*) node)->ptrs; */ - /* *nonptrs = 0; */ - /* break; */ +#if __GLASGOW_HASKELL__ > 708 + /* Small arrays do not have card tables, straightforward. */ + case SMALL_MUT_ARR_PTRS_CLEAN: + case SMALL_MUT_ARR_PTRS_DIRTY: + case SMALL_MUT_ARR_PTRS_FROZEN0: + case SMALL_MUT_ARR_PTRS_FROZEN: + *vhs = 1; // ptrs field + *ptrs = ((StgSmallMutArrPtrs*) node)->ptrs; + *nonptrs = 0; + break; +#endif /* we do not want to see these here (until thread migration) */ case CATCH_STM_FRAME: @@ -482,7 +475,7 @@ STATIC_INLINE rtsBool RoomToPack(nat size) >= RTS_PACK_BUFFER_SIZE)) { - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch("Pack buffer full (size %d). " "Sending partially to receiver.", pack_locn)); @@ -533,7 +526,7 @@ STATIC_INLINE void StuffClosureQueue(void) ASSERT(ClosureQueue != NULL); ASSERT(clq_pos<=clq_size); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Stuffing closure queue (length %d).", QueueSize()); PrintClosureQueue()); if (clq_pos < clq_size) { @@ -544,7 +537,7 @@ STATIC_INLINE void StuffClosureQueue(void) // adjust position and size clq_size = clq_size - clq_pos; clq_pos = 0; - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Closure queue now:"); PrintClosureQueue()); return; @@ -569,7 +562,7 @@ STATIC_INLINE void QueueClosure(StgClosure* closure) { ASSERT(clq_pos <= clq_size); if (clq_size < RTS_PACK_BUFFER_SIZE/sizeof(StgClosure*)) { - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch(">__> Q: %p (%s); %ld elems in q\n", closure, info_type(UNTAG_CLOSURE(closure)), (long)clq_size-clq_pos+1)); @@ -594,14 +587,14 @@ STATIC_INLINE void QueueClosure(StgClosure* closure) STATIC_INLINE StgClosure* DeQueueClosure(void) { if (!QueueEmpty()) { - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch(">__> DeQ: %p (%s); %ld elems in q\n", ClosureQueue[clq_pos], info_type(UNTAG_CLOSURE(ClosureQueue[clq_pos])), (long)clq_size-clq_pos-1)); return (ClosureQueue[clq_pos++]); } else { - IF_DEBUG(packet, debugBelch("Q empty\n ")); + IF_DEBUG(sparks, debugBelch("Q empty\n ")); return ((StgClosure*)NULL); } } @@ -718,29 +711,16 @@ pmPackBuffer* pmPackNearbyGraph(StgClosure* closure, StgTSO* tso) InitPacking(rtsFalse); - IF_DEBUG(verbose, + IF_DEBUG(prof, debugBelch("Packing subgraph @ %p\n", closure)); - IF_DEBUG(pack, - debugBelch("packing:"); - debugBelch("id <%ld> (buffer @ %p); graph root @ %p [PE %d]\n", - (long)globalPackBuffer->id, globalPackBuffer, - closure, thisPE); + IF_DEBUG(prof, + debugBelch("packing: buffer @ %p); graph root @ %p\n", + globalPackBuffer, closure); GraphFingerPrint(closure); debugBelch(" demanded by TSO %d (%p); Fingerprint is\n" "\t{%s}\n", (int)(tso?tso->id:0), tso, fingerPrintStr)); -#if !defined(PARALLEL_RTS) - IF_DEBUG(scheduler, - debugBelch("packing:"); - debugBelch("id <%ld> (buffer @ %p); graph root @ %p\n", - (long)globalPackBuffer->id, globalPackBuffer, - closure); - GraphFingerPrint(closure); - debugBelch(" demanded by TSO %d (%p); Fingerprint is\n" - "\t{%s}\n", - (int)(tso?tso->id:0), tso, fingerPrintStr)); -#endif QueueClosure(closure); do { @@ -753,7 +733,7 @@ pmPackBuffer* pmPackNearbyGraph(StgClosure* closure, StgTSO* tso) /* Check for buffer overflow (again) */ - ASSERT((pack_locn - DEBUG_HEADROOM) * sizeof(StgWord) + ASSERT((pack_locn - DBG_HEADROOM) * sizeof(StgWord) <= RTS_PACK_BUFFER_SIZE); IF_DEBUG(sanity, // write magic end-of-buffer word globalPackBuffer->buffer[pack_locn++] = END_OF_BUFFER_MARKER); @@ -765,13 +745,13 @@ pmPackBuffer* pmPackNearbyGraph(StgClosure* closure, StgTSO* tso) /* done packing */ DonePacking(); - IF_DEBUG(pack, - debugBelch("** Finished <<%ld>> packing graph %p (%s); packed size: %ld; size of graph: %ld\n", - (long)globalPackBuffer->id, closure, info_type(UNTAG_CLOSURE(closure)), + IF_DEBUG(prof, + debugBelch("** Finished packing graph %p (%s); packed size: %ld; size of graph: %ld\n", + closure, info_type(UNTAG_CLOSURE(closure)), (long)globalPackBuffer->size, (long)globalPackBuffer->unpacked_size));; - IF_DEBUG(sanity, checkPacket(globalPackBuffer)); + IF_DEBUG(sanity, pmcheckPacket(globalPackBuffer)); return (globalPackBuffer); } @@ -844,7 +824,7 @@ loop: case FUN_STATIC: case THUNK_STATIC: // all these are packed with their tag (closure is still tagged here) - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("*>~~ Packing a %p (%s) as a PLC\n", closure, info_type_by_ip(info))); @@ -884,7 +864,7 @@ loop: * type as a pointer field. */ - IF_DEBUG(packet, + IF_DEBUG(sparks, StgClosure *selectee = ((StgSelector *) UNTAG_CLOSURE(closure))->selectee; debugBelch("*>** Found THUNK_SELECTOR at %p (%s)" @@ -947,7 +927,7 @@ loop: // 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. - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("packing hit a %s at %p, no TSO given (returning).\n", info_type_by_ip(info), closure)); return P_BLACKHOLE; @@ -963,8 +943,9 @@ loop: case MVAR_CLEAN: case MVAR_DIRTY: case TVAR: - errorBelch("Pack: packing type %s (%p) not possible", - info_type_by_ip(info), closure); + IF_DEBUG(prof, + errorBelch("Pack: packing type %s (%p) not possible", + info_type_by_ip(info), closure)); return P_CANNOTPACK; case ARR_WORDS: @@ -979,14 +960,15 @@ loop: of mutable arrays. => perhaps impossible to find out from the RTS whether we should allow duplication of the array or not. */ - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Packing pointer array @ %p!", closure)); return PackArray(closure); case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: // these guys are known as IORefs in the Haskell world - errorBelch("Pack: packing type %s (%p) not possible", - info_type_by_ip(info),closure); + IF_DEBUG(prof, + errorBelch("Pack: packing type %s (%p) not possible", + info_type_by_ip(info),closure)); return P_CANNOTPACK; case WEAK: @@ -1012,35 +994,35 @@ loop: goto impossible; case WHITEHOLE: -#ifdef THREADED_RTS // closure is spin-locked, loop back and spin until changed. Take the big // round to avoid compiler optimisations getting into the way write_barrier(); goto loop; -#else - // something's very wrong - barf("Pack: found WHITEHOLE while packing"); + // valid only for the threaded RTS... cannot distinguish here + +#if __GLASGOW_HASKELL__ > 708 + case SMALL_MUT_ARR_PTRS_CLEAN: + case SMALL_MUT_ARR_PTRS_DIRTY: + case SMALL_MUT_ARR_PTRS_FROZEN: + case SMALL_MUT_ARR_PTRS_FROZEN0: + /* unlike the standard arrays, small arrays do not have a card table + * Layout is thus: +------------------------------+ + * | hdr | #ptrs | payload (ptrs) | + * +------------------------------+ + * No problem with using PackGeneric and vhs=1 in get_closure_info */ + return PackGeneric(closure); #endif - /* case SMALL_MUT_ARR_PTRS_CLEAN: */ - /* case SMALL_MUT_ARR_PTRS_DIRTY: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN0: */ - /* unlike the standard arrays, small arrays do not have a card table. - * Layout is thus: +------------------------------+ - * | hdr | #ptrs | payload (ptrs) | - * +------------------------------+ - * No problem with using PackGeneric and vhs=1 in get_closure_info. */ - /* return PackGeneric(closure); */ - unsupported: - errorBelch("Pack: packing type %s (%p) not implemented", - info_type_by_ip(info), closure); + IF_DEBUG(prof, + errorBelch("Pack: packing type %s (%p) not implemented", + info_type_by_ip(info), closure)); return P_UNSUPPORTED; impossible: - errorBelch("{Pack}Daq Qagh: found %s (%p) when packing", - info_type_by_ip(info), closure); + IF_DEBUG(prof, + errorBelch("{Pack}Daq Qagh: found %s (%p) when packing", + info_type_by_ip(info), closure)); return P_IMPOSSIBLE; default: @@ -1062,7 +1044,7 @@ static StgWord PackGeneric(StgClosure* closure) ASSERT(!pmIsBlackhole(closure)); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("*>== %p (%s): generic packing" "(size=%d, ptrs=%d, nonptrs=%d, and tag %d)\n", closure, info_type(closure), size, ptrs, nonptrs, @@ -1203,7 +1185,7 @@ static StgWord PackPAP(StgPAP *pap) barf("PackPAP: strange info pointer, type %d ", get_itbl((StgClosure*)pap)->type); } - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Packing Closure with stack (%s) @ %p," "stack size %d\n", info_type((StgClosure*) pap), pap, args)); @@ -1293,7 +1275,7 @@ static StgWord PackPAP(StgPAP *pap) // size refers to the bitmap for the whole function. bitmap = BITMAP_BITS(bitmap); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Packing stack chunk, size %d (PAP.n_args=%d), bitmap %#o\n", size, (int)args, (nat)bitmap)); @@ -1329,7 +1311,7 @@ static StgWord PackPAP(StgPAP *pap) * Header can be 1 (normal) or 2 StgWords (Thunk Header) */ - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("packed PAP, stack contained %d pointers\n", size)); return P_SUCCESS; @@ -1387,7 +1369,7 @@ static StgWord PackArray(StgClosure *closure) // the function in ClosureMacros.h would include the header: // arr_words_sizeW(stgCast(StgArrWords*,q)); - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch("*>== %p (%s): packing array" "(%d words) (size=%d)\n", closure, info_type(closure), payloadsize, @@ -1475,19 +1457,12 @@ StgClosure* pmUnpackGraph(pmPackBuffer *packBuffer, Capability* cap) StgClosure *graphroot; IF_DEBUG(sanity, // do a sanity check on the incoming packet - checkPacket(packBuffer)); + pmcheckPacket(packBuffer)); -#if !defined(PARALLEL_RTS) - IF_DEBUG(scheduler, + IF_DEBUG(prof, debugBelch("Packing: Header unpacked. (bufsize=%" FMT_Word ", heapsize=%" FMT_Word ")\nUnpacking closures now...\n", packBuffer->size, packBuffer->unpacked_size)); -#else - IF_DEBUG(pack, - debugBelch("Packing: Header unpacked. (bufsize=%" FMT_Word - ", heapsize=%" FMT_Word ")\nUnpacking closures now...\n", - packBuffer->size, packBuffer->unpacked_size)); -#endif graphroot = pmUnpackGraph_(packBuffer->buffer, packBuffer->size, cap); @@ -1520,7 +1495,7 @@ StgClosure* pmUnpackGraph_(StgWord *buffer, StgInt size, Capability* cap) nat pptr = 0, pptrs = 0, pvhs = 0; nat currentOffset; - IF_DEBUG(packet, debugBelch("Unpacking buffer @ %p, size %" FMT_Word, + IF_DEBUG(sparks, debugBelch("Unpacking buffer @ %p, size %" FMT_Word, buffer, size)); // Initialisation: alloc. hash table and queue, take lock @@ -1551,18 +1526,14 @@ StgClosure* pmUnpackGraph_(StgWord *buffer, StgInt size, Capability* cap) if (closure == NULL) { // something is wrong with the packet, give up immediately // we do not try to find out details of what is wrong... -#if !defined(PARALLEL_RTS) - IF_DEBUG(scheduler, debugBelch("Unpacking error at address %p",bufptr)); -#else - IF_DEBUG(pack, debugBelch("Unpacking error at address %p",bufptr)); -#endif + IF_DEBUG(prof, debugBelch("Unpacking error at address %p",bufptr)); DonePacking(); return (StgClosure *) NULL; } // store closure address for offsets (if we should, see above) if (currentOffset != 0) { - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("---> Entry in Offset Table: (%d, %p)\n", currentOffset, closure)); // note that the offset is stored WITH TAG @@ -1577,14 +1548,8 @@ StgClosure* pmUnpackGraph_(StgWord *buffer, StgInt size, Capability* cap) if (parent == NULL) { /* we are at the root. Do not remove the tag */ graphroot = closure; -#if !defined(PARALLEL_RTS) - IF_DEBUG(scheduler, debugBelch("Graph root %p, tag %x", closure, + IF_DEBUG(prof, debugBelch("Graph root %p, tag %x", closure, (int) GET_CLOSURE_TAG(closure))); -#else - IF_DEBUG(pack, - debugBelch("Graph root %p, tag %x", closure, - (int) GET_CLOSURE_TAG(closure))); -#endif } else { // packet fragmentation code would need to check whether // there is a temporary blackhole here. Not supported for now. @@ -1619,17 +1584,10 @@ StgClosure* pmUnpackGraph_(StgWord *buffer, StgInt size, Capability* cap) // ToDo: are we *certain* graphroot has been set??? WDP 95/07 ASSERT(graphroot!=NULL); -#if !defined(PARALLEL_RTS) - IF_DEBUG(scheduler, + IF_DEBUG(prof, GraphFingerPrint(graphroot); debugBelch(">>> Fingerprint of unpacked graph rooted at %p:\n" "\t{%s}\n", graphroot, fingerPrintStr)); -#else - IF_DEBUG(pack, - GraphFingerPrint(graphroot); - debugBelch(">>> Fingerprint of unpacked graph rooted at %p\n" - "\t{%s}\n", graphroot, fingerPrintStr)); -#endif return graphroot; } @@ -1748,7 +1706,7 @@ UnpackClosure (StgWord **bufptrP, Capability* cap) */ tag = GET_CLOSURE_TAG((StgClosure*) **bufptrP); ip = UNTAG_CAST(StgInfoTable*, P_POINTER(**bufptrP)); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("pointer tagging: removed tag %d " "from info pointer %p in packet\n", (int) tag, ip)); @@ -1814,12 +1772,14 @@ UnpackClosure (StgWord **bufptrP, Capability* cap) case THUNK_1_1: case THUNK_0_2: case THUNK_SELECTOR: - /* case SMALL_MUT_ARR_PTRS_CLEAN: */ - /* case SMALL_MUT_ARR_PTRS_DIRTY: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN0: */ - /* case SMALL_MUT_ARR_PTRS_FROZEN: */ +#if __GLASGOW_HASKELL__ > 708 + case SMALL_MUT_ARR_PTRS_CLEAN: + case SMALL_MUT_ARR_PTRS_DIRTY: + case SMALL_MUT_ARR_PTRS_FROZEN0: + case SMALL_MUT_ARR_PTRS_FROZEN: +#endif - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Allocating %d heap words for %s-closure:\n" "(%d ptrs, %d non-ptrs, vhs = %d)\n" , size, info_type_by_ip(INFO_PTR_TO_STRUCT(ip)), @@ -1939,7 +1899,7 @@ static StgClosure * UnpackPAP(StgInfoTable *info, StgWord **bufptrP, Capability* INFO_PTR_TO_STRUCT(info)->type); return (StgClosure *) NULL; } - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("allocating %d heap words for a PAP(%d args)\n", size, args)); pap = (StgPAP *) allocate(cap, size); @@ -1963,11 +1923,13 @@ static StgClosure * UnpackPAP(StgInfoTable *info, StgWord **bufptrP, Capability* for (i = hsize+1; i < size; i++) { StgClosure* ind; switch ((long) **bufptrP) { + // TODO should probably pack the bitmap? + // function will arrive later, cannot use its bitmap now. case PLC: // skip marker, unpack data into stack (*bufptrP)++; ((StgPtr) pap)[i] = (StgWord) *(*bufptrP)++; - IF_DEBUG(packet, bitmap |= 1); // set bit in bitmap + IF_DEBUG(sanity, bitmap |= 1); // set bit in bitmap break; case CLOSURE: // skip 2 markers, create/enqueue indirection, put it on the stack @@ -1991,6 +1953,8 @@ static StgClosure * UnpackPAP(StgInfoTable *info, StgWord **bufptrP, Capability* "%d args, constructed bitmap %#o.\n", info_type((StgClosure*) pap),pap, args, (int) bitmap)); + // XXX compare to stored bitmap. + // XXXXXX why not store the bitmap in the first place? return (StgClosure*) pap; } @@ -2025,7 +1989,7 @@ UnpackArray(StgInfoTable* info, StgWord **bufptrP, Capability* cap) * but we read it using the selector function in ClosureMacros.h */ size = sizeofW(StgArrWords) + arr_words_words((StgArrWords*) *bufptrP); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Unpacking word array, size %d\n", size)); array = (StgMutArrPtrs *) allocate(cap, size); @@ -2053,7 +2017,7 @@ UnpackArray(StgInfoTable* info, StgWord **bufptrP, Capability* cap) size = closure_sizeW_((StgClosure*) *bufptrP, INFO_PTR_TO_STRUCT(info)); ASSERT(size == sizeofW(StgMutArrPtrs) + ((StgMutArrPtrs*) *bufptrP)->size); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("Unpacking ptrs array, %" FMT_Word " ptrs, size %d\n", (StgWord) *((*bufptrP)+1), size)); @@ -2076,7 +2040,7 @@ UnpackArray(StgInfoTable* info, StgWord **bufptrP, Capability* cap) return (StgClosure *) NULL; } - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch(" Array created @ %p.\n",array)); return (StgClosure*) array; @@ -2094,7 +2058,7 @@ STATIC_INLINE StgClosure *UnpackPLC(StgWord **bufptrP) // but need to correct the offset plc = (StgClosure*) P_POINTER(**bufptrP); (*bufptrP)++; // skip address - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("*<^^ Unpacked PLC at %p\n", plc)); return plc; } @@ -2115,7 +2079,7 @@ STATIC_INLINE StgClosure *UnpackOffset(StgWord **bufptrP) // find this closure in an offset hashtable (we can have several packets) existing = (StgClosure *) lookupHashTable(offsetTable, offset); - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("*<__ Unpacked indirection to closure %p (was OFFSET %d, current padding %d)", existing, offset, offsetpadding)); @@ -2136,7 +2100,7 @@ StgClosure* restoreUnpackState(UnpackInfo* unpack,StgClosure** graphroot, nat size, i; StgClosure* parent; - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch("restore unpack state")); ASSERT(unpack != NULL); @@ -2159,7 +2123,7 @@ StgClosure* restoreUnpackState(UnpackInfo* unpack,StgClosure** graphroot, stgFree(unpack->queue); stgFree(unpack); - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch("unpack state restored (graphroot: %p, current " "parent: %p (ptr %d of %d, vhs= %d, offset %d).", *graphroot, parent, *pptr, *pptrs, *pvhs, offsetpadding)); @@ -2177,13 +2141,13 @@ StgClosure** saveQueue(nat* size) { if (*size == 0) return NULL; // no queue to save // queue to save: - IF_DEBUG(packet, + IF_DEBUG(sparks, debugBelch("saveQueue: saving "); PrintClosureQueue()); queue = (StgClosure **) stgMallocBytes(*size * sizeof(StgClosure*), "saveQueue: Queue"); memcpy(queue, ClosureQueue+clq_pos, *size * sizeof(StgClosure*)); - IF_DEBUG(packet, + IF_DEBUG(sparks, { nat j; debugBelch("saveQueue: saved this queue:\n"); for (j = 0; j < *size; j++) @@ -2199,7 +2163,7 @@ UnpackInfo* saveUnpackState(StgClosure* graphroot, StgClosure* parent, nat size; save = stgMallocBytes(sizeof(UnpackInfo),"saveUnpackState: UnpackInfo"); - IF_DEBUG(pack, + IF_DEBUG(prof, 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)); @@ -2216,7 +2180,7 @@ UnpackInfo* saveUnpackState(StgClosure* graphroot, StgClosure* parent, save->offsetpadding = offsetpadding; // padding for keys in offsetTable save->offsets = offsetTable; // hashtable remains allocated - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch("unpack state saved (offsetpadding %d in " "hashtable at %p, %d closures in queue at %p).", save->offsetpadding, save->offsets, @@ -2308,8 +2272,14 @@ StgClosure* pmUnpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap) */ /* this array has to be kept in sync with includes/ClosureTypes.h */ -#if !(N_CLOSURE_TYPES == 65 ) -#error Wrong closure type count in fingerprint array. Check code. +#if __GLASGOW_HASKELL__ == 708 +# if !(N_CLOSURE_TYPES == 61 ) +# error Wrong closure type count in fingerprint array. Check code. +# endif +#elif __GLASGOW_HASKELL__ > 708 +# if !(N_CLOSURE_TYPES == 65 ) +# error Wrong closure type count in fingerprint array. Check code. +# endif #endif static char* fingerPrintChar = "0ccccccCC" /* INVALID CONSTRs (0-8) */ @@ -2319,7 +2289,10 @@ static char* fingerPrintChar = "RRRRFFFF" /* RETs FRAMEs (32-39) */ "*@MMT" /* BQ BLACKHOLE MVARs TVAR (40-43) */ "aAAAAmmwppXS" /* ARRAYs MUT_VARs WEAK PRIM MUT_PRIM TSO STACK (44-55) */ - "&FFFWZZZZ" /* TREC (STM-)FRAMEs WHITEHOLE SmallArr (56-64) */ + "&FFFW" /* TREC (STM-)FRAMEs WHITEHOLE (56-60)*/ +#if __GLASGOW_HASKELL__ >= 708 + "ZZZZ" /* SmallArr (61-64) */ +#endif ; @@ -2651,7 +2624,7 @@ print: case WHITEHOLE: break; -#if 0 +#if __GLASGOW_HASKELL__ > 708 case SMALL_MUT_ARR_PTRS_CLEAN: case SMALL_MUT_ARR_PTRS_DIRTY: case SMALL_MUT_ARR_PTRS_FROZEN0: @@ -2679,14 +2652,14 @@ print: /* Doing a sanity check on a packet. This does a full iteration over the packet, as in UnpackGraph. */ -void checkPacket(pmPackBuffer *packBuffer) +void pmcheckPacket(pmPackBuffer *packBuffer) { StgInt packsize, openptrs; nat clsize, ptrs, nonptrs, vhs; StgWord *bufptr; HashTable *offsets; - IF_DEBUG(pack, debugBelch("checking packet (@ %p) ...", + IF_DEBUG(prof, debugBelch("checking packet (@ %p) ...", packBuffer)); offsets = allocHashTable(); // used to identify valid offsets @@ -2699,7 +2672,7 @@ void checkPacket(pmPackBuffer *packBuffer) StgWord tag; StgInfoTable *ip; - IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER)); + ASSERT(*bufptr != END_OF_BUFFER_MARKER); // unpackclosure essentials are mimicked here tag = *bufptr; // marker in buffer (PLC | OFFSET | CLOSURE) @@ -2737,7 +2710,7 @@ void checkPacket(pmPackBuffer *packBuffer) ip = get_closure_info((StgClosure*) bufptr, INFO_PTR_TO_STRUCT(ip), &clsize, &ptrs, &nonptrs, &vhs); - // IF_DEBUG(pack,debugBelch("size (%ld + %d + %d +%d, = %d)", + // IF_DEBUG(sparks,debugBelch("size (%ld + %d + %d +%d, = %d)", // HEADERSIZE, vhs, ptrs, nonptrs, clsize)); // This is rather a test for get_closure_info...but used here @@ -2797,7 +2770,7 @@ void checkPacket(pmPackBuffer *packBuffer) } while (openptrs != 0 && packsize < packBuffer->size); - IF_DEBUG(pack, + IF_DEBUG(prof, debugBelch(" traversed %" FMT_Word " words, %" FMT_Word " open pointers ", packsize, openptrs)); @@ -2814,7 +2787,7 @@ void checkPacket(pmPackBuffer *packBuffer) } freeHashTable(offsets, NULL); - IF_DEBUG(pack, debugBelch("packet OK\n")); + IF_DEBUG(prof, debugBelch("packet OK\n")); } diff --git a/pack.old b/pack.old new file mode 100644 index 0000000..a4786ab Binary files /dev/null and b/pack.old differ diff --git a/packman.cabal b/packman.cabal index b1a68c6..cf37ce8 100644 --- a/packman.cabal +++ b/packman.cabal @@ -12,10 +12,12 @@ extra-source-files: cbits/Wrapper.cmm cbits/Pack.c cbits/Errors.h cbits/Types.h + test/pack.old -flag debug +flag Debug description: Enable debug support default: False +-- we abuse flags "prof(p)" and "sparks(r)" and use "sanity(S)" library exposed-modules: GHC.Packing @@ -34,6 +36,14 @@ library if flag(debug) cc-options: -g -DDEBUG +test-suite simpletest + type: exitcode-stdio-1.0 + main-is: test/TestSerialisation.hs + build-depends: base, array, binary, ghc-prim, bytestring, directory, packman + if flag(debug) + ghc-options: -debug + + -- executable test-server -- hs-source-dirs: test -- main-is: Server.hs diff --git a/test/Main.hs b/test/Main.hs index 095fb95..b72919d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,18 +1,13 @@ module Main where -import Data.Serialize.Packman +import GHC.Packing -- Data.Serialize.Packman +import Control.Exception data Foo = A | B | C | D deriving Show -packAndPrint o = case pack o of - Left err -> putStrLn "Error" - Right _ -> putStrLn "Serialized!" +packAndPrint o = trySerialize o >> putStrLn "Serialized" -packAndUnpack o = case pack o of - Left err -> putStrLn "Error" - Right buf -> case unpack buf of - Left err -> putStrLn "Unpack error" - Right a -> print a +packAndUnpack o = trySerialize o >>= deserialize >>= print main = do packAndPrint A diff --git a/test/TestSerialisation.hs b/test/TestSerialisation.hs new file mode 100644 index 0000000..9d452ac --- /dev/null +++ b/test/TestSerialisation.hs @@ -0,0 +1,107 @@ +{- + Some tests to +-} +-- module TestSerialisation(tests) +-- where + +import GHC.Packing + +import qualified Data.Array.IArray as A +import Control.Concurrent + +import System.Environment +import System.IO +import System.Directory + +import qualified Data.ByteString as B + +import qualified Control.Exception as E + +-- this test uses the trySerialize routine. We expect to trigger some +-- exceptions and catch them as appropriate. + +catchPackExc :: IO () -> IO () +catchPackExc io = io `E.catch` (\e -> putStrLn (show (e::PackException))) + +-- need a time-wasting function which allocates... +nfib :: Integer -> Integer +nfib 0 = 1 +nfib 1 = 1 +nfib n = let n1 = nfib (n-1) + n2 = nfib (n-2) + in 1 + 2*n1 + n2 - n1 + +-- test exceptions. When running this, one should capture +-- stdout (but not stderr) and compare to reference output +--testExc :: IO () +--testExc +main + = do hSetBuffering stdout NoBuffering + + putStrLn "Test program for packing/serialization:" + + let n = 1 -- if (length args < 2) then 1 else read (args!!1) + size = 128 -- if null args then 128 else read (head args)::Int + arr :: A.Array Int Int + arr = A.array (0,size-1) + [ (i,i) | i <- [0..size-1] ] + + let output = A.amap (2*) arr + putStrLn $ show $ take n $ A.elems output + + putStrLn "now packing the array (buffer big enough?)" + + catchPackExc $ + do packet1 <- trySerialize output + -- putStrLn (show packet1) + putStrLn "now unpacking (deserialize):" + copy <- deserialize packet1 + + putStrLn ("unpacked, now evaluate") + putStrLn (show copy) + + putStrLn "packing some forbidden types" + t <- myThreadId + putStrLn "next should be unsupported" + catchPackExc (trySerialize t >>= print) + + m <- newEmptyMVar :: IO (MVar Integer) + putStrLn "next should be cannotpack" + catchPackExc (trySerialize m >>= print) + + putStrLn "next should hit a blackhole" + let b = nfib (-1) -- will loop, but so far unevaluated + putMVar m b + forkIO $ do n <- takeMVar m + case n of -- poor child thread will evaluate bottom + something -> error $"bottom is " ++ show something ++ "!" + yield -- let child thread pick up the trap + catchPackExc (trySerialize b >>= print) + + let arr2 = A.listArray (0,n-1) (take n (A.elems arr)) :: A.Array Int Int + putStrLn "this - finally - should work" + putStrLn ( show $ arr2 A.! 0 ) -- forcing it + catchPackExc $ + do p2 <- trySerialize arr2 + arr3 <- deserialize p2 + print arr3 + + putStrLn "trying to deserialise other binary's data. Expected: binary mismatch" + catchPackExc $ do a <- decodeFromFile "pack.old" + print (a::A.Array Int Int) + + putStrLn "trying to deserialise wrong type from file. Expected: type mismatch" + catchPackExc $ do encodeToFile "pack" arr2 + a <- decodeFromFile "pack" + print (a::A.Array Int Double) + + putStrLn "trying to deserialise truncated data. Expected: parse error" + blob <- B.readFile "pack" + B.writeFile "pack" (B.take 50 blob) -- take more than FingerPrint (4 x Word64) + catchPackExc $ do p <- getProgName + x <- decodeFromFile "pack" :: IO (A.Array Int Int) + print x + (removeFile "pack") `E.catch` (\e -> print (e::E.SomeException) ) + + putStrLn "DONE" +