Commit 7036fde9 authored by Simon Marlow's avatar Simon Marlow

Overhaul of Compact Regions (#12455)

Summary:
This commit makes various improvements and addresses some issues with
Compact Regions (aka Compact Normal Forms).

This was the most important thing I wanted to fix.  Compaction
previously prevented GC from running until it was complete, which
would be a problem in a multicore setting.  Now, we compact using a
hand-written Cmm routine that can be interrupted at any point.  When a
GC is triggered during a sharing-enabled compaction, the GC has to
traverse and update the hash table, so this hash table is now stored
in the StgCompactNFData object.

Previously, compaction consisted of a deepseq using the NFData class,
followed by a traversal in C code to copy the data.  This is now done
in a single pass with hand-written Cmm (see rts/Compact.cmm). We no
longer use the NFData instances, instead the Cmm routine evaluates
components directly as it compacts.

The new compaction is about 50% faster than the old one with no
sharing, and a little faster on average with sharing (the cost of the
hash table dominates when we're doing sharing).

Static objects that don't (transitively) refer to any CAFs don't need
to be copied into the compact region.  In particular this means we
often avoid copying Char values and small Int values, because these
are static closures in the runtime.

Each Compact# object can support a single compactAdd# operation at any
given time, so the Data.Compact library now enforces mutual exclusion
using an MVar stored in the Compact object.

We now get exceptions rather than killing everything with a barf()
when we encounter an object that cannot be compacted (a function, or a
mutable object).  We now also detect pinned objects, which can't be
compacted either.

The Data.Compact API has been refactored and cleaned up.  A new
compactSize operation returns the size (in bytes) of the compact
object.

Most of the documentation is in the Haddock docs for the compact
library, which I've expanded and improved here.

Various comments in the code have been improved, especially the main
Note [Compact Normal Forms] in rts/sm/CNF.c.

I've added a few tests, and expanded a few of the tests that were
there.  We now also run the tests with GHCi, and in a new test way
that enables sanity checking (+RTS -DS).

There's a benchmark in libraries/compact/tests/compact_bench.hs for
measuring compaction speed and comparing sharing vs. no sharing.

The field totalDataW in StgCompactNFData was unnecessary.

Test Plan:
* new unit tests
* validate
* tested manually that we can compact Data.Aeson data

Reviewers: gcampax, bgamari, ezyang, austin, niteria, hvr, erikd

Subscribers: thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D2751

GHC Trac Issues: #12455
parent 4dd6b37f
......@@ -2444,14 +2444,6 @@ primop CompactNewOp "compactNew#" GenPrimOp
has_side_effects = True
out_of_line = True
primop CompactAppendOp "compactAppend#" GenPrimOp
Compact# -> a -> Int# -> State# RealWorld -> (# State# RealWorld, a #)
{ Append an object to a compact, return the new address in the Compact.
The third argument is 1 if sharing should be preserved, 0 otherwise. }
with
has_side_effects = True
out_of_line = True
primop CompactResizeOp "compactResize#" GenPrimOp
Compact# -> Word# -> State# RealWorld ->
State# RealWorld
......@@ -2515,6 +2507,34 @@ primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp
has_side_effects = True
out_of_line = True
primop CompactAdd "compactAdd#" GenPrimOp
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
{ Recursively add a closure and its transitive closure to a
{\texttt Compact\#}, evaluating any unevaluated components at the
same time. Note: {\texttt compactAdd\#} is not thread-safe, so
only one thread may call {\texttt compactAdd\#} with a particular
{\texttt Compact#} at any given time. The primop does not
enforce any mutual exclusion; the caller is expected to
arrange this. }
with
has_side_effects = True
out_of_line = True
primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
{ Like {\texttt compactAdd\#}, but retains sharing and cycles
during compaction. }
with
has_side_effects = True
out_of_line = True
primop CompactSize "compactSize#" GenPrimOp
Compact# -> State# RealWorld -> (# State# RealWorld, Word# #)
{ Return the size (in bytes) of the total amount of data in the Compact# }
with
has_side_effects = True
out_of_line = True
------------------------------------------------------------------------
section "Unsafe pointer equality"
-- (#1 Bad Guy: Alastair Reid :)
......
......@@ -311,6 +311,13 @@ Use a bigger heap!
consume, or perhaps try passing :ghc-flag:`-H` without any argument to let GHC
calculate a value based on the amount of live data.
Compact your data:
The ``Data.Compact`` library (in the ``compact`` package) provides
a way to make garbage collection more efficient for long-lived
data structures. Compacting a data structure collects the objects
together in memory, where they are treated as a single object by
the garbage collector and not traversed individually.
.. _smaller:
Smaller: producing a program that is smaller
......
......@@ -95,6 +95,7 @@ typedef struct _DEBUG_FLAGS {
bool hpc; /* 'c' coverage */
bool sparks; /* 'r' */
bool numa; /* '--debug-numa' */
bool compact; /* 'C' */
} DEBUG_FLAGS;
/* See Note [Synchronization of flags and base APIs] */
......
......@@ -421,12 +421,6 @@ closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)
return bco_sizeW((StgBCO *)p);
case TREC_CHUNK:
return sizeofW(StgTRecChunk);
case COMPACT_NFDATA:
// Nothing should ever call closure_sizeW() on a StgCompactNFData
// because CompactNFData is a magical object/list-of-objects that
// requires special paths pretty much everywhere in the GC
barf("closure_sizeW() called on a StgCompactNFData. "
"This should never happen.");
default:
return sizeW_fromITBL(info);
}
......
......@@ -419,49 +419,61 @@ typedef struct MessageBlackHole_ {
StgClosure *bh;
} MessageBlackHole;
// This is not a closure, it a bare
// structure that lives at the beginning of
// each consecutive block group in a
// compact structure
/* ----------------------------------------------------------------------------
Compact Regions
------------------------------------------------------------------------- */
//
// A compact region is a list of blocks. Each block starts with an
// StgCompactNFDataBlock structure, and the list is chained through the next
// field of these structs. (the link field of the bdescr is used to chain
// together multiple compact region on the compact_objects field of a
// generation).
//
// See Note [Compact Normal Forms] for details
//
typedef struct StgCompactNFDataBlock_ {
struct StgCompactNFDataBlock_ *self; // the address of this block
// this is copied over to the receiving
// end when serializing a compact, so
// the receiving end can allocate the
// block at best as it can, and then
// verify if pointer adjustment is
// needed or not by comparing self with
// the actual address; the same data
// is sent over as SerializedCompact
// metadata, but having it here
// simplifies the fixup implementation
struct StgCompactNFData_ *owner; // the closure who owns this
// block (used in objectGetCompact)
struct StgCompactNFDataBlock_ *next; // chain of blocks used for
// serialization and freeing
struct StgCompactNFDataBlock_ *self;
// the address of this block this is copied over to the
// receiving end when serializing a compact, so the receiving
// end can allocate the block at best as it can, and then
// verify if pointer adjustment is needed or not by comparing
// self with the actual address; the same data is sent over as
// SerializedCompact metadata, but having it here simplifies
// the fixup implementation.
struct StgCompactNFData_ *owner;
// the closure who owns this block (used in objectGetCompact)
struct StgCompactNFDataBlock_ *next;
// chain of blocks used for serialization and freeing
} StgCompactNFDataBlock;
//
// This is the Compact# primitive object.
//
typedef struct StgCompactNFData_ {
StgHeader header; // for sanity and other checks in practice,
// nothing should ever need the compact info
// pointer (we don't even need fwding
// pointers because it's a large object)
StgWord totalW; // for proper accounting in evac, includes
// slop, and removes the first block in
// larger than megablock allocation
// essentially meaningless, but if we got it
// wrong sanity would complain loudly
StgWord totalDataW; // for stats/profiling only, it's the
// full amount of memory used by this
// compact, including the portions not
// yet used
StgWord autoBlockW; // size of automatically appended blocks
StgCompactNFDataBlock *nursery; // where to (try to) allocate from when
// appending
StgCompactNFDataBlock *last; // the last block of the chain (to know where
// to append new blocks for resize)
StgHeader header;
// for sanity and other checks in practice, nothing should ever
// need the compact info pointer (we don't even need fwding
// pointers because it's a large object)
StgWord totalW;
// Total number of words in all blocks in the compact
StgWord autoBlockW;
// size of automatically appended blocks
StgPtr hp, hpLim;
// the beginning and end of the free area in the nursery block. This is
// just a convenience so that we can avoid multiple indirections through
// the nursery pointer below during compaction.
StgCompactNFDataBlock *nursery;
// where to (try to) allocate from when appending
StgCompactNFDataBlock *last;
// the last block of the chain (to know where to append new
// blocks for resize)
struct hashtable *hash;
// the hash table for the current compaction, or NULL if
// there's no (sharing-preserved) compaction in progress.
StgClosure *result;
// Used temporarily to store the result of compaction. Doesn't need to be
// a GC root.
} StgCompactNFData;
......
......@@ -151,7 +151,8 @@ RTS_ENTRY(stg_END_STM_WATCH_QUEUE);
RTS_ENTRY(stg_END_INVARIANT_CHECK_QUEUE);
RTS_ENTRY(stg_END_STM_CHUNK_LIST);
RTS_ENTRY(stg_NO_TREC);
RTS_ENTRY(stg_COMPACT_NFDATA);
RTS_ENTRY(stg_COMPACT_NFDATA_CLEAN);
RTS_ENTRY(stg_COMPACT_NFDATA_DIRTY);
/* closures */
......@@ -411,6 +412,8 @@ RTS_FUN_DECL(stg_makeStableNamezh);
RTS_FUN_DECL(stg_makeStablePtrzh);
RTS_FUN_DECL(stg_deRefStablePtrzh);
RTS_FUN_DECL(stg_compactAddzh);
RTS_FUN_DECL(stg_compactAddWithSharingzh);
RTS_FUN_DECL(stg_compactNewzh);
RTS_FUN_DECL(stg_compactAppendzh);
RTS_FUN_DECL(stg_compactResizzezh);
......@@ -421,6 +424,7 @@ RTS_FUN_DECL(stg_compactGetFirstBlockzh);
RTS_FUN_DECL(stg_compactGetNextBlockzh);
RTS_FUN_DECL(stg_compactAllocateBlockzh);
RTS_FUN_DECL(stg_compactFixupPointerszh);
RTS_FUN_DECL(stg_compactSizzezh);
RTS_FUN_DECL(stg_forkzh);
RTS_FUN_DECL(stg_forkOnzh);
......
......@@ -49,6 +49,7 @@ module Control.Exception (
BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..),
AllocationLimitExceeded(..),
CompactionFailed(..),
Deadlock(..),
NoMethodError(..),
PatternMatchFail(..),
......
......@@ -32,6 +32,7 @@ module Control.Exception.Base (
BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..),
AllocationLimitExceeded(..),
CompactionFailed(..),
Deadlock(..),
NoMethodError(..),
PatternMatchFail(..),
......
......@@ -24,6 +24,8 @@ module GHC.IO.Exception (
Deadlock(..),
AllocationLimitExceeded(..), allocationLimitExceeded,
AssertionFailed(..),
CompactionFailed(..),
cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,
SomeAsyncException(..),
asyncExceptionToException, asyncExceptionFromException,
......@@ -127,6 +129,35 @@ allocationLimitExceeded = toException AllocationLimitExceeded
-----
-- |Compaction found an object that cannot be compacted. Functions
-- cannot be compacted, nor can mutable objects or pinned objects.
-- See 'Data.Compact.compact'.
--
-- @since 4.10.0.0
data CompactionFailed = CompactionFailed String
-- | @since 4.10.0.0
instance Exception CompactionFailed where
-- | @since 4.10.0.0
instance Show CompactionFailed where
showsPrec _ (CompactionFailed why) =
showString ("compaction failed: " ++ why)
cannotCompactFunction :: SomeException -- for the RTS
cannotCompactFunction =
toException (CompactionFailed "cannot compact functions")
cannotCompactPinned :: SomeException -- for the RTS
cannotCompactPinned =
toException (CompactionFailed "cannot compact pinned objects")
cannotCompactMutable :: SomeException -- for the RTS
cannotCompactMutable =
toException (CompactionFailed "cannot compact mutable objects")
-----
-- |'assert' was applied to 'False'.
newtype AssertionFailed = AssertionFailed String
......
......@@ -2,6 +2,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-name-shadowing #-}
-----------------------------------------------------------------------------
-- |
......@@ -18,72 +19,102 @@
-- holding fully evaluated data in a consecutive block of memory.
--
-- /Since: 1.0.0/
module Data.Compact (
-- * The Compact type
Compact,
-- * Compacting data
compact,
compactWithSharing,
compactAdd,
compactAddWithSharing,
-- * Inspecting a Compact
getCompact,
inCompact,
isCompact,
compactSize,
newCompact,
newCompactNoShare,
appendCompact,
appendCompactNoShare,
-- * Other utilities
compactResize,
) where
-- Write down all GHC.Prim deps explicitly to keep them at minimum
import GHC.Prim (Compact#,
compactNew#,
State#,
RealWorld,
Int#,
)
-- We need to import Word from GHC.Types to see the representation
-- and to able to access the Word# to pass down the primops
import GHC.Types (IO(..), Word(..))
import Control.DeepSeq (NFData, force)
import Data.Compact.Internal(Compact(..),
isCompact,
inCompact,
compactAppendEvaledInternal)
-- |Retrieve the object that was stored in a Compact
import Control.Concurrent
import Control.DeepSeq (NFData)
import GHC.Prim
import GHC.Types
import Data.Compact.Internal as Internal
-- | Retrieve the object that was stored in a 'Compact'
getCompact :: Compact a -> a
getCompact (Compact _ obj) = obj
compactAppendInternal :: NFData a => Compact# -> a -> Int# ->
State# RealWorld -> (# State# RealWorld, Compact a #)
compactAppendInternal buffer root share s =
case force root of
!eval -> compactAppendEvaledInternal buffer eval share s
compactAppendInternalIO :: NFData a => Int# -> Compact b -> a -> IO (Compact a)
compactAppendInternalIO share (Compact buffer _) root =
IO (\s -> compactAppendInternal buffer root share s)
-- |Append a value to a 'Compact', and return a new 'Compact'
-- that shares the same buffer but a different root object.
appendCompact :: NFData a => Compact b -> a -> IO (Compact a)
appendCompact = compactAppendInternalIO 1#
-- |Append a value to a 'Compact'. This function differs from
-- 'appendCompact' in that it will not preserve internal sharing
-- in the passed in value (and it will diverge on cyclic structures).
appendCompactNoShare :: NFData a => Compact b -> a -> IO (Compact a)
appendCompactNoShare = compactAppendInternalIO 0#
compactNewInternal :: NFData a => Int# -> Word -> a -> IO (Compact a)
compactNewInternal share (W# size) root =
IO (\s -> case compactNew# size s of
(# s', buffer #) -> compactAppendInternal buffer root share s' )
-- |Create a new 'Compact', with the provided value as suggested block
-- size (which will be adjusted if unsuitable), and append the given
-- value to it, as if calling 'appendCompact'
newCompact :: NFData a => Word -> a -> IO (Compact a)
newCompact = compactNewInternal 1#
-- |Create a new 'Compact', but append the value using 'appendCompactNoShare'
newCompactNoShare :: NFData a => Word -> a -> IO (Compact a)
newCompactNoShare = compactNewInternal 0#
getCompact (Compact _ obj _) = obj
-- | Compact a value. /O(size of unshared data)/
--
-- If the structure contains any internal sharing, the shared data
-- will be duplicated during the compaction process. Loops if the
-- structure constains cycles.
--
-- The NFData constraint is just to ensure that the object contains no
-- functions, 'compact' does not actually use it. If your object
-- contains any functions, then 'compact' will fail. (and your
-- 'NFData' instance is lying).
--
compact :: NFData a => a -> IO (Compact a)
compact = Internal.compactSized 31268 False
-- | Compact a value, retaining any internal sharing and
-- cycles. /O(size of data)/
--
-- This is typically about 10x slower than 'compact', because it works
-- by maintaining a hash table mapping uncompacted objects to
-- compacted objects.
--
-- The 'NFData' constraint is just to ensure that the object contains no
-- functions, `compact` does not actually use it. If your object
-- contains any functions, then 'compactWithSharing' will fail. (and
-- your 'NFData' instance is lying).
--
compactWithSharing :: NFData a => a -> IO (Compact a)
compactWithSharing = Internal.compactSized 31268 True
-- | Add a value to an existing 'Compact'. Behaves exactly like
-- 'compact' with respect to sharing and the 'NFData' constraint.
compactAdd :: NFData a => Compact b -> a -> IO (Compact a)
compactAdd (Compact compact# _ lock) a = withMVar lock $ \_ -> IO $ \s ->
case compactAdd# compact# a s of { (# s1, pk #) ->
(# s1, Compact compact# pk lock #) }
-- | Add a value to an existing 'Compact'. Behaves exactly like
-- 'compactWithSharing' with respect to sharing and the 'NFData'
-- constraint.
compactAddWithSharing :: NFData a => Compact b -> a -> IO (Compact a)
compactAddWithSharing (Compact compact# _ lock) a =
withMVar lock $ \_ -> IO $ \s ->
case compactAddWithSharing# compact# a s of { (# s1, pk #) ->
(# s1, Compact compact# pk lock #) }
-- | Check if the second argument is inside the 'Compact'
inCompact :: Compact b -> a -> IO Bool
inCompact (Compact buffer _ _) !val =
IO (\s -> case compactContains# buffer val s of
(# s', v #) -> (# s', isTrue# v #) )
-- | Check if the argument is in any 'Compact'
isCompact :: a -> IO Bool
isCompact !val =
IO (\s -> case compactContainsAny# val s of
(# s', v #) -> (# s', isTrue# v #) )
compactSize :: Compact a -> IO Word
compactSize (Compact buffer _ lock) = withMVar lock $ \_ -> IO $ \s0 ->
case compactSize# buffer s0 of (# s1, sz #) -> (# s1, W# sz #)
compactResize :: Compact a -> Word -> IO ()
compactResize (Compact oldBuffer _ lock) (W# new_size) =
withMVar lock $ \_ -> IO $ \s ->
case compactResize# oldBuffer new_size s of
s' -> (# s', () #)
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
......@@ -22,57 +21,82 @@
--
-- /Since: 1.0.0/
module Data.Compact.Internal(
Compact(..),
compactResize,
isCompact,
inCompact,
module Data.Compact.Internal
( Compact(..)
, mkCompact
, compactSized
) where
compactAppendEvaledInternal,
) where
import Control.Concurrent.MVar
import Control.DeepSeq
import GHC.Prim
import GHC.Types
-- Write down all GHC.Prim deps explicitly to keep them at minimum
import GHC.Prim (Compact#,
compactAppend#,
compactResize#,
compactContains#,
compactContainsAny#,
State#,
RealWorld,
Int#,
)
-- We need to import Word from GHC.Types to see the representation
-- and to able to access the Word# to pass down the primops
import GHC.Types (IO(..), Word(..), isTrue#)
-- | A 'Compact' contains fully evaluated, pure, and immutable data. If
-- any object in the compact is alive, then the whole compact is
-- alive. This means that 'Compact's are very cheap to keep around,
-- because the data inside a compact does not need to be traversed by
-- the garbage collector. However, the tradeoff is that the memory
-- that contains a 'Compact' cannot be recovered until the whole 'Compact'
-- is garbage.
data Compact a = Compact Compact# a
-- |Check if the second argument is inside the Compact
inCompact :: Compact b -> a -> IO Bool
inCompact (Compact buffer _) !val =
IO (\s -> case compactContains# buffer val s of
(# s', v #) -> (# s', isTrue# v #) )
-- |Check if the argument is in any Compact
isCompact :: a -> IO Bool
isCompact !val =
IO (\s -> case compactContainsAny# val s of
(# s', v #) -> (# s', isTrue# v #) )
-- | A 'Compact' contains fully evaluated, pure, immutable data.
--
-- 'Compact' serves two purposes:
--
-- * Data stored in a 'Compact' has no garbage collection overhead.
-- The garbage collector considers the whole 'Compact' to be alive
-- if there is a reference to any object within it.
--
-- * A 'Compact' can be serialized, stored, and deserialized again.
-- The serialized data can only be deserialized by the exact binary
-- that created it, but it can be stored indefinitely before
-- deserialization.
--
-- Compacts are self-contained, so compacting data involves copying
-- it; if you have data that lives in two 'Compact's, each will have a
-- separate copy of the data.
--
-- The cost of compaction is similar to the cost of GC for the same
-- data, but it is perfomed only once. However, retainining internal
-- sharing during the compaction process is very costly, so it is
-- optional; there are two ways to create a 'Compact': 'compact' and
-- 'compactWithSharing'.
--
-- Data can be added to an existing 'Compact' with 'compactAdd' or
-- 'compactAddWithSharing'.
--
-- Data in a compact doesn't ever move, so compacting data is also a
-- way to pin arbitrary data structures in memory.
--
-- There are some limitations on what can be compacted:
--
-- * Functions. Compaction only applies to data.
--
-- * Pinned 'ByteArray#' objects cannot be compacted. This is for a
-- good reason: the memory is pinned so that it can be referenced by
-- address (the address might be stored in a C data structure, for
-- example), so we can't make a copy of it to store in the 'Compact'.
--
-- * Mutable objects also cannot be compacted, because subsequent
-- mutation would destroy the property that a compact is
-- self-contained.
--
-- If compaction encounters any of the above, a 'CompactionFailed'
-- exception will be thrown by the compaction operation.
--
data Compact a = Compact Compact# a (MVar ())
-- we can *read* from a Compact without taking a lock, but only
-- one thread can be writing to the compact at any given time.
-- The MVar here is to enforce mutual exclusion among writers.
-- Note: the MVar protects the Compact# only, not the pure value 'a'
compactResize :: Compact a -> Word -> IO ()
compactResize (Compact oldBuffer _) (W# new_size) =
IO (\s -> case compactResize# oldBuffer new_size s of
s' -> (# s', () #) )
mkCompact
:: Compact# -> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
mkCompact compact# a s =
case unIO (newMVar ()) s of { (# s1, lock #) ->
(# s1, Compact compact# a lock #) }
where
unIO (IO a) = a
compactAppendEvaledInternal :: Compact# -> a -> Int# -> State# RealWorld ->
(# State# RealWorld, Compact a #)
compactAppendEvaledInternal buffer root share s =
case compactAppend# buffer root share s of
(# s', adjustedRoot #) -> (# s', Compact buffer adjustedRoot #)
compactSized :: NFData a => Int -> Bool -> a -> IO (Compact a)
compactSized (I# size) share a = IO $ \s0 ->
case compactNew# (int2Word# size) s0 of { (# s1, compact# #) ->
case compactAddPrim compact# a s1 of { (# s2, pk #) ->
mkCompact compact# pk s2 }}
where
compactAddPrim
| share = compactAddWithSharing#
| otherwise = compactAdd#
......@@ -29,30 +29,13 @@ module Data.Compact.Serialized(
importCompactByteStrings,
) where
-- Write down all GHC.Prim deps explicitly to keep them at minimum
import GHC.Prim (Compact#,
compactGetFirstBlock#,
compactGetNextBlock#,
compactAllocateBlock#,
compactFixupPointers#,
touch#,
Addr#,
nullAddr#,
eqAddr#,
addrToAny#,
anyToAddr#,
State#,
RealWorld,
Word#,
)
-- We need to import Word from GHC.Types to see the representation
-- and to able to access the Word# to pass down the primops
import GHC.Types (IO(..), Word(..), isTrue#)
import GHC.Prim
import GHC.Types
import GHC.Word (Word8)
import GHC.Ptr (Ptr(..), plusPtr)
import Control.Concurrent
import qualified Data.ByteString as ByteString
import Data.ByteString.Internal(toForeignPtr)
import Data.IORef(newIORef, readIORef, writeIORef)
......@@ -60,16 +43,16 @@ import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Marshal.Utils(copyBytes)
import Control.DeepSeq(NFData, force)
import Data.Compact.Internal(Compact(..))
import Data.Compact.Internal
-- |A serialized version of the 'Compact' metadata (each block with
-- address and size and the address of the root). This structure is
-- meant to be sent alongside the actual 'Compact' data. It can be
-- sent out of band in advance if the data is to be sent over RDMA
-- (which requires both sender and receiver to have pinned buffers).
data SerializedCompact a = SerializedCompact {
serializedCompactBlockList :: [(Ptr a, Word)],
serializedCompactRoot :: Ptr a
data SerializedCompact a = SerializedCompact
{ serializedCompactBlockList :: [(Ptr a, Word)]
, serializedCompactRoot :: Ptr a
}
addrIsNull :: Addr# -> Bool
......@@ -109,7 +92,7 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
{-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: NFData c => Compact a ->
(SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer root) func = do
withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
rootPtr <- IO (\s -> case anyToAddr# root s of
(# s', rootAddr #) -> (# s', Ptr rootAddr #) )
blockList <- mkBlockList buffer
......@@ -129,7 +112,8 @@ fixupPointers firstBlock rootAddr s =
(# s', buffer, adjustedRoot #) ->
if addrIsNull adjustedRoot then (# s', Nothing #)
else case addrToAny# adjustedRoot of
(# root #) -> (# s', Just $ Compact buffer root #)
(# root #) -> case mkCompact buffer root s' of
(# s'', c #) -> (# s'', Just c #)
-- |Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The
-- provided function will be called with the address and size of each
......@@ -175,11 +159,13 @@ importCompact (SerializedCompact blocks root) filler = do
-- these are obviously strict lets, but ghc complains otherwise
let !((_, W# firstSize):otherBlocks) = blocks
let !(Ptr rootAddr) = root
IO (\s0 -> case compactAllocateBlock# firstSize nullAddr# s0 of
(# s1, firstBlock #) ->
case fillBlock firstBlock firstSize s1 of
s2 -> case go firstBlock otherBlocks s2 of
s3-> fixupPointers firstBlock rootAddr s3 )
IO $ \s0 ->
case compactAllocateBlock# firstSize nullAddr# s0 of {
(# s1, firstBlock #) ->
case fillBlock firstBlock firstSize s1 of { s2 ->
case go firstBlock otherBlocks s2 of { s3 ->
fixupPointers firstBlock rootAddr s3
}}}
where
-- note that the case statements above are strict even though
-- they don't seem to inspect their argument because State#
......
*.stderr
!compact_serialize.stderr
*.stdout
.hpc.*
*.eventlog
*.genscript
......
test('compact_simple', omit_ways(['ghci']), compile_and_run, [''])
test('compact_loop', omit_ways(['ghci']), compile_and_run, [''])
test('compact_append', omit_ways(['ghci']), compile_and_run, [''])
test('compact_autoexpand', omit_ways(['ghci']), compile_and_run, [''])
test('compact_simple_array', omit_ways(['ghci']), compile_and_run, [''])
test('compact_serialize', omit_ways(['ghci']), compile_and_run, [''])
\ No newline at end of file
setTestOpts(extra_ways(['sanity']))
test('compact_simple', normal, compile_and_run, [''])
test('compact_loop', normal, compile_and_run, [''])
test('compact_append', normal, compile_and_run, [''])
test('compact_autoexpand', normal, compile_and_run, [''])