diff --git a/GHC/Packing.hs b/GHC/Packing.hs new file mode 100644 --- /dev/null +++ b/GHC/Packing.hs @@ -0,0 +1,224 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | + +Module : GHC.Packing +Copyright : (c) Jost Berthold, 2010-2015, +License : BSD3 +Maintainer : jost.berthold@gmail.com +Stability : experimental +Portability : no (depends on GHC internals) + += Serialisation of Haskell data structures (independent of evaluation) + +Haskell heap structures can be serialised, capturing their current +state of evaluation, and deserialised later during the same program +run (effectively duplicating the data). Serialised data can also be +written to storage or sent over a network, and deserialised in a +different run or different instance of the /same/ executable binary. + +The feature can be used to implement message passing over a network +(which is where the runtime support originated), or for various +applications based on data persistence, for instance checkpointing and +memoisation. + +The library described here supports an operation to serialise Haskell +heap data: + +> trySerialize :: a -> IO (Serialized a) + +The routine will throw a 'PackException' if an error occurs inside the +C code which accesses the Haskell heap (see @'PackException'@). +In presence of concurrent threads, another thread might be evaluating +data /referred to/ by the data to be serialised. In this case, the calling +thread will /block/ on the ongoing evaluation and continue when evaluated +data is available. +Internally, there is a 'PackException' 'P_BLACKHOLE' to signal the +condition, but it is hidden inside the core library +(see <#background Background Information> below). + +The inverse operation to serialisation is + +> deserialize :: Serialized a -> IO a + +The data type 'Serialized' a includes a phantom type @a@ to ensure +type safety within one and the same program run. Type @a@ can be +polymorphic (at compile time, that is) when 'Serialized' @a@ is not used +apart from being argument to 'deserialize'. + +The @Show@, @Read@, and @Binary@ instances of @Serialized a@ require an +additional 'Typeable' context (which requires @a@ to be monomorphic) +in order to implement dynamic type checks when parsing and deserialising +data from external sources. +Consequently, the 'PackException' type contains exceptions which indicate +parse errors and type/binary mismatch. + +-} + +module GHC.Packing + ( -- * Serialisation Operations + trySerialize, trySerializeWith + , deserialize + + -- * Data Types and instances + , Serialized + -- $ShowReadBinary + , PackException(..) + -- $packexceptions + + -- * Serialisation and binary file I/O + , encodeToFile + , decodeFromFile + + -- * Background Information + -- $primitives + ) + where + +-- all essentials are defined in other modules, and reexported here +import GHC.Packing.PackException +import GHC.Packing.Type +import GHC.Packing.Core + +import Data.Binary +import Control.Exception +import Data.Typeable + + +-- | Write serialised binary data directly to a file. May throw 'PackException's. +encodeToFile :: Typeable a => FilePath -> a -> IO () +encodeToFile path x = trySerialize x >>= encodeFile path + +-- | Directly read binary serialised data from a file. May throw +-- 'PackException's (catches I/O and Binary exceptions from decoding +-- the file and re-throws 'P_ParseError') +decodeFromFile :: Typeable a => FilePath -> IO a +decodeFromFile path = do ser <- (decodeFile path) + `catch` + (\(e::ErrorCall) -> throw P_ParseError) + deserialize ser -- exceptions here go through + +---------------------------------------- +-- digressive documentation + +{- $ShowReadBinary + +The power of evaluation-orthogonal serialisation is that one can +/externalise/ partially evaluated data (containing thunks), for +instance write it to disk or send it over a network. + +Therefore, the module defines a 'Data.Binary' instance for +'Serialized' a, as well as instances for 'Read' and 'Show'@ which +satisfy @ 'read' . 'show' == 'id' :: 'Serialized' a -> 'Serialized' a@. + +The phantom type is enough to ensure type-correctness when serialised +data remain in one single program run. However, when data from +previous runs are read in from an external source, their type needs to +be checked at runtime. Type information must be stored together with +the (binary) serialisation data. + +The serialised data contain pointers to static data in the generating +program (top-level functions and constants) and very likely to +additional library code. Therefore, the /exact same binary/ must be +used when reading in serialised data from an external source. A hash +of the executable is therefore included in the representation as well. + +-} + +{- $packexceptions + +'PackException's can occur at Haskell level or in the foreign primop. +The Haskell-level exceptions all occur when reading in +'GHC.Packing.Serialised' data, and are: + +* 'P_BinaryMismatch': the serialised data have been produced by a +different executable (must be the same binary). +* 'P_TypeMismatch': the serialised data have the wrong type +* 'P_ParseError': serialised data could not be parsed (from binary or +text format) + +The other exceptions are return codes of the foreign primitive +operation, and indicate errors at the C level. Most of them occur when +serialising data; the exception is 'P_GARBLED' which indicates corrupt +serialised data. + +-} + +{- $primitives + + #background# + +The functionality exposed by this module builds on serialisation of +Haskell heap graph structures, first implemented in the context of +implementing the GpH implementation GUM (Graph reduction on a +Unified Memory System) and later adopted by the implementation of +Eden. Independent of its evaluation state, data and thunks can be +transferred between the (independent) heaps of several running Haskell +runtime system instances which execute the same executable. + +The idea to expose the heap data serialisation functionality +(often called /packing/) to Haskell by itself was first described in + Jost Berthold. /Orthogonal Serialisation for Haskell/. + In Jurriaan Hage and Marco Morazan, editors, + /IFL'10, 22nd Symposium on Implementation and Application of + Functional Languages/, Springer LNCS 6647, pages 38-53, 2011. +This paper can be found at +, +the original publication is available at +. + +The core runtime support consists of just two operations: +(slightly paraphrasing the way in which GHC implements the IO monad here) + +> serialize# :: a -> IO ByteArray# -- OUTDATED, see below +> deserialize# :: ByteArray# -> IO a -- which is actually pure from a mathematical POW + +However, these operations are completely unsafe with respect to Haskell +types, and may fail at runtime for various other reasons as well. +Type safety can be established by a phantom type, but needs to be checked +at runtime when the resulting data structure is externalised (for instance, +saved to a file). Besides prohibiting unprotected type casts, another +restriction that needs to be explicitly checked in this case is that +different programs cannot exchange data by this serialisation. When data are +serialised during execution, they can only be deserialised by exactly the +same executable binary because they contain code pointers that will change +even by recompilation. + +Other failures can occur because of the runtime system's limitations, +and because some mutable data types are not allowed to be serialised. +A newer API therefore suggests additions towards exception handling +and better usability. +The original primitive @'serialize'@ is modified and now returns error +codes, leading to the following type (again paraphrasing): + +> trySerialize# :: a -> IO ( Int# , ByteArray# ) + +where the @Int#@ encodes potential error conditions returned by the runtime. + +A second primitive operation has been defined, which uses a pre-allocated +@ByteArray#@ + +> trySerializeWith# :: a -> ByteArray# -> IO ( Int# , ByteArray# ) + +Further to returning error codes, the newer primitive operation do not block +the calling thread when the serialisation encounters a blackhole in the +heap. +It would be possible to observe the existence of blackholes from Haskell by +the return code of these primitive operation. This could - in theory - be +used to explicitly control and avoid blocking (avoiding unresponsive behaviour). +In practice, however, making blackholes observable from Haskell is +certainly undesirable. The primitive operations return the address of the +blackhole, and the caller will block on this blackhole at +the Haskell level (see code in the @GHC.Packing.Core@ module). + +The Haskell layer and its types protect the interface function @'deserialize'@ +from being applied to grossly wrong data (by checking a fingerprint of the +executable and the expected type), but deserialisation is still rather fragile +(unpacking code pointers and data). +The primitive operation in the runtime system will only detect grossly wrong +formats, and the primitive will return error code @'P_GARBLED'@ when data +corruption is detected. + +> deserialize# :: ByteArray# -> IO ( Int# , a ) +-} diff --git a/GHC/Packing/Core.hs b/GHC/Packing/Core.hs new file mode 100644 --- /dev/null +++ b/GHC/Packing/Core.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# LANGUAGE GHCForeignImportPrim, ForeignFunctionInterface, + UnliftedFFITypes #-} + +{-| + +Module : GHC.Packing +Copyright : (c) Jost Berthold, 2010-2015, +License : BSD3 +Maintainer : jost.berthold@gmail.com +Stability : experimental +Portability : no (depends on GHC internals) + += Wrapper module for the foreign primitive operations + +-} + +module GHC.Packing.Core + ( trySerialize, trySerializeWith, deserialize + ) where + +import GHC.Packing.Type +import GHC.Packing.PackException + +import GHC.Exts +import GHC.Prim +import Control.Monad.Primitive +import Data.Primitive.ByteArray + +import Control.Exception(throw) + +-- the entire package won't support GHC < 7.8 +#if __GLASGOW_HASKELL__ < 708 +#error This module assumes GHC-7.8 or above +#endif + +-- | Serialises its argument (in current evaluation state, as a thunk). +-- May block if the argument captures (blackhole'd) data under evaluation, +-- may throw 'PackException's to signal errors. +-- This version uses a default buffer of 10MB (see 'trySerializeWith' +-- for a version with flexible buffer size). +trySerialize :: a -> IO (Serialized a) -- throws PackException (RTS) +trySerialize x = trySerializeWith x defaultBufSize + +-- | default buffer size used by trySerialize +defaultBufSize :: Int +defaultBufSize = 10 * 2^20 -- 10 MB + +-- | Extended serialisation interface: Allocates a buffer of given size (in +-- bytes), serialises data into it, then truncates the buffer to the +-- required size before returning it (as @'Serialized' a@) +trySerializeWith :: a -> Int -> IO (Serialized a) -- using instance PrimMonad IO +trySerializeWith dat bufsize + = do buf <- newByteArray bufsize + size <- trySerializeInto buf dat + buf' <- truncate' buf size + ByteArray b# <- unsafeFreezeByteArray buf' + return (Serialized { packetData = b# }) + +-- | core routine. Packs x into mutable byte array buf, returns size +-- of packed x in buf +trySerializeInto :: MutableByteArray RealWorld -> a -> IO Int +trySerializeInto (MutableByteArray buf# ) x + = primitive (tryPack (unsafeCoerce# x :: Any) buf# ) + +-- | calls primitive, decodes/throws errors + wraps Int# size into Int +tryPack :: Any -> MutableByteArray# s + -> State# s -> (# State# s , Int #) +tryPack x# buf# s = case tryPack# x# buf# s of + (# s', 0#, size# #) -> (# s', I# size# #) + (# s', e#, 0# #) + | isBHExc e# -> repack s' + | otherwise -> (# s', throw (decodeEx e#) #) + where -- packing blocked, eval the blocking closure that we found + -- (i.e. block on it) and re-pack afterwards. The first + -- StgWord of the ByteArray contains the address (written by + -- the packing routine, see BLACKHOLE case in packClosure). + repack s = case readAddrArray# buf# 0# s of + (# s', bh #) -> case (addrToAny# bh) of -- or seq it? + _ -> tryPack x# buf# s' + +-- | serialisation primitive, implemented in C. Returns: a +-- status/error code and size used inside the array +foreign import prim "stg_tryPack" tryPack# + :: Any -> MutableByteArray# s -> State# s -> (# State# s, Int#, Int# #) + +-- GHC-7.8 does not have an in-place shrink operation for MutableByteArrays +-- (added in GHC-7.9 on August 16, 2014) +-- GHC-7.9, August 2014 :: MutableByteArray# s -> Int# -> State# s -> State# s +-- with this one available, tryPack could do the work +-- for GHC-7.8, we copy +truncate' :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> m (MutableByteArray (PrimState m)) +truncate' b size + = if sizeofMutableByteArray b < size + then throw P_NOBUFFER -- XXX other error? + else do b' <- newByteArray size + copyMutableByteArray b' 0 b 0 size + return b' + +-------------------------------------------------------- + +-- | Deserialisation function. May throw @'PackException'@ @'P_GARBLED'@ +deserialize :: Serialized a -> IO a +deserialize p = primitive (deser (packetData p)) + +deser :: ByteArray# -> State# s -> (# State# s, a #) +deser buf s = case unpack# buf s of + (# s', 0#, x #) -> (# s', x #) + (# s', n#, _ #) -> (# s', throw (decodeEx n#) #) + +foreign import prim "stg_unpack" unpack# :: ByteArray# -> State# s -> (# State# s, Int#, a #) + diff --git a/GHC/Packing/PackException.hsc b/GHC/Packing/PackException.hsc new file mode 100644 --- /dev/null +++ b/GHC/Packing/PackException.hsc @@ -0,0 +1,100 @@ +{-# LANGUAGE MagicHash, DeriveDataTypeable #-} + +{-| + +Module : GHC.Packing.PackException +Copyright : (c) Jost Berthold, 2010-2015, +License : BSD3 +Maintainer : jost.berthold@gmail.com +Stability : experimental +Portability : no (depends on GHC internals) + +Exception type for packman library, using magic constants #include'd +from a C header file shared with the foreign primitive operation code. + +'PackException's can occur at Haskell level or in the foreign primop. + +All Haskell-level exceptions are cases of invalid data when /reading/ +and /deserialising/ 'GHC.Packing.Serialised' data: + +* 'P_BinaryMismatch': serialised data were produced by a +different executable (must be the same binary). +* 'P_TypeMismatch': serialised data have the wrong type +* 'P_ParseError': serialised data could not be parsed (from binary or +text format) + +The exceptions caused by the foreign primops (return codes) +indicate errors at the C level. Most of them can occur when +serialising data; the exception is 'P_GARBLED' which indicates that +serialised data is garbled. + +-} + +module GHC.Packing.PackException + ( PackException(..) + , decodeEx + , isBHExc + ) where + +-- bring in error codes from cbits/Errors.h +#include "Errors.h" + +import GHC.Exts +import GHC.Prim +import Control.Exception +import Data.Typeable + +-- | Packing exception codes, matching error codes implemented in the +-- runtime system or describing errors which can occur within Haskell. +data PackException = + -- keep in sync with Errors.h + P_SUCCESS -- ^ no error, ==0. + -- Internal code, should never be seen by users. + | P_BLACKHOLE -- ^ RTS: packing hit a blackhole. + -- Used internally, not passed to users. + | P_NOBUFFER -- ^ RTS: buffer too small + | P_CANNOTPACK -- ^ RTS: contains closure which cannot be packed (MVar, TVar) + | P_UNSUPPORTED -- ^ RTS: contains unsupported closure type (implementation missing) + | P_IMPOSSIBLE -- ^ RTS: impossible case (stack frame, message,...RTS bug!) + | P_GARBLED -- ^ RTS: corrupted data for deserialisation + + -- Error codes from inside Haskell + | P_ParseError -- ^ Haskell: Packet data could not be parsed + | P_BinaryMismatch -- ^ Haskell: Executable binaries do not match + | P_TypeMismatch -- ^ Haskell: Packet data encodes unexpected type + deriving (Eq, Ord, Typeable) + +-- | decodes an 'Int#' to a @'PackException'@. Magic constants are read +-- from file /cbits///Errors.h/. +decodeEx :: Int## -> PackException +decodeEx #{const P_SUCCESS}## = P_SUCCESS -- unexpected +decodeEx #{const P_BLACKHOLE}## = P_BLACKHOLE +decodeEx #{const P_NOBUFFER}## = P_NOBUFFER +decodeEx #{const P_CANNOTPACK}## = P_CANNOTPACK +decodeEx #{const P_UNSUPPORTED}## = P_UNSUPPORTED +decodeEx #{const P_IMPOSSIBLE}## = P_IMPOSSIBLE +decodeEx #{const P_GARBLED}## = P_GARBLED +decodeEx #{const P_ParseError}## = P_ParseError +decodeEx #{const P_BinaryMismatch}## = P_BinaryMismatch +decodeEx #{const P_TypeMismatch}## = P_TypeMismatch +decodeEx i## = error $ "Error value " ++ show (I## i##) ++ " not defined!" + +instance Show PackException where + -- keep in sync with Errors.h + show P_SUCCESS = "No error." -- we do not expect to see this + show P_BLACKHOLE = "Packing hit a blackhole" + show P_NOBUFFER = "Pack buffer too small" + show P_CANNOTPACK = "Data contain a closure that cannot be packed (MVar, TVar)" + show P_UNSUPPORTED = "Contains an unsupported closure type (whose implementation is missing)" + show P_IMPOSSIBLE = "An impossible case happened (stack frame, message). This is probably a bug." + show P_GARBLED = "Garbled data for deserialisation" + show P_ParseError = "Packet parse error" + show P_BinaryMismatch = "Executable binaries do not match" + show P_TypeMismatch = "Packet data has unexpected type" + +instance Exception PackException + +-- | internal: checks if the given code indicates 'P_BLACKHOLE' +isBHExc :: Int## -> Bool +isBHExc #{const P_BLACKHOLE}## = True +isBHExc e## = False diff --git a/GHC/Packing/Type.hs b/GHC/Packing/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Packing/Type.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE CPP, MagicHash, BangPatterns, ScopedTypeVariables #-} + +{-| + +Module : GHC.Packing.Type +Copyright : (c) Jost Berthold, 2010-2015, +License : BSD3 +Maintainer : Jost Berthold +Stability : experimental +Portability : no (depends on GHC internals) + += Serialized type for the packman library, instances and helpers + +The data type @'Serialized' a@ includes a phantom type @a@ to ensure +type safety within one and the same program run. Type @a@ can be +polymorphic (at compile time, that is) when @'Serialized' a@ is not used +apart from being argument to @'deserialize'@. + +The @Show@, @Read@, and @Binary@ instances of @Serialized a@ require an +additional @Typeable@ context (which requires @a@ to be monomorphic) +in order to implement dynamic type checks when parsing and deserialising +data from external sources. + +-} + +module GHC.Packing.Type +-- ( Serialized(..) +-- TOOD assemble export list with structure and headings/text blocks +-- , ... ) + where + +import GHC.Prim -- ByteArray# +import GHC.Exts ( Int(..)) -- I# + +-- Read and Show instances +import Text.Printf ( printf ) +import Text.ParserCombinators.ReadP (sepBy1, many1, ReadP, munch, + munch1, pfail, readP_to_S, satisfy, skipSpaces, string ) +import Data.Char ( isDigit ) + +-- Binary instance +import Data.Binary ( Get, Binary(..), encode, decode, encodeFile, decodeFile ) + +-- we use UArrays of machine word size (TargetWord) +import Data.Word( Word, Word64, Word32 ) +import Data.Array.Base ( UArray(..), elems, listArray ) +import Foreign.Storable ( sizeOf ) + +-- for dynamic type checks when parsing +import Data.Typeable (Typeable(..), typeOf) +#if MIN_VERSION_base(4,8,0) +import Data.Typeable.Internal (TypeRep(..), typeRepFingerprint) +#else +import Data.Typeable.Internal (TypeRep(..)) +#endif +import qualified GHC.Fingerprint + +-- for a hash of the executable. Using GHC.Fingerprint.getFileHash +import GHC.Fingerprint(getFileHash) +import System.Environment +import System.IO.Unsafe + +-- for control flow and exceptions +import Control.Monad(when) +import Control.Exception(throw) + +import GHC.Packing.PackException + +-- | The type of Serialized data. Phantom type 'a' ensures that we +-- unpack data as the expected type. +data Serialized a = Serialized { packetData :: ByteArray# } + +{- $ShowReadBinary + +The power of evaluation-orthogonal serialisation is that one can +/externalise/ partially evaluated data (containing thunks), for +instance write it to disk or send it over a network. +Therefore, the module defines a 'Binary' instance for 'Serialized a', +as well as instances for 'Read' and 'Show'@ which satisfy + +> read . show == id :: 'Serialized' a -> 'Serialized' a + +The phantom type is enough to ensure type-correctness when serialised +data remain in one single program run. However, when data from +previous runs are read from an external source, their type needs to +be checked at runtime. Type information must be stored together with +the (binary) serialisation data. + +The serialised data contain pointers to static data in the generating +program (top-level functions and constants) and very likely to +additional library code. Therefore, the /exact same binary/ must be +used when reading in serialised data from an external source. A hash +of the executable is included in the representation to ensure this. + +-} + +-- | prints packet as Word array in 4 columns (/Word/ meaning the +-- machine word size), and additionally includes Fingerprint hash +-- values for executable binary and type. +instance Typeable a => Show (Serialized a) where + show p = unlines [ "Serialization Packet, size " ++ show size, + ", program " ++ show prgHash, + ", type fingerprint" ++ show t, + showWArray (UArray 0 (size-1) size dat) ] + where size = case sizeofByteArray# dat of + sz# -> (I# sz# ) `div` sizeOf(undefined::TargetWord) + t = typeFP ( undefined :: a ) + dat = packetData p + +-- | Helper to show a serialized structure as a packet (Word Array) +showWArray :: UArray Int TargetWord -> String +showWArray arr = unlines [ show i ++ ":" ++ unwords (map showH row) + | (i,row) <- zip [0,4..] elRows ] + where showH w = -- "\t0x" ++ showHex w " " + printf ('\t':hexWordFmt) w + elRows = takeEach4 (elems arr) + + takeEach4 :: [a] -> [[a]] + takeEach4 [] = [] + takeEach4 xs = first:takeEach4 rest + where (first,rest) = splitAt 4 xs + +----------------------------------------------- +-- | Reads the format generated by the 'Show' instance, checks +-- hash values for executable and type and parses exactly as much as +-- the included data size announces. +instance Typeable a => Read (Serialized a) + -- using ReadP parser (base-4.x) + where readsPrec _ input + = case parseP input of + [] -> throw P_ParseError -- no parse + [((sz,tp,dat),r)] + -> let !(UArray _ _ _ arr# ) = listArray (0,sz-1) dat + t = typeFP (undefined::a) + in if t == tp + then [(Serialized arr# , r)] + else throw P_TypeMismatch + other-> throw P_ParseError + -- ambiguous parse for packet + +-- | Packet Parser, reads the format generated by the @Read@ instance. +-- Could also consume other formats of the array (not implemented). +-- Returns: (data size in words, type fingerprint, array values) +parseP :: ReadS (Int, FP, [TargetWord]) +parseP = readP_to_S $ +-- read header with size and type, then iterate over array values, +-- reading several hex words in one row, separated by +-- tab and space. Packet size needed to avoid returning a prefix. + do string "Serialization Packet, size " + sz_str <- munch1 isDigit + let sz = read sz_str::Int + string ", program " + h <- munch1 (not . (== '\n')) + when (read h /= prgHash) (throw P_BinaryMismatch) + -- executables do not match. No ambiguous parses here, + -- so just throw; otherwise we would only pfail. + newline + string ", type " + tp <- munch1 (not . (== '\n')) + newline + let startRow = do { many1 digit; colon; tabSpace } + row = do { startRow; sepBy1 hexNum tabSpace } + valss <- sepBy1 row newline + skipSpaces -- eat remaining spaces + let vals = concat valss + l = length vals + -- filter out wrong lengths: + if (sz /= length vals) then pfail + else return (sz, read tp, vals) + +digit = satisfy isDigit +colon = satisfy (==':') +tabSpace = munch1 ( \x -> x `elem` " \t" ) +newline = munch1 (\x -> x `elem` " \n") + +hexNum :: ReadP TargetWord +hexNum = do string "0x" + ds <- munch hexDigit + return (read ("0x" ++ ds)) + where hexDigit = (\x -> x `elem` "0123456789abcdefABCDEF") + +------------------------------------------------------------------ + +-- | The binary format of @'Serialized' a@ data includes FingerPrint +-- hash values for type and executable binary, which are checked +-- when reading Serialized data back in using @get@. +instance Typeable a => Binary (Serialized a) where + -- We make our life simple and construct/deconstruct Word + -- (U)Arrays, quite as we did in the Show/Read instances. + put (Serialized bArr#) + = do put prgHash + put (typeFP (undefined :: a)) + let arr = UArray 0 (sz-1) sz bArr# :: UArray Int TargetWord + sz = case sizeofByteArray# bArr# of + sz# -> (I# sz# ) `div` sizeOf(undefined::TargetWord) + put arr + get = do hash <- get :: Get FP + when (hash /= prgHash) + (throw P_BinaryMismatch) + -- executables do not match + tp <- get :: Get FP + when (tp /= typeFP (undefined :: a)) + (throw P_TypeMismatch) + -- Type error during packet parse + uarr <- get :: Get (UArray Int TargetWord) + let !(UArray _ _ sz bArr#) = uarr + return ( Serialized bArr# ) + +------------------------------------------------------------------ +-- $ComparingTypes +----------------------------------------------- +-- Helper functions to compare types at runtime: +-- We use type "fingerprints" defined in 'GHC.Fingerprint.Type' + +-- 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). + +-- Typeable context for dynamic type checks. + +-- | The module uses a custom GHC fingerprint type with its two Word64 +-- fields, to be able to /read/ fingerprints +data FP = FP Word64 Word64 deriving (Read, Show, Eq) + +-- | checks whether the type of the given expression matches the given Fingerprint +matches :: Typeable a => a -> FP -> Bool +matches x (FP c1 c2) = f1 == c1 && f2 == c2 + where (GHC.Fingerprint.Fingerprint f1 f2) = typeRepFingerprint (typeOf x) + +#if ! MIN_VERSION_base(4,8,0) +-- typeRepFingerprint is provided since base-4.8.0.0 +typeRepFingerprint typeRep = ghcFP + where TypeRep ghcFP _ _ = typeRep +#endif + +-- | creates an 'FP' from a GHC 'Fingerprint' +toFP :: GHC.Fingerprint.Fingerprint -> FP +toFP (GHC.Fingerprint.Fingerprint f1 f2) = FP f1 f2 + +-- | returns the type fingerprint of an expression +typeFP :: Typeable a => a -> FP +typeFP = toFP . typeRepFingerprint . typeOf + +-- | Binary instance for fingerprint data (encoding TypeRep and +-- executable in binary-encoded @Serialized a@) +instance Binary FP where + put (FP f1 f2) = do put f1 + put f2 + get = do f1 <- get :: Get Word64 + f2 <- get :: Get Word64 + return (FP f1 f2) + +----------------------------------------------- + +-- | To check that the program (executable) is identical when packing +-- and unpacking, the fingerprint type from above is used (Read/Show +-- instances required). An 'FP' fingerprint of the executable is +-- computed once, by unsafePerformIO inside this CAF (safe to inline, +-- just inefficient). + +{-# NOINLINE prgHash #-} +prgHash :: FP +prgHash = unsafePerformIO $ + getExecutablePath >>= getFileHash >>= return . toFP + +----------------------------------------------- + +-- | The target word size is the size of a machine word on the +-- platform we run on. +-- +-- This type is only used in Binary, Read and Show instances, where +-- packets are stored as 'UArrays' of 'TargetWord'. +-- +-- Actually, GHC uses machine word size (as Haskell 2010 spec. does +-- not fix it) so we could just use Word. See +-- + +-- We'd rather just import 'GHC.Constants.TargetWord' but it was +-- removed. This code here is a cheap and incomplete hack, as the +-- package would otherwise need a configure script. + +#if x86_64_BUILD_ARCH +type TargetWord = Word64 +hexWordFmt = "0x%016x" +#elif i386_BUILD_ARCH +type TargetWord = Word32 +hexWordFmt = "0x%08x" +#elif powerpc_BUILD_ARCH +#error Don't know word size of your Power-PC model +#else +#warning Don't know the word size on your machine. +type TargetWord = Word +#endif diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +The packman serialisation library for GHC +Copyright (c) 2014-15, Jost Berthold +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/AllTests.hs b/Test/AllTests.hs new file mode 100644 --- /dev/null +++ b/Test/AllTests.hs @@ -0,0 +1,98 @@ +{- + Some tests to verify that serialisation works as expected +-} +module AllTests(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 Control.Exception +import Data.Typeable + +import Distribution.TestSuite + +-- this test uses the trySerialize routine. We expect to trigger some +-- exceptions and catch them as appropriate. + +catchPackExc :: IO () -> IO () +catchPackExc io = io `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 + +-- make a test instance. Action should check result and return Bool +runIt :: String -> IO Bool -> TestInstance +runIt name action + = TestInstance + { run = action >>= return . Finished . + (\b -> if b then Pass + else Fail "unexpected output (see log)") + , name = "Test case " ++ name + , tags = [] + , options = [] + , setOption = \_ _ -> Right (runIt name action) + } + +tests :: IO [ Test ] +tests = do putStrLn "Running all tests" + mapM (return . Test . uncurry runIt) mytests + +-- all configured tests, see below +mytests = [eval_array, pack_array, pack_ThreadId, pack_MVar ] + +-- test data +arr, output :: A.Array Int Int +arr = A.array (0,127) [ (i,i) | i <- [0..127] ] +output = A.amap (2*) arr + +n :: Int +n = 3 + +eval_array :: (String, IO Bool) +eval_array = ("eval. array", + do let out = show $ take n $ A.elems output + putStrLn $ "Evaluated: " ++ out + return (out == "[0,2,4]") + ) + +pack_array :: (String, IO Bool) +pack_array = ("duplicating an array of 128 elements", + do packet1 <- trySerialize output + putStrLn (take (3*80) (show packet1) ++ "...") + putStrLn "now unpacking (deserialize):" + copy <- deserialize packet1 + putStrLn ("unpacked, now evaluate") + putStrLn (show copy) + return $ copy == A.amap (2*) arr + ) + +expectException :: Typeable a => PackException -> IO (Serialized a) -> IO Bool +expectException exception action + = do putStrLn ("expect exception " ++ show exception) + action >>= print + return False + `catch` \e -> do putStrLn ("Got: " ++ show e) + return (e == exception) + +pack_ThreadId :: (String, IO Bool) +pack_ThreadId = ("packing a thread ID (unsupported)", + do t <- myThreadId + expectException P_UNSUPPORTED $ trySerialize t + ) +pack_MVar :: (String, IO Bool) +pack_MVar = ("packing an MVar (should be cannotpack)", + do m <- newEmptyMVar :: IO (MVar Integer) + expectException P_CANNOTPACK $ trySerialize m + ) diff --git a/Test/QCTest.hs b/Test/QCTest.hs new file mode 100644 --- /dev/null +++ b/Test/QCTest.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE RecordWildCards, DeriveFunctor #-} +module QCTest(tests) where + +import Distribution.TestSuite +import Test.QuickCheck + +import Data.Traversable(Traversable, traverse, sequenceA) +import Data.Foldable hiding (foldl,foldr) +import qualified Data.Foldable as F +import Control.Applicative + +import GHC.Packing + +-- use "detailed" interface: defining test instances +tests :: IO [Test] +tests = mapM (return . Test . uncurry (runQC 10)) + [boldTrees, foldmap square (+) 0, foldmapforce square (+) 0 ] + +square x = x*x + +-- boldTrees :: (Arbitrary a, Eq a, Show a) => (String, a -> Property) +boldTrees :: (String, RoseTree Int -> Property) +boldTrees = ("bold trees", + \t -> ioProperty (do t' <- duplicate t + return (t == t'))) + +foldmap f g x = ("foldmap", + \t -> ioProperty (do t' <- duplicate t + return (fm t == fm t'))) + where fm tree = F.foldr g x (fmap f tree) + +foldmapforce f g x = ("foldmapforce", + \t -> ioProperty (do let t'' = partEval t + t' <- t'' `seq` duplicate t'' + return (fm t == fm t'))) + where fm tree = F.foldr g x (fmap f tree) + +duplicate x = trySerialize x >>= deserialize + +------------------------ + +runQC :: (Arbitrary a, Show a, Testable p) => + Int -> String -> (a -> p) -> TestInstance +runQC size n prop = TestInstance + { name = "QC test " ++ n + , tags = [], options = [] + , setOption = \_ _ -> Right (runQC size n prop) + , run = do r <- quickCheckWithResult stdArgs{maxSize=size} prop + return (Finished (readResult r)) + } + where readResult :: Test.QuickCheck.Result -> Distribution.TestSuite.Result + readResult Success{..} = Pass + readResult GaveUp{..} = Fail ("Insufficient amount of tests (" + ++ show numTests ++ ")") + readResult Failure{..} = Fail output + readResult NoExpectedFailure{..} = Fail output + +-- our test data. Uses a number of different constructors... +data RoseTree a + = Withered a + | Rose1 a (RoseTree a) + | Rose2 a (RoseTree a) (RoseTree a) + | Rose3 a (RoseTree a) (RoseTree a) (RoseTree a) + | Rose4 a (RoseTree a) (RoseTree a) (RoseTree a) (RoseTree a) + -- finally, the normal one. + | RoseN a [RoseTree a] + deriving (Eq, Show, Read, Functor) + +-- meaningless function to force parts of a tree +partEval :: RoseTree a -> RoseTree a +partEval (Withered x) = x `seq` Withered x +partEval (Rose2 x t u) = partEval u `seq` x `seq` Rose2 x t u +partEval (Rose4 x t u v w) = partEval u `seq` partEval w `seq` x + `seq` Rose4 x t u v w +partEval t = t + +instance Foldable RoseTree + where -- foldr :: (a -> b -> b) -> b -> Rosetree a -> b + foldr f x (Withered a) = f a x + foldr f x (Rose1 a t) = f a (F.foldr f x t) + foldr f x (Rose2 a t u) + = -- f a (foldr (F.foldr f) x [t, u]) + f a (F.foldr f (F.foldr f x u) t) + foldr f x (Rose3 a t u v) = f a (foldl (F.foldr f) x [t,u,v]) + foldr f x (Rose4 a t u v w) = f a (foldl (F.foldr f) x [t,u,v,w]) + foldr f x (RoseN a ts) = f a (foldl (F.foldr f) x ts) + +instance Traversable RoseTree where + -- traverse :: Applicative f => (a -> f b) -> RoseTree a -> f (RoseTree b) + traverse f (Withered a) = Withered <$> f a + traverse f (Rose1 a t) = Rose1 <$> f a <*> traverse f t + traverse f (Rose2 a t u) = Rose2 <$> f a <*> traverse f t <*> traverse f u + traverse f (Rose3 a t u v) + = Rose3 <$> f a <*> traverse f t <*> traverse f u <*> traverse f v + traverse f (Rose4 a t u v w) + = Rose4 <$> f a <*> traverse f t <*> traverse f u + <*> traverse f v <*> traverse f w + traverse f (RoseN a ts) = RoseN <$> f a <*> sequenceA (map (traverse f) ts) + +instance Arbitrary a => Arbitrary (RoseTree a) where + arbitrary = sized rt + +rt :: Arbitrary a => Int -> Gen (RoseTree a) +rt 0 = arbitrary >>= return . Withered +rt n = oneof [ do t <- rt (n-1) + x <- arbitrary + return (Rose1 x t) + , do t <- rt (n-1); u <- rt (n-1) + x <- arbitrary + return (Rose2 x t u) + , do t <- rt (n-1); u <- rt (n-1); v <- rt (n-1) + x <- arbitrary + return (Rose3 x t u v) + , do t <- rt (n-1); u <- rt (n-1); v <- rt (n-1); w <- rt (n-1) + x <- arbitrary + return (Rose4 x t u v w) + , do i <- choose (5,n) + ts <- sequence (replicate i (rt (n-1))) + x <- arbitrary + return (RoseN x ts) + ] + +norm :: RoseTree a -> RoseTree a +norm (RoseN x []) = Withered x +norm (RoseN x [t]) = Rose1 x (norm t) +norm (RoseN x [t,u]) = Rose2 x (norm t) (norm u) +norm (RoseN x [t,u,v]) = Rose3 x (norm t) (norm u) (norm v) +norm (RoseN x [t,u,v,w]) = Rose4 x (norm t) (norm u) (norm v) (norm w) +norm t = t + diff --git a/Test/TestExceptions.hs b/Test/TestExceptions.hs new file mode 100644 --- /dev/null +++ b/Test/TestExceptions.hs @@ -0,0 +1,156 @@ +{- + Some tests to verify that serialisation works as expected +-} +module Main(mytests, main) + 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 Control.Exception +import Data.Typeable + +-- import Distribution.TestSuite +import System.Exit +import Control.Monad + +-- this test uses the trySerialize routine. We expect to trigger some +-- exceptions and catch them as appropriate. + +catchPackExc :: IO () -> IO () +catchPackExc io = io `catch` (\e -> putStrLn (show (e::PackException))) + +expectException :: (Show a) => PackException -> IO a -> IO Bool +expectException exception action + = do putStrLn ("expect exception:\n" ++ show exception) + action >>= print + return False + `catch` \e -> do putStrLn ("Got: " ++ show e) + return (e == exception) + +main :: IO () +main = do putStrLn "Running all tests" + args <- getArgs + let n = if (length args < 2) then 3 else read (args!!1) + size = if null args then 128 else read (head args)::Int + -- test data from arguments, avoiding over-optimisation + arr, arr2, output :: A.Array Int Int + arr = A.array (0,127) [ (i,i) | i <- [0..127] ] + output = A.amap (2*) arr + arr2 = A.listArray (0,2*n-1) (take (2*n) (A.elems arr)) + cfg = (output, arr2, n) + (mapM_ (runIt cfg) mytests) `finally` (rmv testfile) + +-- file used for all tests +testfile :: FilePath +testfile = "testfile" + +type Config = (A.Array Int Int, A.Array Int Int, Int) + +type MyTest = Config -> (String, IO Bool) + +-- run a defined test +runIt :: Config -> MyTest -> IO () +runIt cfg f + = do putStrLn $ "Test: " ++ name ++ ": " + result <- action + putStrLn $ "Result: " ++ show result + if not result then error "test failed!" else return () + where (name, action) = f cfg + +-- all configured tests, see below +mytests :: [ MyTest ] +mytests = [ evalArray, packArray, packThreadId, packMVar, + unpackOther, unpackWrongType, unpackTruncated, unpackGarbled ] + +evalArray :: MyTest +evalArray (output, _, n) + = ("eval. array", + do let out = show $ take n $ A.elems output + putStrLn $ "Evaluated: " ++ out + return (out == "[0,2,4]")) + +packArray :: MyTest +packArray (output, arr2, n) + = ("duplicating an array of 128 elements", + do packet1 <- trySerialize output + putStrLn (take (3*80) (show packet1) ++ "...") + putStrLn "now unpacking (deserialize):" + copy <- deserialize packet1 + putStrLn ("unpacked, now evaluate") + putStrLn (show copy) + return $ + take (2*n) (A.elems copy) == A.elems (A.amap (2*) arr2) + ) + +packThreadId :: MyTest +packThreadId _ = ("packing a thread ID (unsupported)", + do t <- myThreadId + expectException P_UNSUPPORTED $ trySerialize t + ) +packMVar :: MyTest +packMVar _ = ("packing an MVar (should be cannotpack)", + do m <- newEmptyMVar :: IO (MVar Integer) + expectException P_CANNOTPACK $ trySerialize m + ) + +unpackOther :: MyTest +unpackOther _ = ("deserialise other binary's data (binary mismatch)", + expectException P_BinaryMismatch + (decodeFromFile "pack.old" :: IO (A.Array Int Int)) + ) + +unpackWrongType :: MyTest +unpackWrongType (output, arr2, n) + = ("deserialise wrong type from file (type mismatch)", + do encodeToFile testfile arr2 + expectException P_TypeMismatch + (decodeFromFile testfile :: IO (A.Array Int Double)) + ) + +unpackTruncated :: MyTest +unpackTruncated (output, arr2, n) + = ("deserialise truncated data. Expected: parse error", + do encodeToFile testfile arr2 + blob <- B.readFile testfile + B.writeFile testfile (B.take 50 blob) + -- take more than FingerPrint (4 x Word64) + expectException P_ParseError + (decodeFromFile testfile :: IO (A.Array Int Int)) + ) + +unpackGarbled :: MyTest +unpackGarbled (output, arr2, n) + = ("deserialise garbled data. Expected: garbled data", + do encodeToFile testfile arr2 + blob <- B.readFile testfile + B.writeFile testfile (tamperWith blob) + expectException P_GARBLED + (decodeFromFile testfile :: IO (A.Array Int Int)) + ) + +tamperWith :: B.ByteString -> B.ByteString +tamperWith b = B.concat [b1, B.pack [11,11], B.drop 2 b2] + where n = B.length b + (b1,b2) = B.splitAt (n - 10) b +-- do not touch the FingerPrints (4 x Word64) + +-- file cleanup, catching all exceptions +rmv :: FilePath -> IO () +rmv f = (removeFile f) `catch` (\e -> print (e::SomeException)) + + +-- 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 diff --git a/Test/TestMThread.hs b/Test/TestMThread.hs new file mode 100644 --- /dev/null +++ b/Test/TestMThread.hs @@ -0,0 +1,106 @@ +-- testing serialisation with multiple concurrent threads + +import GHC.Packing + +import qualified Data.Array.IArray as A +import Control.Concurrent + +import System.Environment +import System.IO +import System.Directory +import System.Exit + +import qualified Data.ByteString as B + +import Control.Exception + +-- 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 + +fib :: Int -> Int +fib x | x <= 1 = 1 + |otherwise = fib (x-1) + fib (x-2) + +-- | duplicate data +duplicate :: a -> IO a +duplicate x = (deserialize =<< trySerialize x) + +testeval :: (Show b) => String -> a -> (a -> b) -> String -> IO () +testeval name dat f expected + = do putStr name + dat' <- duplicate dat + let out = show (f dat') + if (out /= expected) + then do putStrLn (": FAILED\t unexpected " ++ out) + error (name ++ " failed") + else putStrLn (": OK\t" ++ out) + +main + = do hSetBuffering stdout NoBuffering + + args <- getArgs + let u = if (null args) then 40 else read (head args) + n = if length args < 2 then 10 else read (args!!1) + + putStrLn "Multithreaded test program for serialisation" + let input = [20..u] + flt = filter (> 10000) + fibL = (flt . map fib) input +-- [10946,17711,28657,46368,75025,121393,196418,317811,514229,832040,1346269] + + putStrLn "normal evaluation (take 3), should be \n[10946,17711,28657]" + putStrLn (show $ take 3 fibL) + + let doThread i = + do v <- newEmptyMVar + -- note that all threads use fibL. Many calls to + -- trySerialize will block on blackholes (the core + -- operation will block and retry) + forkIO (do testeval (show i) + (cycle fibL) (!!i) + (show (fibL!!(i `mod` length fibL))) + putMVar v ()) + return v + vs <- mapM doThread [0..n-1] + + putStrLn "forked, waiting" + mapM_ takeMVar vs + putStrLn "done" +{- + + let f2 x y = fib (x+y) + testeval "packing a function (2 arg.s)" f2 + (\f -> (take 3 . flt . map (f 0)) input) + "[10946,17711,28657]" + + let f3 x a b c y d = head $ map (map fib) + [[(x+a+b+c+d)-const .. (y+a+b+c+d)-const ]] + const = head fibL - 1 + f3' = f3 (head fibL) 0 0 + const `seq` f3' `seq` + testeval "packing a list function (2 arg.s, 1 supplied)" + f3' (\f -> take 3 (flt (f 0 (u+const) 0))) + "[10946,17711,28657]" + + putStrLn "DONE" + + let n = max 10 u + size = 3*u -- default 120 + arr :: A.Array Int Int + arr = A.array (0,size-1) + [ (i,i) | i <- [0..size-1] ] + output = A.amap (2*) arr + + -- output some of the original elements + putStrLn $ show $ take n $ A.elems arr + + testeval "packing an unevaluated array" + output (take n . A.elems) + (show (take n [0,2..])) + +-} diff --git a/Test/TestSerialisation.hs b/Test/TestSerialisation.hs new file mode 100644 --- /dev/null +++ b/Test/TestSerialisation.hs @@ -0,0 +1,98 @@ +-- 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 System.Exit + +import qualified Data.ByteString as B + +import Control.Exception + +-- this test uses the trySerialize routine. We expect to trigger some +-- exceptions and catch them as appropriate. + +catchPackExc :: IO () -> IO () +catchPackExc io = io `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 + +fib :: Int -> Int +fib x | x <= 1 = 1 + |otherwise = fib (x-1) + fib (x-2) + +-- | duplicate data +duplicate :: a -> IO a +duplicate x = deserialize =<< trySerialize x + +-- | +testeval :: (Show b) => String -> a -> (a -> b) -> String -> IO () +testeval name dat f expected + = do putStr name + dat' <- duplicate dat + let out = show (f dat') + if (out /= expected) + then do putStrLn (": FAILED\t unexpected " ++ out) + error (name ++ " failed") + else putStrLn (": OK\t" ++ out) + +main + = do hSetBuffering stdout NoBuffering + + args <- getArgs + let u = if (null args) then 40 else read (head args) + putStrLn "Test program for serialisation" + putStrLn "Evaluating some fib expressions before and after packing" + let input = [20..u] + flt = filter (> 10000) + fibL = (flt . map fib) input +-- [10946,17711,28657,46368,75025,121393,196418,317811,514229,832040,1346269] + + putStrLn "normal evaluation (take 3), should be \n[10946,17711,28657]" + putStrLn (show $ take 3 fibL) + + testeval "packing one part" fibL (take 5) + "[10946,17711,28657,46368,75025]" + + let f2 x y = fib (x+y) + testeval "packing a function (2 arg.s)" f2 + (\f -> (take 3 . flt . map (f 0)) input) + "[10946,17711,28657]" + + let f3 x a b c y d = head $ map (map fib) + [[(x+a+b+c+d)-const .. (y+a+b+c+d)-const ]] + const = head fibL - 1 + f3' = f3 (head fibL) 0 0 + const `seq` f3' `seq` + testeval "packing a list function (2 arg.s, 1 supplied)" + f3' (\f -> take 3 (flt (f 0 (u+const) 0))) + "[10946,17711,28657]" + + putStrLn "DONE" + + let n = max 10 u + size = 3*u -- default 120 + arr :: A.Array Int Int + arr = A.array (0,size-1) + [ (i,i) | i <- [0..size-1] ] + output = A.amap (2*) arr + + -- output some of the original elements + putStrLn $ show $ take n $ A.elems arr + + testeval "packing an unevaluated array" + output (take n . A.elems) + (show (take n [0,2..])) + diff --git a/cbits/Errors.h b/cbits/Errors.h new file mode 100644 --- /dev/null +++ b/cbits/Errors.h @@ -0,0 +1,29 @@ + +#ifndef ERRORS_H +#define ERRORS_H + +/* + * Return codes for the packing routine (rts/parallel/Pack.c) + * Must be in sync with library code. + * We need them here for use in Cmm code in PrimOps.cmm + */ +#define P_SUCCESS 0x00 /* used for return value of PackToMemory only */ +#define P_BLACKHOLE 0x01 /* possibly also blocking the packing thread */ +#define P_NOBUFFER 0x02 /* buffer too small */ +#define P_CANNOTPACK 0x03 /* type cannot be packed (MVar, TVar) */ +#define P_UNSUPPORTED 0x04 /* type not supported (but could/should be) */ +#define P_IMPOSSIBLE 0x05 /* impossible type found (stack frame,msg, etc) */ +#define P_GARBLED 0x06 /* invalid data for deserialisation */ +// for completeness, we also include the Haskell error codes here: +#define P_ParseError 0x07 /* Packet parse error */ +#define P_BinaryMismatch 0x08 /* Executable binaries do not match */ +#define P_TypeMismatch 0x09 /* Packet data has unexpected type */ + +#undef P_ERRCODEMAX +#define P_ERRCODEMAX 0x09 + +// predicate for checks: +#define isPackError(bufptr) (((StgWord) (bufptr)) <= P_ERRCODEMAX) + +#endif + diff --git a/cbits/GHCFunctions.h b/cbits/GHCFunctions.h new file mode 100644 --- /dev/null +++ b/cbits/GHCFunctions.h @@ -0,0 +1,33 @@ +/* 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); + +#ifdef DEBUG +extern void checkClosure(StgClosure*); +#endif diff --git a/cbits/Pack.c b/cbits/Pack.c new file mode 100644 --- /dev/null +++ b/cbits/Pack.c @@ -0,0 +1,2791 @@ +/* + Packing for the Generic RTE: +-------- + + Graph packing and unpacking code for sending it to another processor + and retrieving the original graph structure from the packet. + Derived from RTS code used in GUM and Eden. + + 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/rts/storage/Closure*h + and rts/sm/Scav.c + + This file: a heavily revised version which uses a thread-local + internal pack state to make the code thread-safe. + + Code is shared between the library and the parallel RTS. Library code is + separated by PP symbol LIBRARY_CODE (code without it is shared or in-RTS). + +*/ + +#ifdef LIBRARY_CODE + +#include +#include + +#include "Types.h" +#include "Errors.h" +#include "GHCFunctions.h" + +#else + +// in-RTS version uses different includes +#include "Rts.h" +#include "RtsUtils.h" +#include "Hash.h" +#include "Threads.h" // updateThunk +#include "Messages.h" // messageBlackHole + +# if defined(DEBUG) +# include "sm/Sanity.h" +# endif + +#include "Printer.h" // printing closure info (also non-debug-enabled) + +#include // memset +#endif + +#ifdef DEBUG +#define DBG_HEADROOM 1 +#define END_OF_BUFFER_MARKER 0xdededeee +#else +#define DBG_HEADROOM 0 +#endif + +// debugging macros for library and in-RTS version +#ifdef LIBRARY_CODE +// for the library version, borrow flags "scheduler" and "sparks" +# define PACKDEBUG(s) IF_DEBUG(scheduler, s) +# define PACKETDEBUG(s) IF_DEBUG(sparks, s) +#else +// for the in-RTS version, use the usual macros +// XXX maybe drop support for the non-parallel in-RTS version +# ifdef PARALLEL_RTS +# define PACKDEBUG(s) IF_PAR_DEBUG(pack, s) +# define PACKETDEBUG(s) IF_PAR_DEBUG(packet, s) +# else +# define PACKDEBUG(s) IF_DEBUG(scheduler, s) +# define PACKETDEBUG(s) /* nothing */ +# endif +#endif + +// size of the (fixed) Closure header in words +#define HEADERSIZE sizeof(StgHeader)/sizeof(StgWord) + +// markers for packed/unpacked type +#define PLC 1L +#define OFFSET 2L +#define CLOSURE 3L +// marker for small bitmap in PAP packing +#define SMALL_BITMAP_TAG (~0UL) + +/* Tagging macros will work for any word-sized type, not only + closures. In the packet, we tag info pointers instead of + closure pointers. + See "pointer tagging" before "PackNearbyGraph" routine for use. +*/ +#define UNTAG_CAST(type,p) ((type) UNTAG_CLOSURE((StgClosure*) (p))) + +// Info pointer <--> Info offset (also for PLC pointers) +// See "relocatable binaries" before "PackNearbyGraph" routine for use. + +// 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[]; + +// use this one on info pointers before they go into a packet +#define P_OFFSET(ip) ((StgWord) ((StgWord) (ip)) - (StgWord) BASE_SYM) +// use this one on info offsets taken from packets +#define P_POINTER(val) ((StgWord)(val) + (StgWord) BASE_SYM) + +// padding for offsets into the already-packed data (failing lookup in the +// hashtable will produce 0, but offset 0 would be the graph root without +// padding) +#define PADDING 1 + +// internal types + +// closure queue: array implementation with wrap-around +// 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; +} 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 +#ifndef LIBRARY_CODE + StgTSO *tso; // in-RTS version: may block when accessing a blackhole +#endif + ClosureQ *queue; + HashTable *offsets; +} PackState; + +// forward declarations + +// Init module at startup +static void init(void) __attribute__((constructor)); + +// init/destruct pack data structure +#ifdef LIBRARY_CODE +static PackState* initPacking(StgArrWords *mutArr); +#else +static PackState* initRtsPacking(StgWord *buffer, nat size, StgTSO *tso); +#endif +static void donePacking(PackState *state); + +// closure queue +static ClosureQ* initClosureQ(nat size); +static void freeClosureQ(ClosureQ* q); +STATIC_INLINE rtsBool queueEmpty(ClosureQ* q); +STATIC_INLINE nat queueSize(ClosureQ* q); +static void queueClosure(ClosureQ* q, StgClosure *closure); +static StgClosure *deQueueClosure(ClosureQ* q); + +/*************************************************************** + * packing + */ + +// 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); + +// closure information +STATIC_INLINE StgInfoTable* getClosureInfo(StgClosure* node, StgInfoTable* info, + nat *size, nat *ptrs, + nat *nonptrs, nat *vhs); +#ifdef LIBRARY_CODE +// remains local when code is stand-alone for the library +STATIC_INLINE rtsBool pmIsBlackhole(StgClosure* node); +#define isBlackhole pmIsBlackhole +#else +// if compiling for the RTS: used in other files, declared in Parallel.h +// rtsBool isBlackhole(StgClosure* node); +#endif + +/************************ + * interface for packing + */ +#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); +#else +// in-RTS version: packToBuffer, declared in Parallel.h +// int packToBuffer(StgClosure* closure, +// StgWord *buffer, nat bufsize, StgTSO *caller); +// serialisation into a Haskell Byte array, returning error codes on failure +// StgClosure* tryPackToMemory(StgClosure* graphroot, StgTSO* tso, +// Capability* cap); +#endif + +// packing static addresses and offsets +STATIC_INLINE void PackPLC(PackState* p, StgPtr addr); +STATIC_INLINE void PackOffset(PackState* p, StgWord offset); +// packing routine, branches into special cases +static StgWord packClosure(PackState* p, StgClosure *closure); + +// low-level packing: fill one StgWord of data into the buffer +STATIC_INLINE void Pack(PackState* p, StgWord data); + +// the workhorses: generic heap-alloc'ed (ptrs-first) closure +static StgWord PackGeneric(PackState* p, StgClosure *closure); +// and special cases +static StgWord PackPAP(PackState* p, StgPAP *pap); +static StgWord PackArray(PackState* p, StgClosure* array); + +/*************************************************************** + * unpacking + */ + +/************************** + * interface for unpacking + */ +#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); +#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); +#endif + +// internal function working on the raw data buffer +static StgClosure* unpackGraph_(StgWord *buffer, StgInt size, Capability* cap); + +// helper function to find next pointer (filling in pointers) +STATIC_INLINE void locateNextParent(ClosureQ* q, StgClosure **parentP, + nat* pptrP, nat* pptrsP, nat* pvhsP); + +// core unpacking function +static StgClosure* UnpackClosure (ClosureQ* q, HashTable* offsets, + StgWord **bufptrP, Capability* cap); + +// helpers +STATIC_INLINE StgClosure *UnpackOffset(HashTable* offsets, StgWord **bufptrP); +STATIC_INLINE StgClosure *UnpackPLC(StgWord **bufptrP); +static StgClosure * UnpackPAP(ClosureQ *queue, StgInfoTable *info, + StgWord **bufptrP, Capability* cap); +static StgClosure* UnpackArray(ClosureQ *queue, StgInfoTable* info, + StgWord **bufptrP, Capability* cap); + + +/*********************************************** + * additional interface (used by in-RTS version) + */ +#ifndef LIBRARY_CODE +// creating fresh nodes in the heap. Used by in-RTS version (from other files, +// therefore all declared in Parallel.h) +// +// used here and by the primitive which creates new channels: +// creating a blackhole closure from scratch. +// Declared in Parallel.h +// StgClosure* createBH(Capability *cap); + +// used in HLComms: creating a list node +// Declared in Parallel.h +// StgClosure* createListNode(Capability *cap, +// StgClosure *head, StgClosure *tail); + +// A special structure used as the "owning thread" of system-generated +// blackholes. Layout [ hdr | payload ], holds a TSO header.info and blocking +// queues in the payload field. +// +// Used in: +// createBH (here), +// Threads::updateThunk + Messages::messageBlackHole (special treatment) +// ParInit::synchroniseSystem(init), +// Evac::evacuate (do not evacuate) and GC::garbageCollect (evac. BQueue) +StgInd stg_system_tso; + +#endif + +#if defined(DEBUG) +// finger print: "type hash" of packed graph, for quick debugging +// checks +#define MAX_FINGER_PRINT_LEN 1023 +static void graphFingerPrint(char* fp, StgClosure *graphroot); + +static void checkPacket(StgWord* buffer, nat size); +#endif + +/*************************************************************** + * init function (called when loading the module) + */ +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; +} + +/*************************************************************** + * pack state and queue functions + */ + +// Pack state constructor, allocates space, queue and hash table. +#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) { + PackState *ret; + + ret = (PackState*) stgMallocBytes(sizeof(PackState), "pack state"); + + ASSERT(mutArr->bytes > 0); + + ret->buffer = mutArr->payload; + ret->size = mutArr->bytes / sizeof(StgWord); + + ret->position = 0; + + // create a closure queue "big enough" => about what the array can hold + ret->queue = initClosureQ(ret->size / 2); + // new hash table + ret->offsets = allocHashTable(); + + return ret; +} +#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) { + PackState *ret; + + ret = (PackState*) stgMallocBytes(sizeof(PackState), "pack state"); + + // assume buffer and size provided by caller are correct + ret->buffer = buffer; + ret->size = size; + + ret->position = 0; + ret->tso = tso; + + // create a closure queue "big enough" => about what the array can hold + ret->queue = initClosureQ(ret->size / 2); + // new hash table + ret->offsets = allocHashTable(); + + return ret; +} +#endif + +// Pack state destructor: frees hashtable and queue. Mutable array used when +// initialising has now been mutated. +static void donePacking(PackState *state) { + freeHashTable(state->offsets, NULL); + freeClosureQ(state->queue); + stgFree(state); + return; +} + +// initialise a closure queue for "size" many closures +static ClosureQ* initClosureQ(nat size) { + ClosureQ* ret; + ret = (ClosureQ*) stgMallocBytes(sizeof(ClosureQ), "cl.queue"); + ret->queue = (StgClosure**) + stgMallocBytes(size * sizeof(StgClosure*), "cl.queue data"); + ret->size = size; + ret->head = ret->tail = 0; + return ret; +} + +// free an allocated closure queue +static void freeClosureQ(ClosureQ* q) { + stgFree(q->queue); + stgFree(q); +} + +// queue empty if head == tail +STATIC_INLINE rtsBool 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) { + // 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; + } else { + // wrapped around + return (q->size - span); + } +} + +// enqueue a closure +static void queueClosure(ClosureQ* q, StgClosure *closure) { + + // next index, wrapping around when required + nat idx = (q->head == q->size - 1) ? 0 : q->head + 1; + + if (idx == q->tail) { + // queue full, stop (should not happen with sizes used here) + errorBelch("Pack.c: Closure Queue Overflow"); + stg_exit(EXIT_FAILURE); + } + q->queue[q->head] = closure; + PACKETDEBUG(debugBelch(">__> Q: %p (%s) at %ld\n", closure, + info_type(UNTAG_CLOSURE(closure)), (long) q->head)); + q->head = idx; + +} + +// dequeue a closure +static StgClosure *deQueueClosure(ClosureQ* q) { + 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", + c, info_type(UNTAG_CLOSURE(c)), + (long) queueSize(q))); + return c; + } else { + PACKETDEBUG(debugBelch("Q empty\n ")); + return ((StgClosure*)NULL); + } +} + + + +/*************************************************************** + * Helper functions for packing + */ + +// RegisterOffset records that/where the closure is packed +STATIC_INLINE void registerOffset(PackState* p, StgClosure *closure) { + insertHashTable(p->offsets, UNTAG_CAST(StgWord, closure), + // remove tag for offset + (void *) (StgWord) (p->position + PADDING)); + // note: offset is never 0 (indicates failing lookup), PADDING is 1 +} + +// OffsetFor returns an offset for a closure which has already been packed. +// offsetFor returns 0 => closure has _not_ been packed +// (root closure gets offset 1, see PADDING above) +STATIC_INLINE StgWord offsetFor(PackState* p, StgClosure *closure) { + // avoid typecast warnings... + void* offset; + offset = lookupHashTable(p->offsets, UNTAG_CAST(StgWord, closure)); + // remove tag for offset + return (StgWord) offset; +} + +// 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) +{ + if ((p->position + // where we are in the buffer right now + size + // space needed for the current closure +#ifdef GUM + queueSize(q) * FETCH_ME_PACKED_SIZE + +#endif + 1) // closure tag + >= p->size) { + PACKDEBUG(debugBelch("Pack buffer full (size %d). ", p->position)); + return rtsFalse; + } + return rtsTrue; +} + +// quick test for blackholes. Available somewhere else? + +#ifdef LIBRARY_CODE +STATIC_INLINE +#endif +rtsBool 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; + // some Blackholes are actually indirections since ghc-7.0 + switch (((StgInfoTable*)get_itbl(UNTAG_CLOSURE(indirectee)))->type) { + case TSO: + case BLOCKING_QUEUE: + return rtsTrue; + default: + return rtsFalse; + } + } + return rtsFalse; +} + +// unwind (chains of) indirections, return the actual data closure +// Blackholes are one kind of indirection, see above. +STATIC_INLINE StgClosure* unwindInd(StgClosure *closure) +{ + StgClosure *start = closure; + + while (closure_IND(start)) + start = (UNTAG_CAST(StgInd*, start))->indirectee; + + return start; +} + +/*************************************************************** + * general helper function used here + */ + +/* getClosureInfo: returns payload structure for closures. + Only used in here + IN: node - ptr to the closure / into the packet + info - (optional) info _table_ (not info ptr!) for closure + to be computed from info offset by caller when in packet + OUT: size - total size of closure in heap (for allocation) + ptrs - number of pointers in payload + nonptrs- number of non-pointers in payload + vhs - variable header size + RETURNS: info _table_ (pointer) +*/ +STATIC_INLINE StgInfoTable* +getClosureInfo(StgClosure* node, StgInfoTable* info, + nat *size, nat *ptrs, nat *nonptrs, nat *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 + // packet slot instead of the heap) which is the case if we find + // something tagged. + ASSERT(!GET_CLOSURE_TAG((StgClosure*) node->header.info)); + // not tagged, OK + info = get_itbl(node); + } + // ClosureMacros.h. NB relies on variable header for PAP, AP, Arrays + *size = closure_sizeW_(node, info); + + /* Caution: layout field is union, may contain different information + according to closure type! see InfoTables.h: THUNK_SELECTOR: + selector_offset stack frames, ret. vec.s, whatever: bitmap / ptr. to + large_bitmap other closures: ptrs | nptrs + */ + switch (info->type) { + case THUNK_SELECTOR: + *ptrs = 1; // selectee is a pointer + *vhs = *size - 1 - sizeofW(StgHeader); + *nonptrs = 0; + break; + + // PAP/AP/AP_STACK contain a function field, + // treat this field as a (= the one single) pointer + case PAP: + *vhs = 1; // arity/args + *ptrs = 1; + // wrong (some are ptrs), but not used in the unpacking code! + *nonptrs = *size - 2 - sizeofW(StgHeader); + break; + + case AP_STACK: + case AP: + // thunk header and arity/args field + *vhs = sizeofW(StgThunkHeader) - sizeofW(StgHeader) + 1; + *ptrs = 1; + // wrong (some are ptrs), but not used in the unpacking code! + *nonptrs = *size - 2 - sizeofW(StgThunkHeader); + break; + + /* For Word arrays, no pointers need to be filled in. + * (the generic "ptrs-first" treatment works for them) + */ + case ARR_WORDS: + *vhs = 1; + *ptrs = 0; + *nonptrs = (((StgArrWords*) node)->bytes) / sizeof(StgWord); + break; + + /* For Arrays of pointers, we need to fill in all the pointers and + allocate additional space for the card table at the end. + */ + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN0: + case MUT_ARR_PTRS_FROZEN: + *vhs = 2; + *ptrs = ((StgMutArrPtrs*) node)->ptrs; + *nonptrs = ((StgMutArrPtrs*) node)->size - *ptrs; // count card table + // NB nonptrs field for array closures is only used in checkPacket + 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: + case CATCH_RETRY_FRAME: + case ATOMICALLY_FRAME: + case UPDATE_FRAME: + case CATCH_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: + case RET_SMALL: + case RET_BIG: + case RET_BCO: + barf("getClosureInfo: stack frame!"); + break; + + default: + // this works for all pointers-first layouts + *ptrs = (nat) (info->layout.payload.ptrs); + *nonptrs = (nat) (info->layout.payload.nptrs); + *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader); + } + + ASSERT(*size == sizeofW(StgHeader) + *vhs + *ptrs + *nonptrs); + + return info; +} + +/******************************************************************* + * packing a graph structure: + * + * 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 + * + * About "pointer tagging": + * Every closure pointer carries a tag in its l.s. bits (those which + * are not needed since closures are word-aligned anyway). + * These tags indicate that data pointed at is fully evaluated, and + * allow for a shortcut in case of small constructors (selecting + * arguments). + * The tagged pointers are *references* to a closure. RTS must ensure + * that every occurrence of one and the same pointer has the same tag. + * + * Tags should survive packing-sending-unpacking, so we must store + * them in the packet somehow. + * => Closure pointers in the closure queue are stored *WITH TAGS*, + * and we pack the tags together with the closure. + * OTOH, *offsets* (HashTable entries) are stored without tags, in + * order to catch the case when two references with different tags + * exist (possible?) + * (the tag of the first occurrence will win, a problem?) + * + * We use the last bits of the info-ptr (stored anyway), which is + * aligned just as closure pointers, in word size. + * + * Anyway, closures are enqueued with tags, and the tag handled in + * functions called from PackClosure(): PackGeneric, or specialised + * ones. + * + * Restoring the tags: Tags must be restored at every place where we + * put a reference to the closure. Here: when we fill in the + * pointers to a closure. The tags are restored right after + * unpacking, inside unpackClosure(). See comments there for details. + * + * About relocatable binaries: + * Packing relies on shipping pointers to info tables between + * running RTS instances. When these addresses are unstable + * (relocatable binaries), they need to be computed using a known + * (and usually very low) address is subtracted from any info + * pointer packed. + * + * We use the terminology of an "info offset" as opposed to an "info + * pointer". (Furthermore there are proper "info tables", see + * ClosureMacros.h for the difference ->TABLES_NEXT_TO_CODE ). + * + * Info offsets are computed from the info pointer in the heap + * closure's header when packing, tagged (see above) and put into + * the packet. The receiver restores the info pointer and uses the + * tag for pointers to the respective unpacked closure. + * + *******************************************************************/ + +// packing a static value +STATIC_INLINE void PackPLC(PackState* p, StgPtr addr) { + Pack(p, PLC); // weight + // pointer tag of addr still present, packed as-is (with offset) + Pack(p, (StgWord) P_OFFSET(addr)); // address +} + +// packing an offset (repeatedly packed same closure) +STATIC_INLINE void PackOffset(PackState* p, StgWord offset) { + Pack(p, OFFSET); // weight + // Pack(0L); // pe + Pack(p, offset); // slot/offset +} + +// helper accessing the pack buffer +STATIC_INLINE void Pack(PackState* p, StgWord data) { + ASSERT(p->position < p->size); + p->buffer[p->position++] = data; +} + +#ifdef LIBRARY_CODE +// 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 errcode = P_SUCCESS; // error code returned by PackClosure + PackState* p; + nat size; + + PACKDEBUG( { + char fpstr[MAX_FINGER_PRINT_LEN]; + graphFingerPrint(fpstr, closure); + debugBelch("Packing subgraph @ %p\nGraph fingerprint is\n" + "\t{%s}\n", closure, fpstr); + }); + p = initPacking(mutArr); + + queueClosure(p->queue, closure); + do { + errcode = packClosure(p, deQueueClosure(p->queue)); + if (errcode != P_SUCCESS) { + donePacking(p); + return (errcode); + // small value => error (real size offset by P_ERRCODEMAX) + } + } while (!queueEmpty(p->queue)); + + /* Check for buffer overflow (again) */ + ASSERT((p->position + DBG_HEADROOM) < p->size); + IF_DEBUG(sanity, // write magic end-of-buffer word + p->buffer[p->position++] = END_OF_BUFFER_MARKER); + + /* Record how much space the graph needs in packet and in heap */ + size = p->position; // need to offset it for the primop to recognise errors + // globalPackBuffer->unpacked_size = unpacked_size; XXX unpackedSize + + PACKDEBUG(debugBelch("** Finished packing graph %p (%s); " + "packed size: %d words; size of graph: %d\n", + closure, info_type(UNTAG_CLOSURE(closure)), + size, 0)); // globalPackBuffer->unpacked_size)); + + /* done packing */ + donePacking(p); + + IF_DEBUG(sanity, checkPacket(mutArr->payload, size)); + + size = size*sizeof(StgWord) + P_ERRCODEMAX; + // need offset to recognise errors in primop + + return (int) size; +} +#else +// packToBuffer: interface function for the RTS (DataComms). +// Returns packed size (in bytes!) + P_ERRCODEMAX when successful, or +// error codes upon failure +int packToBuffer(StgClosure* closure, + StgWord *buffer, nat bufsize, StgTSO *caller) { + int errcode = P_SUCCESS; // error code returned by PackClosure + PackState* p; + nat size; + + PACKDEBUG( { + char fpstr[MAX_FINGER_PRINT_LEN]; + graphFingerPrint(fpstr, closure); + debugBelch("RTS packs subgraph @ %p\nGraph fingerprint is\n" + "\t{%s}\n", closure, fpstr); + }); + p = initRtsPacking(buffer, bufsize, caller); + + queueClosure(p->queue, closure); + do { + errcode = packClosure(p, deQueueClosure(p->queue)); + if (errcode != P_SUCCESS) { + donePacking(p); + return (errcode); + // small value => error (real size offset by P_ERRCODEMAX) + } + } while (!queueEmpty(p->queue)); + + /* Check for buffer overflow (again) */ + ASSERT((p->position + DBG_HEADROOM) < p->size); + IF_DEBUG(sanity, // write magic end-of-buffer word + p->buffer[p->position++] = END_OF_BUFFER_MARKER); + + /* Record how much space the graph needs in packet and in heap */ + size = p->position; // need to offset it for the primop to recognise errors + // unpacked_size = p->unpacked_size; XXX unpackedSize + + PACKDEBUG(debugBelch("** Finished packing graph %p (%s); " + "packed size: %d words; size of graph: %d\n", + closure, info_type(UNTAG_CLOSURE(closure)), + size, 0)); // globalPackBuffer->unpacked_size)); + + /* done packing */ + donePacking(p); + + IF_DEBUG(sanity, checkPacket(buffer, size)); + + size = size*sizeof(StgWord) + P_ERRCODEMAX; + // need offset to recognise errors in primop + + return (int) size; +} + +// pack, then copy the buffer into newly (Haskell-)allocated space +// (unless packing was blocked, in which case we return the error code) +// This implements primitive serialize# and #trySerialize (if tso==NULL). +StgClosure* tryPackToMemory(StgClosure* graphroot, + StgTSO* tso, Capability* cap) { + StgWord *buffer; + StgWord packedSize, trySize; + StgArrWords* wordArray; + +#define ONEMEGABYTE 1048576 + trySize = ONEMEGABYTE; // start with 1MB buffer, increase if it fails + + buffer = (StgWord*) stgMallocBytes(trySize, "serialize buffer"); + packedSize = packToBuffer(graphroot, buffer, trySize, tso); + + while (packedSize == P_NOBUFFER // packing failed due to buffer overflow + && trySize <= RtsFlags.ParFlags.packBufferSize) { + // increase and retry (until max, given as RtsFlag) + stgFree(buffer); + trySize += ONEMEGABYTE; + buffer = (StgWord*) stgMallocBytes(trySize, "serialize buffer"); + packedSize = packToBuffer(graphroot, buffer, trySize, tso); + } + + // here: not failing due to NOBUFFER + + if (isPackError(packedSize)) { + // packing hit an error, return this error to caller + stgFree(buffer); +#ifndef DEBUG + // if we are not debugging, crash the system upon impossible cases. + if (packedSize == P_IMPOSSIBLE) { + barf("GHC RTS found an impossible closure during packing."); + // never returns + } +#endif + return ((StgClosure*) packedSize); + } + + packedSize -= P_ERRCODEMAX; // now size is correct, in bytes + + // allocate space to hold an array + // +---------+----------+------------------------+ + // |ARR_WORDS| n_bytes | data (array of words) | + // +---------+----------+------------------------+ + wordArray = (StgArrWords*) allocate(cap, 2 + packedSize / sizeof(StgWord)); + SET_HDR(wordArray, &stg_ARR_WORDS_info, CCS_SYSTEM); + wordArray->bytes = packedSize; + memcpy((void*) &(wordArray->payload), buffer, packedSize); + stgFree(buffer); + + return ((StgClosure*) wordArray); +} +#endif + +/* + * @packClosure@ is the heart of the normal packing code. It packs a + * single closure into the pack buffer, skipping over any + * indirections, queues any child pointers for further packing. + * + * The routine returns error codes (see Errors.h) indicating error + * status when packing a closure fails. + */ + +static StgWord packClosure(PackState* p, StgClosure *closure) { + + StgInfoTable *info; + StgWord offset; + + // Ensure we can always pack this closure as an offset/PLC. + if (!roomToPack(p, sizeofW(StgWord))) + return P_NOBUFFER; + +loop: + closure = unwindInd(closure); + // now closure is the thing we want to pack + // ... but might still be tagged. + + offset = offsetFor(p, closure); + // If the closure has been packed already, pack an indirection + if (offset != 0) { + PackOffset(p, offset); + return P_SUCCESS; + } + + // remove the tag (temporary, subroutines will handle tag as needed) + info = get_itbl(UNTAG_CLOSURE(closure)); + + // code relies on info-pointers being word-aligned (they are tagged) + ASSERT(info == UNTAG_CAST(StgInfoTable*, info)); + + switch (info->type) { + + // follows order of ClosureTypes.h... + case INVALID_OBJECT: + barf("Found invalid object"); + + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + 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) + PACKETDEBUG(debugBelch("*>~~ Packing a %p (%s) as a PLC\n", + closure, info_type_by_ip(info))); + + PackPLC(p, (StgPtr)closure); + // NB: unpacked_size of a PLC is 0 + return P_SUCCESS; + + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_2_0: + case FUN_1_1: + case FUN_0_2: + return PackGeneric(p, closure); + + case THUNK: + case THUNK_1_0: + case THUNK_0_1: + case THUNK_2_0: + case THUNK_1_1: + case THUNK_0_2: + // !different layout! (smp update field, see Closures.h) + // the update field should better not be shipped... + return PackGeneric(p, closure); + + case THUNK_SELECTOR: + // a thunk selector extracts one of the arguments of another + // closure. See GC.c::eval_thunk_selector. Selectee might be + // CONSTR*, or IND* or unevaluated (THUNK*, AP, AP_STACK, + // BLACKHOLE). + + // GC tries to evaluate and eliminate THUNK_SELECTORS by + // following them. unwindInd could include them in the normal + // case, but this is fatal in case of a loop. Therefore, just + // pack selector and selectee instead. getClosureInfo treats + // the selectee in this closure type as a pointer field. + + return PackGeneric(p, closure); + + case BCO: + goto unsupported; + + case AP: + case PAP: + return PackPAP(p, (StgPAP *)closure); // types with bitmap-layout + + case AP_STACK: + // this is a stack from an evaluation that was interrupted + // (by an exception or alike). Slightly unclear whether it + // would ever make sense to pack/replicate it. + goto unsupported; + + case IND: + case IND_PERM: + case IND_STATIC: + // clearly a bug! + barf("Pack: found IND_... after shorting out indirections %d (%s)", + (nat)(info->type), info_type_by_ip(info)); + + // return vectors + case RET_BCO: + case RET_SMALL: + case RET_BIG: + case RET_FUN: + goto impossible; + + // stack frames + case UPDATE_FRAME: + case CATCH_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: + goto impossible; + + case BLOCKING_QUEUE: + goto impossible; + + case BLACKHOLE: + // case RBH: + { + StgClosure* indirectee = ((StgInd*)closure)->indirectee; + + // some Blackholes are actually indirections since ghc-7.0 + switch (((StgInfoTable*)get_itbl(UNTAG_CLOSURE(indirectee)))->type) { + + case IND: // race cond. when threaded (blackhole just got updated) + // This case is analogous with the one in StgMiscClosures.cmm + goto loop; + case TSO: // blackhole without blocking queue + case BLOCKING_QUEUE: // another thread already blocked here + +#ifndef LIBRARY_CODE + // For the in-RTS version: If the calling TSO is known, it can + // block on this Blackhole until it is updated/data arrives. + // The TSO should then restart packing when woken up. + if (p->tso != NULL) { + StgTSO *tso = p->tso; + MessageBlackHole *msg = NULL; + + PACKETDEBUG(debugBelch("TSO %d blocks on %s (at %p) " + "while packing.", (int)tso->id, + info_type_by_ip(info), closure)); + + // blocking the tso: create a message, call msgBlackHole, + // set fields in tso. If msgBlackHole signals we can + // continue (threaded rts case), we jump back. + + msg = (MessageBlackHole*) + allocate(tso->cap, sizeofW(MessageBlackHole)); + SET_HDR(msg, &stg_MSG_BLACKHOLE_info, CCS_SYSTEM); + msg->tso = tso; + msg->bh = closure; + + if (messageBlackHole(tso->cap, msg)) { + tso->why_blocked = BlockedOnBlackHole; + tso->block_info.bh = msg; + // packing failed, TSO blocked, caller should suspend it + return P_BLACKHOLE; + } else { + goto loop; // could not block (race condition), retry + } + } + // else (we don't know the packing TSO): + // In GUM, we would globalise and pack a FetchMe. +#endif + // Without global addresses and virtual shared heap, packing + // just fails, an error code is returned to Haskell. + // Likewise in library code: would be good to just block on the + // blackhole, but there is no way to return to the scheduler. + PACKETDEBUG(debugBelch("packing hit a %s at %p (returning).\n", + info_type_by_ip(info), closure)); + + // Packing will fail anyway, so write the blackhole address into + // the buffer (first word), to enable blocking from Haskell by a + // whnf evaluation. Caller to do the rest. + *p->buffer = (StgWord) closure; + + return P_BLACKHOLE; + + default: // an indirection, pack the indirectee (jump back to start) + closure = indirectee; + // race condition, "unwindInd" should have removed this. + goto loop; + } + } + + case MVAR_CLEAN: + case MVAR_DIRTY: + case TVAR: + PACKDEBUG(errorBelch("Pack: packing type %s (%p) not possible", + info_type_by_ip(info), closure)); + return P_CANNOTPACK; + + case ARR_WORDS: + // Word arrays follow the "pointers-first" layout (with no pointers) + return PackGeneric(p, closure); + + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN0: + case MUT_ARR_PTRS_FROZEN: + // Arrays of pointers have a card table to indicate dirty cells, + // therefore not the simple pointers/nonpointers layout. + // NB At this level, we cannot distinguish immutable arrays + // from mutable ones + return PackArray(p, closure); + + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: // known as IORefs in the Haskell world + PACKDEBUG(errorBelch("Pack: packing type %s (%p) not possible", + info_type_by_ip(info),closure)); + return P_CANNOTPACK; + + case WEAK: + goto unsupported; + + case PRIM: + // Prim type holds internal immutable closures: MSG_TRY_WAKEUP, + // MSG_THROWTO, MSG_BLACKHOLE, MSG_NULL, MVAR_TSO_QUEUE + case MUT_PRIM: + // Mut.Prim type holds internal mutable closures: + // TVAR_WATCH_Q, ATOMIC_INVARIANT, INVARIANT_CHECK_Q, TREC_HEADER + case TSO: + // this might actually happen if the user is smart and brave + // enough (a thread id in Haskell is a TSO ptr in the RTS) + goto unsupported; + + case STACK: + case TREC_CHUNK: // recorded transaction on STM. Should not occur + goto impossible; + + // more stack frames: + case ATOMICALLY_FRAME: + case CATCH_RETRY_FRAME: + case CATCH_STM_FRAME: // STM-related stack frames. Should not occur + goto impossible; + + case WHITEHOLE: + // 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; + // 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 getClosureInfo + return PackGeneric(p, closure); +#endif + +unsupported: + PACKDEBUG(errorBelch("Pack: packing type %s (%p) not implemented", + info_type_by_ip(info), closure)); + return P_UNSUPPORTED; + +impossible: + PACKDEBUG(errorBelch("{Pack}Daq Qagh: found %s (%p) when packing", + info_type_by_ip(info), closure)); + return P_IMPOSSIBLE; + + default: + barf("Pack: strange closure %d", (nat)(info->type)); + } // closure type switch + +} + +// XXX rename packGeneric +// packGeneric packs all closures with "pointers-first" layout +// +-------------------------------------------------+ +// | FIXED HEADER | VARIABLE HEADER | PTRS | NON-PRS | +// +-------------------------------------------------+ +// The first (and only, in the default system) word of the header is +// 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; + StgWord tag=0; + StgClosure* infoptr; // actually just a pointer... + + // store tag separately, pack with info ptr + tag = GET_CLOSURE_TAG(closure); + closure = UNTAG_CLOSURE(closure); + + // get info about basic layout of the closure + getClosureInfo(closure, NULL, &size, &ptrs, &nonptrs, &vhs); + + ASSERT(!isBlackhole(closure)); + + PACKETDEBUG(debugBelch("*>== %p (%s): generic packing" + "(size=%d, ptrs=%d, nonptrs=%d, and tag %d)\n", + closure, info_type(closure), size, ptrs, nonptrs, + (int)tag)); + + // make sure we can pack this closure into the current buffer + if (!roomToPack(p, HEADERSIZE + vhs + nonptrs)) + return P_NOBUFFER; + + // Record that this has been packed + registerOffset(p, closure); + + // GUM would allocate a GA for the packed closure if it is a thunk +#ifdef GUM + // Checks for globalisation scheme; default: globalise everything thunks + if ( RtsFlags.ParFlags.globalising == 0 || + (closure_THUNK(closure) && !closure_UNPOINTED(closure)) ) + GlobaliseAndPackGA(closure); + else +#endif + Pack(p, (StgWord) CLOSURE); // marker for unglobalised closure + + // At last! A closure we can actually pack! + + // pack fixed and variable header + // First word (==infopointer) is tagged and offset using macros + infoptr = *((StgClosure**) closure); + Pack(p, (StgWord) (P_OFFSET(TAG_CLOSURE(tag, infoptr)))); + + // pack the rest of the header (variable header) + for (i = 1; i < HEADERSIZE + vhs; ++i) { + Pack(p, (StgWord)*(((StgPtr)closure)+i)); + } + + // register all ptrs for further packing + for (i = 0; i < ptrs; ++i) { + queueClosure(p->queue, ((StgClosure *) *(((StgPtr)closure)+(HEADERSIZE+vhs)+i))); + } + + // pack non-ptrs + for (i = 0; i < nonptrs; ++i) { + Pack(p, (StgWord)*(((StgPtr)closure)+(HEADERSIZE+vhs)+ptrs+i)); + } + + ASSERT(HEADERSIZE+vhs+ptrs+nonptrs==size); // no slop in closure, all packed + + // unpacked_size += size; XXX unpacked_size in PackState + +#ifdef GUM + // Record that this is a revertable black hole so that we can fill + // in its address from the fetch reply. Problem: unshared thunks + // may cause space leaks this way, their GAs should be deallocated + // following an ACK. + + // convert to RBH + if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) { + StgClosure *rbh; + rbh = convertToRBH(closure); + ASSERT(size>=HEADERSIZE+MIN_UPD_SIZE); // min size for updatable closure + ASSERT(rbh == closure); // rbh at same position (minced version) + + // record the thunk that has been packed so that we may abort and revert + if (thunks_packed < MAX_THUNKS_PER_PACKET) + thunks[thunks_packed++] = closure; + // otherwise: abort packing right now (should not happen at all). + } +#endif + + return P_SUCCESS; +} + +// Packing PAPs and APs: + +// a PAP (partial application) represents a function which has been +// given too few arguments for complete evaluation (thereby defining a +// new function with fewer arguments). +// +// PAP/AP closure layout in GHC (see Closures.h, InfoTables.h): +// +--------------------------------------------------------------+ +// | Header | (arity | n_args) | Function | Stack.|Stack.|Stack...| +// +--------------------------------------------------------------+ +// | +// (info table has bitmap for stack) +// +// The _arity_ of the PAP informs about how many arguments are still +// missing to saturate the function call. n_args, in turn, is how many +// arguments are already present (i.e. the stack size). +// +// An APs (generic application) has similar layout, but actually has +// all its arguments, i.e. the application has not been evaluated to +// WNHF yet. Therefore, APs have a thunk header (one extra word). +// +// PAPs/APs are packed by packing the function and the argument stack, +// where both can point to static or dynamic (heap-allocated) closures +// which must be packed later, and enqueued here. +// The stack may contain either pointers or non-pointer words, indicated +// by a _bitmap_ that comes with the function (but is only used up to the +// indicated n_args size). +// Old code used tags on all stored values (doubling the stack size), +// this version packs the btimap instead. +static StgWord PackPAP(PackState *p, StgPAP *pap) { + + nat i; + nat 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 + + nat n_args; // arg. count on stack + StgClosure *fun; // function in PAP/AP + StgPtr ptr; // stack object currently packed + StgWord tag = 0; + + tag = GET_CLOSURE_TAG((StgClosure*) pap); + pap = UNTAG_CAST(StgPAP*, (StgClosure*) pap); + + ASSERT(LOOKS_LIKE_CLOSURE_PTR(pap)); + ASSERT(get_itbl((StgClosure*)pap)->type == PAP || + get_itbl((StgClosure*)pap)->type == AP); + + switch (get_itbl((StgClosure*)pap)->type) { + case PAP: + n_args = pap->n_args; + hsize = HEADERSIZE+1; + fun = pap->fun; + ptr = (StgPtr) pap->payload; + break; + + case AP: + n_args = ((StgAP*) pap)->n_args; + hsize = sizeofW(StgThunkHeader)+1; + fun = ((StgAP*) pap)->fun; + ptr = (StgPtr) ((StgAP*) pap)->payload; + break; + + default: // checked in packClosure, should not happen here + barf("PackPAP: strange info pointer, type %d ", + get_itbl((StgClosure*)pap)->type); + } + + PACKETDEBUG( { + debugBelch("Packing %s closure @ %p," + "with stack of size %d\n", + info_type((StgClosure*) pap), pap, n_args); + }); + + // Extract the bitmap from the function. + // Bitmaps can be either small (1 StgWord) or large + // (StgLargeBitmap, see InfoTables.h) with a size field and + // multiple bitmap fields. + // Note that only the bits up to n_args are used in the packing code, + // therefore the packed bitmap is not necessarily the complete one. + // + // small bitmap: + // (32 bit StgWord) [ bits 5-31: bitmap | bits 0-4: size ] + // (64 bit StgWord) [ bits 5-63: bitmap | bits 0-5: size ] + // <--reading--| + // + // note that reading direction for bitmaps is right-to-left per + // StgWord (but left-to-right in the large for large bitmaps) + // see rts/sm/Scav.c::scavenge_(small|large)_bitmap + + lbm = (StgLargeBitmap*) NULL; + funInfo = get_fun_itbl(UNTAG_CLOSURE(fun)); + switch (funInfo->f.fun_type) { + + // these two use a large bitmap. + case ARG_GEN_BIG: + errorBelch("PackPAP at %p: large bitmap not implemented", + pap); + return P_UNSUPPORTED; + // lbm set indicates a large bitmap (bad if all non-pointers! :-) + lbm = GET_FUN_LARGE_BITMAP(funInfo); + bsizeW = lbm->size / BITS_IN(StgWord); + break; + case ARG_BCO: + errorBelch("PackPAP at %p: large bitmap not implemented", + pap); + return P_UNSUPPORTED; + // lbm indicates large bitmap. BCO macro needs fun ptr, not info + lbm = BCO_BITMAP(fun); + bsizeW = lbm->size / BITS_IN(StgWord); + break; + + // another clever solution: fields in info table different for + // some cases... and referring to autogenerated constants (Apply.h) + case ARG_GEN: + bitmap = funInfo->f.b.bitmap; + bsizeW = 1; + break; + + default: + bitmap = stg_arg_bitmaps[funInfo->f.fun_type]; + bsizeW = 1; + } + + + // check that we have enough space... upper bound on required size: + // header + arg.s (all non-ptrs) + bitmap and its tag + if (!roomToPack(p, hsize + n_args + 1 + bsizeW)) + return P_NOBUFFER; + + // XXX unpacked_size += hsize + 1 + n_args; // == closure_size(pap) + + // register closure + registerOffset(p, (StgClosure*) pap); + + // do the actual packing! + // PAP layout in pack buffer + // +---------------------------....................---------------------+ + // | Header | (arity | n_args) | bsizeW | bitmap.. | nonPtr | nonPtr|...| + // +---------------------------....................---------------------+ + // Function field and pointers on stack are not packed but enqueued. In + // turn, the packet contains the bitmap, together with its size (or value + // 0xFF..FF to tag a small bitmap) + + // pack closure marker + Pack(p, (StgWord) CLOSURE); + + // pack header. First word (infoptr) is tagged and offset + Pack(p, (StgWord) (P_OFFSET(TAG_CLOSURE(tag, (StgClosure*) *((StgPtr) pap + ))))); + // rest of header packed as-is (possibly padding, then arity|n_args) + for(i = 1; i < hsize; i++) { + Pack(p, (StgWord) *(((StgWord*)pap)+i)); + } + + // queue the function closure for later packing + queueClosure(p->queue, fun); + + // pack the bitmap + // the bitmap is preceded by a tag, SMALL_BITMAP_TAG == ~0L for a small one, + // its size in bits for a large bitmap. + + // Then we pack the bitmap itself. + // Note that packing only n_args/BITS_IN(StgWord) bits would do, only those + // bits are actually used in the packing/unpacking code). However, we do not + // save much, and the case is very rare anyway. + if ( lbm == NULL ) { + // small bitmap, tag and pack it + // SMALL_BITMAP_TAG is ~0L, a very unlikely size + Pack(p, SMALL_BITMAP_TAG); + Pack(p, bitmap); + } else { + // large bitmap, a lot of gymnastics + PACKETDEBUG(debugBelch("yuck, large bitmap")); + return P_UNSUPPORTED; // XXX following code is an unchecked draft + // use size as tag for large bitmap (see above, ~0L is unlikely size) + Pack(p, bsizeW); + // for (i=0; i * BITS_IN(StgWord) < n_args; i++) { // meeh, we pack all + for (i=0; i < bsizeW; i++) { + Pack(p, lbm->bitmap[i]); + } + } + + // now walk the stack, packing non-pointers and enqueueing pointers, as + // indicated by bitmap, see Scav.c::scavenge_(small|large)_bitmap (which + // only evacuates pointers) + + // ptr = first word of payload (PAP/AP cases separated above) + if (lbm == NULL) { + bsize = BITMAP_SIZE(bitmap); + bitmap = BITMAP_BITS(bitmap); + while (bsize > 0) { + if (bitmap & 1) { + // bit set => non-pointer, pack + Pack(p, *ptr); + } else { + // bit not set => pointer + queueClosure(p->queue, (StgClosure*) *ptr); + // XXX unpacked_size += sizeofW(StgInd); // unpacking creates IND + } + ptr++; + bitmap = bitmap >> 1; + bsize--; + } + } else { + debugBelch("yuck, large bitmap again"); + return P_UNSUPPORTED; + // XXX following code UNCHECKED! + // written to closely match Scav.c::scavenge_large_bitmap + nat j, b; + b = 0; + bsize = lbm->size; + for(i = 0; i < bsize; b++) { + bitmap = lbm->bitmap[b]; + j = stg_min(bsize-i, BITS_IN(StgWord)); + i += j; + for (; j > 0; j--, ptr++) { + if (bitmap & 1) { // bit set => non-pointer + Pack(p, *ptr); + } else { // bit not set => pointer + queueClosure(p->queue, (StgClosure*) *ptr); + // XXX unpacked_size += sizeofW(StgInd); // unpacking creates IND + } + bitmap = bitmap >> 1; + } + } + } + + return P_SUCCESS; +} + +// Packing Arrays. + +// An Array in the heap can contain StgWords or Pointers (to +// closures), and is thus of type StgArrWords or StgMutArrPtrs. +// +// Array layout in heap/buffer is the following: +// +// (packed into the buffer) +// +------------------------+......................................+ +// | IP'| Hdr | ptrs | size | ptr1 | ptr2 | .. | ptrN | card space | +// +------------------------+......................................+ +// (added in heap when unpacking) +// +// 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 +// pointers), and are packed simply by copying all words (as non-ptrs). +// +// MutArrPtrs (MUT_ARRAY_PTRS_* types) contain pointers to other +// closures instead of words. +// Packing MutArrPtrs means to enqueue/pack all pointers found. +// OTOH, packing=copying a mutable array is not a good idea at all. +// We implement it even though, leave it to higher levels to restrict. +static StgWord PackArray(PackState *p, StgClosure *closure) { + + StgClosure *infoptr; + nat i, payloadsize, packsize; + + /* remove tag, store it in infopointer (same as above) */ + StgWord tag=0; + + tag = GET_CLOSURE_TAG(closure); + closure = UNTAG_CLOSURE(closure); + +#if DEBUG + /* get info about basic layout of the closure */ + StgInfoTable *info = get_itbl(closure); + + ASSERT( info->type == MUT_ARR_PTRS_CLEAN + || info->type == MUT_ARR_PTRS_DIRTY + || info->type == MUT_ARR_PTRS_FROZEN0 + || info->type == MUT_ARR_PTRS_FROZEN); +#endif + + // MUT_ARR_PTRS_* {HDR,(no. of)ptrs,size(total incl.card table)} + // Only pack header, not card table which follows the data. + packsize = HEADERSIZE + 2; + payloadsize = ((StgMutArrPtrs *)closure)->ptrs; + + // the function in ClosureMacros.h would include the header: + // arr_words_sizeW(stgCast(StgArrWords*,q)); + PACKETDEBUG(debugBelch("*>== %p (%s): packing array" + "(%d words) (size=%d)\n", + closure, info_type(closure), payloadsize, + (int)closure_sizeW(closure))); + + // check if enough room in the pack buffer + if (!roomToPack(p, packsize)) return P_NOBUFFER; + + // record offset of the closure */ + registerOffset(p, closure); + + Pack(p, (StgWord) CLOSURE); // marker for unglobalised closure (array) + + // Pack the header and the number of bytes/ptrs that follow) + // First word (info pointer) is tagged and offset + infoptr = *((StgClosure**) closure); + Pack(p, (StgWord) (P_OFFSET(TAG_CLOSURE(tag, infoptr)))); + + // pack the rest of the header (variable header) + for (i = 1; i < HEADERSIZE; ++i) + Pack(p, (StgWord)*(((StgPtr)closure)+i)); + + // pack no. of ptrs and total size, enqueue pointers + Pack(p, (StgWord) ((StgMutArrPtrs *)closure)->ptrs); + Pack(p, (StgWord) ((StgMutArrPtrs*)closure)->size); + for (i=0; iqueue, ((StgMutArrPtrs *) closure)->payload[i]); + + // unpacked_size += closure_sizeW(closure); XXX unpacked_size + + return P_SUCCESS; +} + +/******************************************************************* + * unpacking a graph structure: + *******************************************************************/ + +/* + @UnpackGraph@ unpacks the graph contained in a message buffer. It + returns a pointer to the new graph. + + 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. + + for "pointer tagging", we assume here that all stored + info pointers (each first word of a packed closure) also carry the + tag found at the sender side when enqueueing it (for the first + time!). When closures are unpacked, the tag must be added before + inserting the result of unpacking into other closures as a pointer. + Done by UnpackClosure(), see there. +*/ + +#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) +#else +StgClosure* unpackGraphWrapper(StgArrWords* packBufferArray, Capability* cap) +#endif +{ + nat size; + StgWord *buffer; + StgClosure* newGraph; + + size = packBufferArray->bytes / sizeof(StgWord); + buffer = (StgWord*) packBufferArray->payload; + + // unpack. Might return NULL in case the buffer was inconsistent. + newGraph = unpackGraph_(buffer, size, cap); + + return (newGraph == NULL ? (StgClosure *) P_GARBLED : newGraph); +} + +#ifndef LIBRARY_CODE +StgClosure* +unpackGraph(rtsPackBuffer *packBuffer, Capability* cap) { + + StgClosure *graphroot; + + IF_DEBUG(sanity, // do a sanity check on the incoming packet + checkPacket(packBuffer->buffer, packBuffer->size)); + + PACKDEBUG(debugBelch("Packing: Header unpacked. (bufsize=%" FMT_Word + ", heapsize=%" FMT_Word ")\nUnpacking closures...\n", + packBuffer->size, packBuffer->unpacked_size)); + + graphroot = unpackGraph_(packBuffer->buffer, packBuffer->size, cap); + + // if this fails outside the library code, complain and abort the program + if (graphroot == NULL) { + barf("Failure during unpacking, aborting program"); + } + + // wipe the pack buffer if we do sanity checks. + // Only valid for the in-RTS version where data is never reused + IF_DEBUG(sanity, { + StgPtr p; + for (p=(StgPtr)packBuffer->buffer; + p<(StgPtr)(packBuffer->buffer)+(packBuffer->size);) + *p++ = 0xdeadbeef; + }); + + return (graphroot); +} +#endif + +// Internal worker function, not allowed to edit the buffer at all +// (used with with an immutable Haskell ByteArray# as buffer for +// deserialisation). This function returns NULL upon +// errors/inconsistencies in buffer (avoiding to abort the program). +static StgClosure* unpackGraph_(StgWord *buffer, StgInt size, Capability* cap) { + StgWord* bufptr; + StgClosure *closure, *parent, *graphroot; + nat pptr = 0, pptrs = 0, pvhs = 0; + nat currentOffset; + HashTable* offsets; + ClosureQ* queue; + + PACKDEBUG(debugBelch("Unpacking buffer @ %p (%" FMT_Word " words)\n", + buffer, size)); + IF_DEBUG(sanity, checkPacket(buffer, size)); + + offsets = allocHashTable(); + queue = initClosureQ(size); + + graphroot = parent = (StgClosure *) NULL; + bufptr = buffer; + + do { + // check that we aren't at the end of the buffer, yet + IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER)); + + // Compute the offset to register for future back references + // If this is itself an offset, or a PLC, we do not store anything + if (*bufptr == OFFSET || *bufptr == PLC) { + currentOffset = 0; + } else { + currentOffset = ((nat) (bufptr - buffer)) + PADDING; + // ...which is at least 1 (PADDING) + } + + // Unpack one closure (or offset or PLC). This allocates heap + // space, checks for PLC/offset etc. The returned pointer is + // tagged with the tag found in the info pointer. + closure = UnpackClosure (queue, offsets, &bufptr, 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... + PACKDEBUG(debugBelch("Unpacking error at address %p",bufptr)); + freeHashTable(offsets, NULL); + freeClosureQ(queue); + return (StgClosure *) NULL; + } + + // store closure address for offsets (if we should, see above) + if (currentOffset != 0) { + PACKETDEBUG(debugBelch("---> Entry in Offset Table: (%d, %p)\n", + currentOffset, closure)); + // note that the offset is stored WITH TAG + insertHashTable(offsets, currentOffset, (void*) closure); + } + + // Set the pointer in the parent to point to chosen + // closure. If we're at the top of the graph (our parent is + // NULL), then we want to return this closure to our caller. + if (parent == NULL) { + /* we are at the root. Do not remove the tag */ + graphroot = closure; + PACKDEBUG(debugBelch("Graph root %p, tag %x", closure, + (int) GET_CLOSURE_TAG(closure))); + } else { + // packet fragmentation code would need to check whether + // there is a temporary blackhole here. Not supported. + + // write ptr to new closure into parent at current position (pptr) + ((StgPtr) parent)[HEADERSIZE + pvhs + pptr] = (StgWord) closure; + } + + // Locate next parent pointer (incr ppr, dequeue next closure at end) + locateNextParent(queue, &parent, &pptr, &pptrs, &pvhs); + + // stop when buffer size has been reached or end of graph + } while ((parent != NULL) && (size > (bufptr-buffer))); + + if (parent != NULL) { + // this case is valid when one graph can stretch across + // several packets (fragmentation), in which case we would + // save the state. Not supported here. + + PACKDEBUG(errorBelch("Pack buffer overrun")); + return (StgClosure *) NULL; + } + + freeHashTable(offsets, NULL); + freeClosureQ(queue); + + // check magic end-of-buffer word + 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)); + + // ToDo: are we *certain* graphroot has been set??? WDP 95/07 + ASSERT(graphroot!=NULL); + + PACKDEBUG( { + char fpstr[MAX_FINGER_PRINT_LEN]; + graphFingerPrint(fpstr, graphroot); + debugBelch(">>> unpacked graph at %p\n Fingerprint is\n" + "\t{%s}\n", graphroot, fpstr); + }); + + return graphroot; +} + +// locateNextParent finds the next pointer field in the parent +// closure, retrieve information about its variable header size and +// no. of pointers. If the current parent has been completely unpacked +// already, get the next closure from the global closure queue, and +// register the new variable header size and no. of pointers. +// +// Example situation: +// +// *parentP +// | +// V +// +--------------------------------------------------------------------+ +// |hdr| variable hdr | ptr1 | ptr2 | ptr3 | ... | ptrN | non-pointers | +// +--------------------------------------------------------------------+ +// <-- *pvhsP=2 ---> A +// | +// *pptrs = N *pptr=3 +STATIC_INLINE void locateNextParent(ClosureQ* q, StgClosure** parentP, + nat* pptrP, nat* pptrsP, nat* pvhsP) { + nat size, nonptrs; + + // pptr as an index into the current parent; find the next pointer + // field in the parent by increasing pptr; if that takes us off + // the closure (i.e. *pptr + 1 > *pptrs) grab a new parent from + // the closure queue + + (*pptrP)++; + while (*pptrP + 1 > *pptrsP) { + // *parentP has been constructed (all pointer set); so check it now + IF_DEBUG(sanity, + if (*parentP != (StgClosure*)NULL) // not root + checkClosure(*parentP)); + + *parentP = deQueueClosure(q); + + if (*parentP == NULL) { + break; + } else { + getClosureInfo(*parentP, NULL, &size, pptrsP, &nonptrs, pvhsP); + *pptrP = 0; + } + } + // *parentP points to the new (or old) parent; + // *pptr, *vhsP, and *pptrs have been updated referring to the new parent +} + +// UnpackClosure is the heart of the unpacking routine. It is called for +// every closure found in the packBuffer. +// UnpackClosure does the following: +// - check for the kind of the closure (PLC, Offset, std closure) +// - copy the contents of the closure from the buffer into the heap +// - update LAGA tables (in particular if we end up with 2 closures +// having the same GA, we make one an indirection to the other) +// - set the GAGA map in order to send back an ACK message +// In case of any unexpected data, the routine returns NULL. +// +// At the end of this function, +// *bufptrP points to the next word in the pack buffer to be unpacked. +// +// "pointer tagging": +// When unpacking, UnpackClosure() we add the tag to its return value, +// but enqueue the closure address WITHOUT A TAG, so we can access the +// unpacked closure directly by the enqueued pointer. +// The closure WITH TAG is saved as offset value in the offset hash +// table (key=offset, value=address WITH TAG), to be filled in other +// closures as a pointer field. +// When packing, we did the reverse: saved the closure address WITH TAG +// in the queue, but stored it WITHOUT TAG in the offset table (as a +// key, value was the offset). +static StgClosure* +UnpackClosure (ClosureQ* q, HashTable* offsets, + StgWord **bufptrP, Capability* cap) { + StgClosure *closure; + nat size,ptrs,nonptrs,vhs,i; + StgInfoTable *ip; + StgWord tag = 0; + + // Unpack the closure body, if there is one; three cases: + // - PLC: closure is just a pointer to a static closure + // - Offset: closure has been unpacked already + // - else: copy data from packet into closure + switch ((StgWord) **bufptrP) { + // these two cases respect the "pointer tags" by + // design: either the tag was not removed at all (PLC case), or + // the offset refers to an already unpacked (=> tagged) closure. + case PLC: + closure = UnpackPLC(bufptrP); + break; + case OFFSET: + closure = UnpackOffset(offsets, bufptrP); + break; + case CLOSURE: + + (*bufptrP)++; // skip marker + + /* The first word of a closure is the info pointer. In contrast, + in the packet (where (*bufptrP) points to a packed closure), + the first word is an info _offset_, which additionally was + tagged before packing. We remove and store the tag added to the + info offset, and compute the untagged info table pointer from + the info offset. + (NB The original value must be untouched inside the buffer!) + */ + tag = GET_CLOSURE_TAG((StgClosure*) **bufptrP); + ip = UNTAG_CAST(StgInfoTable*, P_POINTER(**bufptrP)); + PACKETDEBUG(debugBelch("pointer tagging: removed tag %d " + "from info pointer %p in packet\n", + (int) tag, ip)); + + // The essential part starts here: allocate heap, fill in + // closure, queue it to fill pointer payload later. + if (!LOOKS_LIKE_INFO_PTR((StgWord) ip)) { + errorBelch("Invalid info pointer in packet"); + return (StgClosure *) NULL; + } + + /* Historic comment: + * Close your eyes. You don't want to see where we're + * looking. You can't get closure info until you've unpacked the + * variable header, but you don't know how big it is until you've + * got closure info. So...we trust that the closure in the buffer + * is organized the same way as they will be in the heap...at + * least up through the end of the variable header. + */ + + getClosureInfo((StgClosure *) *bufptrP, INFO_PTR_TO_STRUCT(ip), + &size, &ptrs, &nonptrs, &vhs); + + switch (INFO_PTR_TO_STRUCT(ip)->type) { + // bitmap layouts branch into special routines: + case PAP: + case AP: + closure = UnpackPAP(q, ip, bufptrP, cap); + // creates/enQs INDirections for pointers on stack + break; + + // MUT_ARR* need to allocate (but not fill) card table + // space after data space, and enqueue the closure + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN0: + case MUT_ARR_PTRS_FROZEN: + closure = UnpackArray(q, ip, bufptrP, cap); + break; + + // word arrays follow the "ptrs first" layout (with no pointers) + case ARR_WORDS: + + // normal closures with pointers-first layout (these are exactly + // the closures handled by PackGeneric above): + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_2_0: + case FUN_1_1: + case FUN_0_2: + case THUNK: + case THUNK_1_0: + case THUNK_0_1: + case THUNK_2_0: + case THUNK_1_1: + case THUNK_0_2: + case THUNK_SELECTOR: +#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 + + PACKETDEBUG( + 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)), + ptrs, nonptrs, vhs)); + + closure = (StgClosure*) allocate(cap, size); + + // Remember, the generic closure layout is as follows: + // +------------------------------------------------+ + // | IP | FIXED HDR | VARIABLE HDR | PTRS | NON-PRS | + // +------------------------------------------------+ + // Note that info ptr (IP) is assumed to be first hdr. field + + // Fill in the info pointer (extracted before) + ((StgPtr)closure)[0] = (StgWord) ip; + (*bufptrP)++; + + // Fill in the rest of the fixed header (if any) + for (i = 1; i < HEADERSIZE; i++) + ((StgPtr)closure)[i] = *(*bufptrP)++; + + // Fill in the packed variable header + for (i = 0; i < vhs; i++) + ((StgPtr)closure)[HEADERSIZE + i] = *(*bufptrP)++; + + // Pointers will be filled in later, but set zero here to + // easily check if there is a temporary BH. + for (i = 0; i < ptrs; i++) + ((StgPtr)closure)[HEADERSIZE + vhs + i] = 0; + + // Fill in the packed non-pointers + for (i = 0; i < nonptrs; i++) + ((StgPtr)closure)[HEADERSIZE + i + vhs + ptrs] + = *(*bufptrP)++; + + ASSERT(HEADERSIZE+vhs+ptrs+nonptrs == size); + + queueClosure(q, closure); + break; + + // other cases are unsupported/unexpected, and caught here + default: + errorBelch("Unpacking unexpected closure type (%x)\n", + INFO_PTR_TO_STRUCT(ip)->type); + return (StgClosure *) NULL; + } // switch(INFO_PTR_TO_STRUCT(ip)->type) + break; + + default: + // invalid markers (not OFFSET, PLC, CLOSURE) are caught here + errorBelch("unpackClosure: Found invalid marker %" FMT_Word ".\n", + (long) **bufptrP); + return (StgClosure *) NULL; + } + + return TAG_CLOSURE(tag, closure); +} + +// look up the closure's address for an offset in the hashtable +// advance buffer pointer while reading data +STATIC_INLINE StgClosure *UnpackOffset(HashTable* offsets, StgWord **bufptrP) { + StgClosure* existing; + int offset; + + ASSERT((long) **bufptrP == OFFSET); + + (*bufptrP)++; // skip marker + // unpack nat; find closure for this offset + offset = (nat) **bufptrP; + (*bufptrP)++; // skip offset + + ASSERT(offset != 0); + // find this closure in an offset hashtable (we can have several packets) + existing = (StgClosure *) lookupHashTable(offsets, offset); + + PACKETDEBUG(debugBelch("*<__ Unpacked indirection to closure %p" + " (was OFFSET %d)", existing, offset)); + + // we should have found something... + ASSERT(existing!= NULL); + + return existing; +} + +// unpack a static address (advancing buffer pointer while reading) +STATIC_INLINE StgClosure *UnpackPLC(StgWord **bufptrP) { + StgClosure* plc; + + ASSERT((long) **bufptrP == PLC); + + (*bufptrP)++; // skip marker + // Not much to unpack; just a static local address + // but need to correct the offset + plc = (StgClosure*) P_POINTER(**bufptrP); + (*bufptrP)++; // skip address + PACKETDEBUG(debugBelch("*<^^ Unpacked PLC at %p\n", plc)); + return plc; +} + +// unpacking PAPs (and other bitmap layout). Returns NULL in case of errors +static StgClosure * UnpackPAP(ClosureQ *queue, StgInfoTable *info, + StgWord **bufptrP, Capability* cap) { + + nat 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) + + // PAP layout in pack buffer + // +---------------------------....................---------------------+ + // | Header | (arity | n_args) | bsizeW | bitmap.. | nonPtr | nonPtr|...| + // +---------------------------....................---------------------+ + // + // The bitmap indicating pointers on the stack is packed after the header. + // For large bitmaps, their size in words is stored in the buffer; small + // bitmaps are indicated by a size of 0xFF..FF (SMALL_BITMAP_TAG). + // + // In the heap, there will be a function field instead of this bitmap, and + // the payload (stack) will have pointers interspersed with the packed + // nonptrs. + // The function field is filled in the usual way (as if a PAP was + // "ptrs-first"), the stack will be constructed with pointers to new + // indirections filled later. + + // Unpacking should result in the following layout in the heap: + // +----------------------------------------------------------------+ + // | Header | (arity , n_args) | Fct. | Arg/&Ind1 | Arg/&Ind2 | ... | + // +----------------------------------------------------------------+ + // followed by <= n_args indirections pointed at from the stack + + // calc./alloc. needed closure space in the heap, using common macros. + switch (INFO_PTR_TO_STRUCT(info)->type) { + case PAP: + hsize = HEADERSIZE + 1; + n_args = ((StgPAP*) *bufptrP)->n_args; + size = PAP_sizeW(n_args); + break; + case AP: + hsize = sizeofW(StgThunkHeader) + 1; + n_args = ((StgAP*) *bufptrP)->n_args; + size = AP_sizeW(n_args); + break; + default: + PACKDEBUG(errorBelch("UnpackPAP: strange info pointer, type %d ", + INFO_PTR_TO_STRUCT(info)->type)); + return (StgClosure*) NULL; + } + PACKETDEBUG(debugBelch("allocating %d heap words for a PAP (%d args)\n", + size, n_args)); + pap = (StgPtr) allocate(cap, size); + + // fill in info ptr (extracted and given as argument by caller) + pap[0] = (StgWord) info; + (*bufptrP)++; + + // fill in header fields (includes ( arity | n_args ) ) + for(i = 1; i < hsize; i++) { + pap[i] = (StgWord) *(*bufptrP)++; + } + // enqueue to get function field filled (see getClosureInfo) + queueClosure(queue, (StgClosure*) pap); + // zero the function field + pap[hsize] = (StgWord) NULL; + + // read bitmap size and bitmap + bsizeW = *(*bufptrP)++; + + // unpack the stack (size == args), starting at pap[hsize] + // make room for fct. pointer, thus start at hsize+1 + + if (bsizeW == SMALL_BITMAP_TAG) { + StgWord bitmap; + // small bitmap, just read it and unpack accordingly + bitmap = (StgWord) *(*bufptrP)++; + + // bitmap size irrelevant here, but should be >= n_args + ASSERT(n_args <= BITMAP_SIZE(bitmap)); + bitmap = BITMAP_BITS(bitmap); + for (i = hsize + 1; i < hsize + n_args; i++, bitmap >>= 1) { + if (bitmap & 1) { + // non-pointer, just unpack it + pap[i] = (StgWord) *(*bufptrP)++; + } else { + // pointer: create and enqueue a new indirection, store a + // pointer to it on the stack + StgInd *ind; + // allocate a new closure + ind = (StgInd*) allocate(cap, sizeofW(StgInd)); + SET_HDR(ind, &stg_IND_info, CCS_SYSTEM); // set ccs + // zero the indirectee field (should be filled later) + ind->indirectee = (StgClosure*) NULL; + // store a pointer + pap[i] = (StgWord) ind; + queueClosure(queue, (StgClosure*) ind); + } + bitmap >>= 1; + } + + } else { + debugBelch("yuck, unpacking large bitmap"); + return (StgClosure*) NULL; + // need to repeatedly read a new bitmap and proceed + StgPtr bitmapPos; + nat j; + StgWord bitmap; + + // ... walk through the bitmap until n_args have been unpacked + bitmapPos = *bufptrP; + bitmap = *bitmapPos; + j = BITS_IN(StgWord); + for (i = hsize + 1; i < hsize + n_args; i++) { + if (bitmap & 1) { + // non-pointer, just unpack it + pap[i] = (StgWord) *(*bufptrP)++; + } else { + // pointer: create and enqueue a new indirection, store a + // pointer to it on the stack + StgInd *ind; + // allocate a new closure + ind = (StgInd*) allocate(cap, sizeofW(StgInd)); + SET_HDR(ind, &stg_IND_info, CCS_SYSTEM); // set ccs + // zero the indirectee field (should be filled later) + ind->indirectee = (StgClosure*) NULL; + // store a pointer + pap[i] = (StgWord) ind; + queueClosure(queue, (StgClosure*) ind); + } + // advance into next part of bitmap when current one done + j--; + if (j == 0) { + bitmapPos++; + bitmap = *bitmapPos; + j = BITS_IN(StgWord); + } else { + bitmap >>= 1; + } + } + } + + return (StgClosure*) pap; +} + +// unpacking arrays. Returns NULL in case of errors. +static StgClosure* UnpackArray(ClosureQ *queue, StgInfoTable* info, + StgWord **bufptrP, Capability* cap) { + nat size; + StgMutArrPtrs *array; + + nat 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 && + type != MUT_ARR_PTRS_FROZEN0 && type != MUT_ARR_PTRS_FROZEN) { + + PACKDEBUG(errorBelch("UnpackArray: unexpected closure type %d", + INFO_PTR_TO_STRUCT(info)->type)); + return (StgClosure *) NULL; + } + + // Since GHC-6.13, ptr arrays additionally carry a "card table" + // for generational GC (to indicate mutable/dirty elements). For + // unpacking, allocate the card table and fill it with zero. + // Array layout in buffer: + // +------------------------+......................................+ + // | IP'| Hdr | ptrs | size | ptr1 | ptr2 | .. | ptrN | card space | + // +------------------------+......................................+ + // (added in heap when unpacking) + // ptrs indicates how many pointers to come (N). Size field gives + // total size for pointers and card table behind (to add). + + // size = sizeofW(StgMutArrPtrs) + (StgWord) *((*bufptrP)+2); + size = closure_sizeW_((StgClosure*) *bufptrP, INFO_PTR_TO_STRUCT(info)); + ASSERT(size == sizeofW(StgMutArrPtrs) + ((StgMutArrPtrs*) *bufptrP)->size); + PACKETDEBUG(debugBelch("Unpacking ptrs array, %" FMT_Word + " ptrs, size %d\n", + (StgWord) *((*bufptrP)+1), size)); + array = (StgMutArrPtrs *) allocate(cap, size); + + // set area 0 (Blackhole-test in unpacking and card table) + memset(array, 0, size*sizeof(StgWord)); + // write header + for (size = 0; size < (sizeof(StgMutArrPtrs)/sizeof(StgWord)); size++) + ((StgPtr) array)[size] = (StgWord) *(*bufptrP)++; + // correct first word (info ptr, stored with offset in packet) + ((StgPtr)array)[0] = (StgWord) info; + // and enqueue it, pointers will be filled in subsequently + queueClosure(queue, (StgClosure*)array); + + PACKETDEBUG(debugBelch(" Array created @ %p.\n",array)); + + return (StgClosure*) array; +} + + +#ifndef LIBRARY_CODE +// creating new heap closures: + +// creating a black hole (to receive remote data), owned by the system tso +StgClosure* createBH(Capability *cap) { + StgClosure *new; + + // a blackhole carries one pointer of payload, see StgMiscClosures.cmm, so + // we allocate 2 words. The payload indicates the blackhole owner, in our + // case it is the "system" (or later, the cap, for -threaded rts). + new = (StgClosure*) allocate(cap, 2); + + SET_HDR(new, &stg_BLACKHOLE_info, CCS_SYSTEM); // ccs to be checked! + + new->payload[0] = (StgClosure*) &stg_system_tso; + // see above. Pseudo-TSO (has TSO info pointer) owning all + // system-created black holes, and storing BQs. + + return new; +} + +// cons node info pointer, from GHC.Base +#define CONS_INFO ghczmprim_GHCziTypes_ZC_con_info +// constructor tag for pointer tagging. We return a tagged pointer here! +#define CONS_TAG 2 +extern const StgInfoTable CONS_INFO[]; + +// creating a list node. returns a tagged pointer. +StgClosure* createListNode(Capability *cap, StgClosure *head, StgClosure *tail) { + StgClosure *new; + + // a list node (CONS) carries two pointers => 3 words to allocate + // if we have given a capability, we can allocateLocal (cheaper, no lock) + new = (StgClosure*) allocate(cap, 3); + + SET_HDR(new, CONS_INFO, CCS_SYSTEM); // to be checked!!! + new->payload[0] = head; + new->payload[1] = tail; + + return TAG_CLOSURE(CONS_TAG,new); +} +#endif + +// debugging functions +#if defined(DEBUG) + +/* + Generate a finger-print for a graph. A finger-print is a string, + with each char representing one node; depth-first traversal. + Will only be called inside this module. +*/ + +/* this array has to be kept in sync with includes/ClosureTypes.h */ +#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) */ + "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__ >= 708 + "ZZZZ" /* SmallArr (61-64) */ +#endif + ; + + +// recursive worker function: +static void graphFingerPrint_(char* fingerPrintStr, + HashTable* tmpClosureTable, StgClosure *p); + +static void graphFingerPrint(char* fingerPrintStr, StgClosure *p) +{ + HashTable* visitTable; + + // delete old fingerprint: + fingerPrintStr[0]='\0'; + + /* init hash table */ + visitTable = allocHashTable(); + + /* now do the real work */ + graphFingerPrint_(fingerPrintStr, visitTable, p); + + /* nuke hash table */ + freeHashTable(visitTable, NULL); + + ASSERT(strlen(fingerPrintStr)<=MAX_FINGER_PRINT_LEN); +} + +/* + This is the actual worker functions. + All recursive calls should be made to this function. +*/ +static void graphFingerPrint_(char* fp, HashTable* visited, StgClosure *p) { + nat i, len, args, arity; + const StgInfoTable *info; + StgWord *payload; + + // first remove potential pointer tags + p = UNTAG_CLOSURE(p); + + len = strlen(fp); + ASSERT(len<=MAX_FINGER_PRINT_LEN); + if (len+2 >= MAX_FINGER_PRINT_LEN) + return; + /* at most 7 chars added immediately (unchecked) for this node */ + if (len+7 >= MAX_FINGER_PRINT_LEN) { + strcat(fp, "--end"); + return; + } + /* check whether we have met this node already to break cycles */ + if (lookupHashTable(visited, (StgWord)p)) { // ie. already touched + strcat(fp, "."); + return; + } + + /* record that we are processing this closure */ + insertHashTable(visited, (StgWord) p, (void *)rtsTrue/*non-NULL*/); + + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); + + info = get_itbl((StgClosure *)p); + + // append char for this node + fp[len] = fingerPrintChar[info->type]; + fp[len+1] = '\0'; + /* the rest of this fct recursively traverses the graph */ + switch (info -> type) { + + // simple and static objects + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + case FUN_STATIC: + case THUNK_STATIC: + break; + + /* CONSTRs, THUNKs, FUNs are written with arity */ + case THUNK_2_0: + // append char for this node + strcat(fp, "20("); + // special treatment for thunks... extra smp header field + graphFingerPrint_(fp, visited, ((StgThunk *)p)->payload[0]); + graphFingerPrint_(fp, visited, ((StgThunk *)p)->payload[1]); + if (strlen(fp)+2payload[0]); + graphFingerPrint_(fp, visited, ((StgClosure *)p)->payload[1]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + break; + + case THUNK_1_0: + // append char for this node + strcat(fp, "10("); + graphFingerPrint_(fp, visited, ((StgThunk *)p)->payload[0]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + break; + + case FUN_1_0: + case CONSTR_1_0: + // append char for this node + strcat(fp, "10("); + graphFingerPrint_(fp, visited, ((StgClosure *)p)->payload[0]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + break; + + case THUNK_0_1: + case FUN_0_1: + case CONSTR_0_1: + // append char for this node + strcat(fp, "01"); + break; + + case THUNK_0_2: + case FUN_0_2: + case CONSTR_0_2: + // append char for this node + strcat(fp, "02"); + break; + + case THUNK_1_1: + // append char for this node + strcat(fp, "11("); + graphFingerPrint_(fp, visited, ((StgThunk *)p)->payload[0]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + break; + + case FUN_1_1: + case CONSTR_1_1: + // append char for this node + strcat(fp, "11("); + graphFingerPrint_(fp, visited, ((StgClosure *)p)->payload[0]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + break; + + case THUNK: + { + char str[6]; + sprintf(str,"%d?(", info->layout.payload.ptrs); + strcat(fp,str); + for (i = 0; i < info->layout.payload.ptrs; i++) + graphFingerPrint_(fp, visited, ((StgThunk *)p)->payload[i]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + } + break; + + case FUN: + case CONSTR: + { + char str[6]; + sprintf(str,"%d?(",info->layout.payload.ptrs); + strcat(fp,str); + for (i = 0; i < info->layout.payload.ptrs; i++) + graphFingerPrint_(fp, visited, + ((StgClosure *)p)->payload[i]); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + } + break; + + case THUNK_SELECTOR: + graphFingerPrint_(fp, visited, ((StgSelector *)p)->selectee); + break; + + case BCO: + break; + + case AP_STACK: + // unsure how to handle this one + break; + case AP: + arity = ((StgAP*)p)->arity; + args = ((StgAP*)p)->n_args; + payload = (StgPtr)((StgAP*)p)->payload; + p = ((StgAP*)p)->fun; + goto print; + + case PAP: + /* note the arity (total #args) and n_args (how many supplied) */ + arity = ((StgPAP*)p)->arity; + args = ((StgPAP*)p)->n_args; + payload = (StgPtr) ((StgPAP*)p)->payload; + p = ((StgPAP*)p)->fun; +print: + { char str[6]; + sprintf(str,"%d/%d(", arity, args); + strcat(fp, str); + // follow the function, and everything on the stack + graphFingerPrint_(fp, visited, (StgClosure *) (p)); + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) { + StgWord bitmap; + 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...*/ + case ARG_GEN_BIG: + case ARG_BCO: + bitmap = (StgWord) (~0); // all ones + break; + case ARG_GEN: + bitmap = funInfo->f.b.bitmap; + break; + default: + bitmap = stg_arg_bitmaps[funInfo->f.fun_type]; + } + // size = BITMAP_SIZE(bitmap); + bitmap = BITMAP_BITS(bitmap); + while (args > 0) { + if ((bitmap & 1) == 0) + graphFingerPrint_(fp, visited, + (StgClosure *)(*payload)); + else { + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, "x"); + } + payload++; + args--; + bitmap = bitmap>>1; + } + } + if (strlen(fp)+2 < MAX_FINGER_PRINT_LEN) + strcat(fp, ")"); + } + break; + + case IND: + case IND_PERM: + case IND_STATIC: + /* do not print the '_' for indirections */ + fp[len] = '\0'; + /* could also be different type StgIndStatic */ + graphFingerPrint_(fp, visited, ((StgInd*)p)->indirectee); + break; + + case RET_BCO: + case RET_SMALL: + case RET_BIG: + case RET_FUN: + case UPDATE_FRAME: + case CATCH_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: + case BLOCKING_QUEUE: + case BLACKHOLE: + // check if this is actually an indirection. See above in + // packing code, some Blackholes are actually indirections + // since ghc-7.0 + switch (((StgInfoTable*) + get_itbl(UNTAG_CLOSURE(((StgInd*)p)->indirectee)))->type) { + case TSO: + case BLOCKING_QUEUE: + debugBelch("Woops! Found blackhole during fingerprint!\n"); + break; + default: + /* do not print the '_' for indirections */ + fp[len] = '\0'; + graphFingerPrint_(fp, visited, ((StgInd*)p)->indirectee); + break; + } + break; + + case MVAR_CLEAN: + case MVAR_DIRTY: + // follow MVar contents unless empty (END_TSO_QUEUE is magic) + if (((StgMVar *)p)->value != (StgClosure*) END_TSO_QUEUE) + graphFingerPrint_(fp, visited, ((StgMVar *)p)->value); + break; + + case TVAR: + // The TVAR type subsumes both the var itself and a watch + // queue; the latter holds a TSO or an "Atomic Invariant" + // where the former (clean/dirty) holds the current value + // as its first payload. Anyways, while useful for GC, the + // double meaning of the first payload is not useful for + // fingerprinting. We do not descend into TVars. + break; + + case ARR_WORDS: + { // record size only (contains StgWords, not pointers) + char str[6]; + sprintf(str, "%ld", (long) arr_words_words((StgArrWords*)p)); + strcat(fp, str); + } + break; + + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN0: + case MUT_ARR_PTRS_FROZEN: + { + char str[6]; + sprintf(str, "%ld", (long)((StgMutArrPtrs*)p)->ptrs); + strcat(fp, str); + nat i; + for (i = 0; i < ((StgMutArrPtrs*)p)->ptrs; i++) { + //contains closures... follow + graphFingerPrint_(fp, visited, + ((StgMutArrPtrs*)p)->payload[i]); + } + break; + } + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: + graphFingerPrint_(fp, visited, ((StgMutVar *)p)->var); + break; + + case WEAK: + case PRIM: + break; + case MUT_PRIM: + break; + case TSO: + break; + case STACK: + break; + + case TREC_CHUNK: + case ATOMICALLY_FRAME: + case CATCH_RETRY_FRAME: + case CATCH_STM_FRAME: + case WHITEHOLE: + break; + +#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: + { + char str[6]; + sprintf(str,"%ld",(long)((StgSmallMutArrPtrs*)p)->ptrs); + strcat(fp,str); + nat i; + for (i = 0; i < ((StgSmallMutArrPtrs*)p)->ptrs; i++) { + //contains closures... follow + graphFingerPrint_(fp, visited, + ((StgSmallMutArrPtrs*)p)->payload[i]); + } + break; + } +#endif + + default: + barf("graphFingerPrint_: unknown closure %d", + info -> type); + } + +} + +// 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) { + StgInt packsize, openptrs; + nat clsize, ptrs, nonptrs, vhs; + StgWord *bufptr; + HashTable *offsets; + + PACKDEBUG(debugBelch("checking packet (@ %p), size %ld words ...", + buffer, (long) size)); + + offsets = allocHashTable(); // used to identify valid offsets + packsize = 0; // compared against argument + openptrs = 1; // counting pointers (but no need for a queue to fill them in) + // initially, one pointer is open (graphroot) + bufptr = buffer; + + do { + StgWord tag; + StgInfoTable *ip; + + ASSERT(*bufptr != END_OF_BUFFER_MARKER); + + // unpackclosure essentials are mimicked here + tag = *bufptr; // marker in buffer (PLC | OFFSET | CLOSURE) + + if (tag == PLC) { + bufptr++; // skip marker + // check that this looks like a PLC (static data) + // which is however complicated when code and data mix... TODO + + bufptr++; // move forward + packsize += 2; + } else if (tag == OFFSET) { + bufptr++; // skip marker + if (!lookupHashTable(offsets, *bufptr)) { + barf("invalid offset %" FMT_Word " in packet " + " at position %p", *bufptr, bufptr); + } + bufptr++; // move forward + packsize += 2; + } else if (tag == CLOSURE) { + bufptr++; // skip marker + + // untag info offset and compute info pointer (first word of the + // closure), then compute a proper info table + ip = UNTAG_CAST(StgInfoTable*,P_POINTER(*bufptr)); + + // check info ptr + if (!LOOKS_LIKE_INFO_PTR((StgWord) ip)) { + barf("Non-closure found in packet" + " at position %p (value %p)\n", + bufptr, ip); + } + + // analogous to unpacking, we pretend the buffer is a heap closure + ip = getClosureInfo((StgClosure*) bufptr, INFO_PTR_TO_STRUCT(ip), + &clsize, &ptrs, &nonptrs, &vhs); + + // PACKETDEBUG(debugBelch("size (%ld + %d + %d +%d, = %d)", + // HEADERSIZE, vhs, ptrs, nonptrs, clsize)); + + // This is rather a test for getClosureInfo...but used here + if (clsize != (nat) HEADERSIZE + vhs + ptrs + nonptrs) { + barf("size mismatch in packed closure at %p :" + "(%d + %d + %d +%d != %d)", bufptr, + HEADERSIZE, vhs, ptrs, nonptrs, clsize); + } + + // do a plausibility check on the values. Assume we never see + // large numbers of ptrs and non-ptrs simultaneously + if (ptrs > 99 && nonptrs > 99) { + barf("Found weird infoptr %p in packet " + " (position %p): vhs %d, %d ptrs, %d non-ptrs, size %d", + ip, bufptr, vhs, ptrs, nonptrs, clsize); + } + + // Register the pack location as a valid offset. Offsets are + // one-based (we incremented bufptr before) in units of StgWord + // (which is magically adjusted by the C compiler here!). + insertHashTable(offsets, + (StgWord) ( bufptr - buffer ), + bufptr); // No need to store any value + + switch (ip->type) { + // some closures need special treatment, as their size in the + // packet is unobvious + + case PAP: + // all arg.s packed as tag + value, 2 words per arg. + bufptr += sizeofW(StgHeader) + 1 + 2*((StgPAP*) bufptr)->n_args; + packsize += 1 + sizeofW(StgHeader) + 1 + 2*((StgPAP*) bufptr)->n_args; + break; + case AP: // same, but thunk header + bufptr += sizeofW(StgThunkHeader) + 1 + 2*((StgAP*) bufptr)->n_args; + packsize += 1 + sizeofW(StgThunkHeader) + 1 + 2*((StgAP*) bufptr)->n_args; + break; + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN0: + case MUT_ARR_PTRS_FROZEN: + // card table is counted as non-pointer, but not in packet + bufptr += sizeofW(StgHeader) + vhs; + packsize += 1 + sizeofW(StgHeader) + vhs; + break; + default: // standard (ptrs. first) layout + bufptr += HEADERSIZE + vhs + nonptrs; + packsize += (StgInt) 1 + HEADERSIZE + vhs + nonptrs; + } + + openptrs += (StgInt) ptrs; // closure needs some pointers to be filled in + } else { + barf("found invalid tag %x in packet", *bufptr); + } + + openptrs--; // one thing was unpacked + + } while (openptrs != 0 && packsize < size); + + PACKDEBUG(debugBelch(" traversed %" FMT_Word " words.", packsize)); + + if (openptrs != 0) { + barf("%d open pointers at end of packet ", + openptrs); + } + + IF_DEBUG(sanity, ASSERT(*(bufptr++) == END_OF_BUFFER_MARKER && packsize++)); + + if (packsize != size) { + barf("surplus data (%" FMT_Word " words) at end of packet ", + size - packsize); + } + + freeHashTable(offsets, NULL); + PACKDEBUG(debugBelch("packet OK\n")); + +} + +/* 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/cbits/Types.h b/cbits/Types.h new file mode 100644 --- /dev/null +++ b/cbits/Types.h @@ -0,0 +1,17 @@ +#ifndef PACKMAN_TYPES_H +#define PACKMAN_TYPES_H + + + +// packing and sending: +// Pack Buffer for constructing messages between PEs +// defined here instead of in RtsTypes.h due to FLEXIBLE_ARRAY usage +typedef struct pmPackBuffer_ { + // for data messages only, + StgInt /* nat */ size; + StgInt /* nat */ unpacked_size; + StgWord buffer[FLEXIBLE_ARRAY]; +} pmPackBuffer; + + +#endif /* PACKMAN_TYPES_H */ diff --git a/cbits/Wrapper.cmm b/cbits/Wrapper.cmm new file mode 100644 --- /dev/null +++ b/cbits/Wrapper.cmm @@ -0,0 +1,54 @@ +#include +#include "Errors.h" + +STRING(debugval, "debugval %d") + +stg_tryPack (gcptr original, gcptr buffer) +{ + // args: closure (graph root to serialize) + // buffer (MutableByteArray to pack into) + W_ errCode; + W_ size; + + MAYBE_GC_PP(stg_tryPack, original, buffer); + + // assign something to keep cmm reg.allocator happy + errCode = P_SUCCESS; + + // call packing function (without giving the TSO, no blocking) + (size) = ccall pmtryPackToBuffer(original "ptr", buffer "ptr"); + // small values indicate failure (size biased with P_ERRCODEMAX, + // see Errors.h and Pack.c + // NB seems Cmm always compares unsigned (wanted to use negative values here) + if (size < P_ERRCODEMAX ) { + errCode = size; + size = 0; + } else { + size = size - P_ERRCODEMAX; + } + + return (errCode, size); +} + +stg_unpack (gcptr buff) +{ + // args: R1 ByteArray# containing a serialized subgraph + W_ new; + W_ errCode; + + // assign something to keep cmm reg.allocator happy + new = ghczmprim_GHCziTypes_False_closure; + errCode = P_SUCCESS; + + MAYBE_GC_P(stg_unpack, buff); + + // call packing function + ("ptr" new) = ccall pmUnpackGraphWrapper(buff "ptr", MyCapability() "ptr"); + + if (new <= P_ERRCODEMAX) { + errCode = new; + new = ghczmprim_GHCziTypes_False_closure; + } + + return (errCode, new); +} diff --git a/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs b/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import QCTest ( tests ) +main :: IO () +main = stubMain tests diff --git a/pack.old b/pack.old new file mode 100644 Binary files /dev/null and b/pack.old differ diff --git a/packman.cabal b/packman.cabal new file mode 100644 --- /dev/null +++ b/packman.cabal @@ -0,0 +1,180 @@ +name: packman +version: 0.3.0 +synopsis: Serialization library for GHC + +description: + This package provides Haskell data serialisation independent of evaluation, + by accessing the Haskell heap using foreign primitive operations. + Any Haskell data structure apart from mutable data structures (@MVar@s + and @TVar@s) can be serialised and later deserialised during the same run, + or loaded into a new run, of the same program (the same executable file). + . + The library provides operations to @serialize@ Haskell heap data, + and to @deserialize@ it: + . + > trySerializeWith :: a -> Int -> IO (Serialized a) -- Int is maximum buffer size to use + > trySerialize :: a -> IO (Serialized a) -- uses default (maximum) buffer size + > deserialize :: Serialized a -> IO a + . + The data type @Serialized a@ is an opaque representation of serialised + Haskell data (it contains a @ByteArray@). + A phantom type @a@ ensures type safety within the same program run. + Type @a@ can be polymorphic (at compile time, that is) when @Serialized a@ + is not used apart from being argument to @deserialize@. + When data are externalised (written to disk or communicated over the + network) using the provided instances of @Binary@ or @Read@ and @Show@, + @a@ needs to be monomorphic because they require @Typeable@ context. + The instances for @Show@ and @Read@ satisfy @read . show == id@. + . + Packman serialisation is /orthogonal/ to evaluation, heap data are + serialised /in their current state of evaluation/, they might be entirely + unevaluated (a thunk) or only partially evaluated (containing thunks). + Therefore, there can be cases where a mutable data structure is captured by + a thunk, and lead to serialisation failures (typically related to lazy I/O). + . + The serialisation routine will throw a @PackException@ if an error occurs + inside the C code which accesses the Haskell heap, if a mutable data + structure is serialised, or if the serialised data is too large. + In presence of concurrent threads, another thread might be evaluating + data /referred to/ by the data to be serialised. In this case, the calling + thread will /block/ on the ongoing evaluation and continue when evaluated + data is available. + Internally, there is a @PackException@ @P_BLACKHOLE@ to signal the + condition, but it is hidden inside the core library + +category: Serialization, Data, GHC +license: BSD3 +license-file: LICENSE +author: Michael Budde, Ásbjørn V. Jøkladal, Jost Berthold +maintainer: jost.berthold@gmail.com +build-type: Simple +cabal-version: >= 1.18 +tested-with: GHC==7.8.2, GHC==7.8.3, GHC==7.10.2 +extra-source-files: cbits/Wrapper.cmm + cbits/Pack.c + cbits/Errors.h + cbits/Types.h + cbits/GHCFunctions.h + pack.old + +flag debug + manual: True + default: False + description: Enable debug support +-- we abuse flags "prof(p)" and "sparks(r)" and use "sanity(S)" + +library + exposed-modules: GHC.Packing + GHC.Packing.PackException + GHC.Packing.Type + GHC.Packing.Core + build-depends: base >= 4.7 && < 5, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5 + if flag(debug) + ghc-options: -debug -optc-DDEBUG -optc-g + + c-sources: cbits/Wrapper.cmm + cbits/Pack.c + include-dirs: cbits + includes: + default-language: Haskell2010 + if flag(debug) + cc-options: -g -DDEBUG -DLIBRARY_CODE + else + cc-options: -DLIBRARY_CODE + +test-suite simpletest + type: exitcode-stdio-1.0 + main-is: TestSerialisation.hs + hs-source-dirs: Test + build-depends: base >= 4.7, + directory >= 1.2, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5, + packman + default-language: Haskell2010 + if flag(debug) + ghc-options: -debug -optc-g -optc-DDEBUG + +test-suite testexceptions + type: exitcode-stdio-1.0 + main-is: TestExceptions.hs + hs-source-dirs: Test + build-depends: base >= 4.7, + directory >= 1.2, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5, + Cabal >= 1.18, + packman + default-language: Haskell2010 + if flag(debug) + ghc-options: -debug -optc-g -optc-DDEBUG + +test-suite alltests + type: detailed-0.9 + test-module: AllTests + hs-source-dirs: Test + build-depends: base >= 4.7, + directory >= 1.2, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5, + Cabal >= 1.20, + packman + default-language: Haskell2010 + if flag(debug) + ghc-options: -debug -optc-g -optc-DDEBUG + +test-suite testmthread + type: exitcode-stdio-1.0 + main-is: TestMThread.hs + hs-source-dirs: Test + build-depends: base >= 4.7, + directory >= 1.2, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5, + Cabal >= 1.20, + packman + default-language: Haskell2010 + if flag(debug) + ghc-options: -with-rtsopts=-N4 -debug -threaded -optc-g -optc-DDEBUG + else + ghc-options: -with-rtsopts=-N4 -threaded + +test-suite quickchecktest + type: detailed-0.9 + test-module: QCTest + hs-source-dirs: Test + build-depends: base >= 4.7, + directory >= 1.2, + ghc-prim >= 0.3, + array >= 0.5, + binary >= 0.7, + bytestring >= 0.10, + primitive >= 0.5, + Cabal >= 1.20, + QuickCheck >= 2.6, + packman + default-language: Haskell2010 + if flag(debug) + ghc-options: -debug -optc-g -optc-DDEBUG + + +source-repository head + type: git + location: git://github.com/jberthold/packman.git