Commit cf989ffe authored by gcampax's avatar gcampax Committed by Simon Marlow

Compact Regions

This brings in initial support for compact regions, as described in the
ICFP 2015 paper "Efficient Communication and Collection with Compact
Normal Forms" (Edward Z. Yang et.al.) and implemented by Giovanni
Campagna.

Some things may change before the 8.2 release, but I (Simon M.) wanted
to get the main patch committed so that we can iterate.

What documentation there is is in the Data.Compact module in the new
compact package.  We'll need to extend and polish the documentation
before the release.

Test Plan:
validate
(new test cases included)

Reviewers: ezyang, simonmar, hvr, bgamari, austin

Subscribers: vikraman, Yuras, RyanGlScott, qnikst, mboes, facundominguez, rrnewton, thomie, erikd

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

GHC Trac Issues: #11493
parent 93acc02f
......@@ -351,7 +351,6 @@ emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)
])
emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
= emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
......@@ -359,6 +358,10 @@ emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
emitPrimOp _ [res] AddrToAnyOp [arg]
= emitAssign (CmmLocal res) arg
-- #define hvalueToAddrzh(r, a) r=(W_)a
emitPrimOp _ [res] AnyToAddrOp [arg]
= emitAssign (CmmLocal res) arg
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- Note: argument may be tagged!
emitPrimOp dflags [res] DataToTagOp [arg]
......
......@@ -1579,7 +1579,8 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey :: Unique
eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey,
compactPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
stableNameTyConKey = mkPreludeTyConUnique 52
......@@ -1608,6 +1609,7 @@ bcoPrimTyConKey = mkPreludeTyConUnique 74
ptrTyConKey = mkPreludeTyConUnique 75
funPtrTyConKey = mkPreludeTyConUnique 76
tVarPrimTyConKey = mkPreludeTyConUnique 77
compactPrimTyConKey = mkPreludeTyConUnique 78
-- Parallel array type constructor
parrTyConKey :: Unique
......
......@@ -59,6 +59,7 @@ module TysPrim(
tVarPrimTyCon, mkTVarPrimTy,
stablePtrPrimTyCon, mkStablePtrPrimTy,
stableNamePrimTyCon, mkStableNamePrimTy,
compactPrimTyCon, compactPrimTy,
bcoPrimTyCon, bcoPrimTy,
weakPrimTyCon, mkWeakPrimTy,
threadIdPrimTyCon, threadIdPrimTy,
......@@ -138,6 +139,7 @@ primTyCons
, realWorldTyCon
, stablePtrPrimTyCon
, stableNamePrimTyCon
, compactPrimTyCon
, statePrimTyCon
, voidPrimTyCon
, proxyPrimTyCon
......@@ -170,7 +172,7 @@ mkBuiltInPrimTc fs unique tycon
BuiltInSyntax
charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
......@@ -201,6 +203,7 @@ mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPr
tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon
stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon
weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
......@@ -890,6 +893,20 @@ stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] Ptr
mkStableNamePrimTy :: Type -> Type
mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
{-
************************************************************************
* *
\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type}
* *
************************************************************************
-}
compactPrimTyCon :: TyCon
compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName PtrRep
compactPrimTy :: Type
compactPrimTy = mkTyConTy compactPrimTyCon
{-
************************************************************************
* *
......
......@@ -2425,6 +2425,92 @@ primop EqStableNameOp "eqStableName#" GenPrimOp
primop StableNameToIntOp "stableNameToInt#" GenPrimOp
StableName# a -> Int#
------------------------------------------------------------------------
section "Compact normal form"
------------------------------------------------------------------------
primtype Compact#
primop CompactNewOp "compactNew#" GenPrimOp
Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)
{ Create a new Compact with the given size (in bytes, not words).
The size is rounded up to a multiple of the allocator block size,
and capped to one mega block. }
with
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
{ Set the new allocation size of the compact. This value (in bytes)
determines the size of each block in the compact chain. }
with
has_side_effects = True
out_of_line = True
primop CompactContainsOp "compactContains#" GenPrimOp
Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
{ Returns 1# if the object is contained in the compact, 0# otherwise. }
with
out_of_line = True
primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, Int# #)
{ Returns 1# if the object is in any compact at all, 0# otherwise. }
with
out_of_line = True
primop CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp
Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
{ Returns the address and the size (in bytes) of the first block of
a compact. }
with
out_of_line = True
primop CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp
Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
{ Given a compact and the address of one its blocks, returns the
next block and its size, or #nullAddr if the argument was the
last block in the compact. }
with
out_of_line = True
primop CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp
Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
{ Attempt to allocate a compact block with the given size (in
bytes) at the given address. The first argument is a hint to
the allocator, allocation might be satisfied at a different
address (which is returned).
The resulting block is not known to the GC until
compactFixupPointers# is called on it, and care must be taken
so that the address does not escape or memory will be leaked.
}
with
has_side_effects = True
out_of_line = True
primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp
Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #)
{ Given the pointer to the first block of a compact, and the
address of the root object in the old address space, fix up
the internal pointers inside the compact to account for
a different position in memory than when it was serialized.
This method must be called exactly once after importing
a serialized compact, and returns the new compact and
the new adjusted root address. }
with
has_side_effects = True
out_of_line = True
------------------------------------------------------------------------
section "Unsafe pointer equality"
-- (#1 Bad Guy: Alistair Reid :)
......@@ -2507,6 +2593,21 @@ primop AddrToAnyOp "addrToAny#" GenPrimOp
with
code_size = 0
primop AnyToAddrOp "anyToAddr#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, Addr# #)
{ Retrive the address of any Haskell value. This is
essentially an {\texttt unsafeCoerce\#}, but if implemented as such
the core lint pass complains and fails to compile.
As a primop, it is opaque to core/stg, and only appears
in cmm (where the copy propagation pass will get rid of it).
Note that "a" must be a value, not a thunk! It's too late
for strictness analysis to enforce this, so you're on your
own to guarantee this. Also note that {\texttt Addr\#} is not a GC
pointer - up to you to guarantee that it does not become
a dangling pointer immediately after you get it.}
with
code_size = 0
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
BCO# -> (# a #)
{ Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of
......
......@@ -465,6 +465,7 @@ PACKAGES_STAGE1 += ghc-boot
PACKAGES_STAGE1 += template-haskell
PACKAGES_STAGE1 += hoopl
PACKAGES_STAGE1 += transformers
PACKAGES_STAGE1 += compact
ifeq "$(HADDOCK_DOCS)" "YES"
PACKAGES_STAGE1 += xhtml
......
......@@ -154,6 +154,10 @@ typedef struct bdescr_ {
#define BF_KNOWN 128
/* Block was swept in the last generation */
#define BF_SWEPT 256
/* Block is part of a Compact */
#define BF_COMPACT 512
/* Maximum flag value (do not define anything higher than this!) */
#define BF_FLAG_MAX (1 << 15)
/* Finding the block descriptor for a given block -------------------------- */
......
......@@ -355,6 +355,10 @@ EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );
EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )
{ return bco->size; }
EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str );
EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str )
{ return str->totalW; }
/*
* TODO: Consider to switch return type from 'uint32_t' to 'StgWord' #8742
*
......@@ -417,6 +421,12 @@ 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);
}
......
......@@ -82,6 +82,7 @@
#define SMALL_MUT_ARR_PTRS_DIRTY 61
#define SMALL_MUT_ARR_PTRS_FROZEN0 62
#define SMALL_MUT_ARR_PTRS_FROZEN 63
#define N_CLOSURE_TYPES 64
#define COMPACT_NFDATA 64
#define N_CLOSURE_TYPES 65
#endif /* RTS_STORAGE_CLOSURETYPES_H */
......@@ -419,4 +419,50 @@ 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
//
// 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
} StgCompactNFDataBlock;
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)
} StgCompactNFData;
#endif /* RTS_STORAGE_CLOSURES_H */
......@@ -94,6 +94,22 @@ typedef struct generation_ {
memcount n_new_large_words; // words of new large objects
// (for doYouWantToGC())
bdescr * compact_objects; // compact objects chain
// the second block in each compact is
// linked from the closure object, while
// the second compact object in the
// chain is linked from bd->link (like
// large objects)
memcount n_compact_blocks; // no. of blocks used by all compacts
bdescr * compact_blocks_in_import; // compact objects being imported
// (not known to the GC because
// potentially invalid, but we
// need to keep track of them
// to avoid assertions in Sanity)
// this is a list shaped like compact_objects
memcount n_compact_blocks_in_import; // no. of blocks used by compacts
// being imported
memcount max_blocks; // max blocks
StgTSO * threads; // threads in this gen
......@@ -130,6 +146,9 @@ typedef struct generation_ {
bdescr * scavenged_large_objects; // live large objs after GC (d-link)
memcount n_scavenged_large_blocks; // size (not count) of above
bdescr * live_compact_objects; // live compact objs after GC (d-link)
memcount n_live_compact_blocks; // size (not count) of above
bdescr * bitmap; // bitmap for compacting collection
StgTSO * old_threads;
......
......@@ -144,6 +144,7 @@ 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);
/* closures */
......@@ -403,6 +404,17 @@ RTS_FUN_DECL(stg_makeStableNamezh);
RTS_FUN_DECL(stg_makeStablePtrzh);
RTS_FUN_DECL(stg_deRefStablePtrzh);
RTS_FUN_DECL(stg_compactNewzh);
RTS_FUN_DECL(stg_compactAppendzh);
RTS_FUN_DECL(stg_compactResizzezh);
RTS_FUN_DECL(stg_compactGetRootzh);
RTS_FUN_DECL(stg_compactContainszh);
RTS_FUN_DECL(stg_compactContainsAnyzh);
RTS_FUN_DECL(stg_compactGetFirstBlockzh);
RTS_FUN_DECL(stg_compactGetNextBlockzh);
RTS_FUN_DECL(stg_compactAllocateBlockzh);
RTS_FUN_DECL(stg_compactFixupPointerszh);
RTS_FUN_DECL(stg_forkzh);
RTS_FUN_DECL(stg_forkOnzh);
RTS_FUN_DECL(stg_yieldzh);
......
GNUmakefile
/dist-install/
/dist/
ghc.mk
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Compact
-- Copyright : (c) The University of Glasgow 2001-2009
-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2014
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : unstable
-- Portability : non-portable (GHC Extensions)
--
-- This module provides a data structure, called a Compact, for
-- holding fully evaluated data in a consecutive block of memory.
--
-- /Since: 1.0.0/
module Data.Compact (
Compact,
getCompact,
inCompact,
isCompact,
newCompact,
newCompactNoShare,
appendCompact,
appendCompactNoShare,
) 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
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#
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Compact.Internal
-- Copyright : (c) The University of Glasgow 2001-2009
-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : unstable
-- Portability : non-portable (GHC Extensions)
--
-- This module provides a data structure, called a Compact, for
-- holding fully evaluated data in a consecutive block of memory.
--
-- This is a private implementation detail of the package and should
-- not be imported directly.
--
-- /Since: 1.0.0/
module Data.Compact.Internal(
Compact(..),
compactResize,
isCompact,
inCompact,
compactAppendEvaledInternal,
) where
-- 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 #) )
compactResize :: Compact a -> Word -> IO ()
compactResize (Compact oldBuffer _) (W# new_size) =
IO (\s -> case compactResize# oldBuffer new_size s of
s' -> (# s', () #) )
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 #)
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Compact.Serialized
-- Copyright : (c) The University of Glasgow 2001-2009
-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : unstable
-- Portability : non-portable (GHC Extensions)
--
-- This module provides a data structure, called a Compact, for
-- holding fully evaluated data in a consecutive block of memory.
--
-- This module contains support for serializing a Compact for network
-- transmission and on-disk storage.
--
-- /Since: 1.0.0/
module Data.Compact.Serialized(
SerializedCompact(..),
withSerializedCompact,
importCompact,
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.Word (Word8)
import GHC.Ptr (Ptr(..), plusPtr)
import qualified Data.ByteString as ByteString
import Data.ByteString.Internal(toForeignPtr)
import Data.IORef(newIORef, readIORef, writeIORef)
import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Marshal.Utils(copyBytes)
import Control.DeepSeq(NFData, force)
import Data.Compact.Internal(Compact(..))
-- |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
}
addrIsNull :: Addr# -> Bool
addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr)
compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
compactGetFirstBlock buffer =
IO (\s -> case compactGetFirstBlock# buffer s of
(# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock buffer block =
IO (\s -> case compactGetNextBlock# buffer block s of
(# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
mkBlockList :: Compact# -> IO [(Ptr a, Word)]
mkBlockList buffer = compactGetFirstBlock buffer >>= go
where
go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
go (Ptr block, _) | addrIsNull block = return []
go item@(Ptr block, _) = do
next <- compactGetNextBlock buffer block
rest <- go next
return $ item : rest
-- We MUST mark withSerializedCompact as NOINLINE
-- Otherwise the compiler will eliminate the call to touch#
-- causing the Compact# to be potentially GCed too eagerly,
-- before func had a chance to copy everything into its own
-- buffers/sockets/whatever
-- |Serialize the 'Compact', and call the provided function with
-- with the 'Compact' serialized representation. The resulting
-- action will be executed synchronously before this function
-- completes.
{-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: NFData c => Compact a ->
(SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer root) func = do
rootPtr <- IO (\s -> case anyToAddr# root s of
(# s', rootAddr #) -> (# s', Ptr rootAddr #) )
blockList <- mkBlockList buffer
let serialized = SerializedCompact blockList rootPtr
-- we must be strict, to avoid smart uses of ByteStrict.Lazy that
-- return a thunk instead of a ByteString (but the thunk references
-- the Ptr, not the Compact#, so it will point to garbage if GC
-- happens)
!r <- fmap force $ func serialized
IO (\s -> case touch# buffer s of
s' -> (# s', r #) )
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
fixupPointers firstBlock rootAddr s =
case compactFixupPointers# firstBlock rootAddr s of
(# s', buffer, adjustedRoot #) ->
if addrIsNull adjustedRoot then (# s', Nothing #)
else case addrToAny# adjustedRoot of
(# root #) -> (# s', Just $ Compact buffer root #)
-- |Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The
-- provided function will be called with the address and size of each
-- newly allocated block in succession, and should fill the memory
-- from the external source (eg. by reading from a socket or from disk)
-- 'importCompact' can return Nothing if the 'Compact' was corrupt
-- or it had pointers that could not be adjusted.
importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) ->
IO (Maybe (Compact a))
-- what we would like is
{-
importCompactPtrs ((firstAddr, firstSize):rest) = do
(firstBlock, compact) <- compactAllocateAt firstAddr firstSize
#nullAddr
fillBlock firstBlock firstAddr firstSize
let go prev [] = return ()
go prev ((addr, size):rest) = do
(block, _) <- compactAllocateAt addr size prev
fillBlock block addr size
go block rest
go firstBlock rest
if isTrue# (compactFixupPointers compact) then
return $ Just compact
else
return Nothing
But we can't do that because IO Addr# is not valid (kind mismatch)
This check exists to prevent a polymorphic data constructor from using
an unlifted type (which would break GC) - it would not a problem for IO