packman (empty) → 0.3.0

raw patch · 20 files changed

+4464/−0 lines, 20 filesdep +Cabaldep +QuickCheckdep +arraysetup-changedbinary-added

Dependencies added: Cabal, QuickCheck, array, base, binary, bytestring, directory, ghc-prim, packman, primitive

Files

• GHC/Packing.hs +224/−0
• GHC/Packing/Core.hs +112/−0
• GHC/Packing/PackException.hsc +100/−0
• GHC/Packing/Type.hs +294/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• Test/AllTests.hs +98/−0
• Test/QCTest.hs +130/−0
• Test/TestExceptions.hs +156/−0
• Test/TestMThread.hs +106/−0
• Test/TestSerialisation.hs +98/−0
• cbits/Errors.h +29/−0
• cbits/GHCFunctions.h +33/−0
• cbits/Pack.c +2791/−0
• cbits/Types.h +17/−0
• cbits/Wrapper.cmm +54/−0
• dist/build/alltestsStub/alltestsStub-tmp/alltestsStub.hs +5/−0
• dist/build/quickchecktestStub/quickchecktestStub-tmp/quickchecktestStub.hs +5/−0
• pack.old binary
• packman.cabal +180/−0

@@ -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 +<http://www.mathematik.uni-marburg.de/~eden/papers/mainIFL10-withCopyright.pdf>,+the original publication is available at +<http://www.springerlink.com/content/78642611n7623551/>.++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 )+-}

@@ -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 #)+

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

@@ -0,0 +1,294 @@+{-# LANGUAGE CPP, MagicHash, BangPatterns, ScopedTypeVariables #-}++{-|++Module      : GHC.Packing.Type+Copyright   : (c) Jost Berthold, 2010-2015,+License     : BSD3+Maintainer  : Jost Berthold <jost.berthold@gmail.com>+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+-- <http://www.haskell.org/ghc/docs/7.8.3/html/users_guide/bugs-and-infelicities.html#haskell-98-2010-undefined>++-- 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

@@ -0,0 +1,30 @@+The packman serialisation library for GHC+Copyright (c) 2014-15, Jost Berthold <jost.berthold@gmail.com>+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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

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

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

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

@@ -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..]))++-}

@@ -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..]))+

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

@@ -0,0 +1,33 @@+/* Packing as a library:+ *+ * GHC functions linked into the C code we use+ *+ */++#include <Rts.h>+// This brings in a lot of declared functions.++// All these are internal functions of the GHC runtime. While their+// functionality is usually very stable, future versions might need to+// #ifdef-out or modify some of these declarations.+++// Internal functions in the GHC runtime+extern char* info_type(StgClosure*);+extern char* info_type_by_ip(StgInfoTable*);++// Internal hash table implementation+typedef struct hashtable HashTable;+extern HashTable *allocHashTable(void);+extern void *lookupHashTable(HashTable *table, StgWord key);+extern void  insertHashTable(HashTable *table, StgWord key, void *data);+extern void *removeHashTable(HashTable *table, StgWord key, void *data);+extern void  freeHashTable(HashTable *table, void (*freeDataFun)(void *));++// Internal malloc wrapper functions+extern void *stgMallocBytes(int n, char *msg) GNUC3_ATTRIBUTE(__malloc__);+extern void  stgFree(void* p);++#ifdef DEBUG+extern void checkClosure(StgClosure*);+#endif

@@ -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 <Rts.h>+#include <string.h>++#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 <string.h> // 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; i<payloadsize; i++)+        queueClosure(p->queue, ((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)+2<MAX_FINGER_PRINT_LEN)+                strcat(fp, ")");+            break;++        case FUN_2_0:+        case CONSTR_2_0:+            // append char for this node+            strcat(fp, "20(");+            graphFingerPrint_(fp, visited, ((StgClosure *)p)->payload[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:

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

@@ -0,0 +1,54 @@+#include <Cmm.h>+#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);+}

@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import AllTests ( tests )+main :: IO ()+main = stubMain tests

@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import QCTest ( tests )+main :: IO ()+main = stubMain tests

binary file changed (absent → 168 bytes)

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