jberthold/packman
1
1
Fork 0
mirror of https://github.com/jberthold/packman.git synced 2024-08-16 17:00:22 +03:00
Code Issues Projects Releases Wiki Activity

Some adjustments, towards more robust version

Browse Source 
- lock (haskell level)
- cabal file and C code with debug support
- test suite (one program for now)
This commit is contained in:
Jost Berthold 2014-07-24 20:35:52 +02:00
parent 5a7eab42cd
commit 714ab55854
7 changed files with 338 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
GHC/Packing.hs
View File

@ -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<size>)
| 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

39
cbits/GHCFunctions.h Normal file
View File

@ -0,0 +1,39 @@
/* Packing as a library:
*
* GHC functions linked into the C code we use
*
*/
#include <Rts.h>
// 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

281
cbits/Pack.c
View File

@ -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 <Rts.h>
@ -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"));
}

BIN
pack.old Normal file
View File

Binary file not shown.

12
packman.cabal
View File

@ -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

13
test/Main.hs
View File

@ -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

107
test/TestSerialisation.hs Normal file
View File

@ -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"