diff options
49 files changed, 2865 insertions, 20 deletions
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 84f263cc3c..d3c09c584e 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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] diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 483006f638..4d5e378f57 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -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 diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 376a0bbe43..19728ee430 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -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 @@ -893,6 +896,20 @@ 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 + +{- +************************************************************************ +* * \subsection[TysPrim-BCOs]{The ``bytecode object'' type} * * ************************************************************************ diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index bfeb7852c6..9fd5d17f14 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2426,6 +2426,92 @@ 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 diff --git a/includes/rts/storage/Block.h b/includes/rts/storage/Block.h index e04cfdfec6..7d6f102ab8 100644 --- a/includes/rts/storage/Block.h +++ b/includes/rts/storage/Block.h @@ -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 -------------------------- */ diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 4ebec0f45f..e485246206 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -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); } diff --git a/includes/rts/storage/ClosureTypes.h b/includes/rts/storage/ClosureTypes.h index 4f66de318b..f5e96e7500 100644 --- a/includes/rts/storage/ClosureTypes.h +++ b/includes/rts/storage/ClosureTypes.h @@ -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 */ diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h index f880b5c876..4dda0a7f3a 100644 --- a/includes/rts/storage/Closures.h +++ b/includes/rts/storage/Closures.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 */ diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index 4aa44bd344..50fc5eb227 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.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; diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 731893efd0..0b8fbdc78a 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -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); diff --git a/libraries/compact/.gitignore b/libraries/compact/.gitignore new file mode 100644 index 0000000000..89cf73d0b3 --- /dev/null +++ b/libraries/compact/.gitignore @@ -0,0 +1,4 @@ +GNUmakefile +/dist-install/ +/dist/ +ghc.mk diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs new file mode 100644 index 0000000000..7cedd1c27a --- /dev/null +++ b/libraries/compact/Data/Compact.hs @@ -0,0 +1,89 @@ +{-# 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# diff --git a/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs new file mode 100644 index 0000000000..36cd438b1e --- /dev/null +++ b/libraries/compact/Data/Compact/Internal.hs @@ -0,0 +1,78 @@ +{-# 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 #) diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs new file mode 100644 index 0000000000..e58f9eef83 --- /dev/null +++ b/libraries/compact/Data/Compact/Serialized.hs @@ -0,0 +1,225 @@ +{-# 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 +because IO stores a function, not a value, but the kind check is there +anyway. +Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor +we can do IO (Addr#, Word#) (that would break the GC for real!) + +And therefore we need to do everything with State# explicitly. +-} + +-- just do shut up GHC +importCompact (SerializedCompact [] _) _ = return Nothing +importCompact (SerializedCompact blocks root) filler = do + -- I'm not sure why we need a bang pattern here, given that + -- 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 ) + where + -- note that the case statements above are strict even though + -- they don't seem to inspect their argument because State# + -- is an unlifted type + fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld + fillBlock addr size s = case filler (Ptr addr) (W# size) of + IO action -> case action s of + (# s', _ #) -> s' + + go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld + go _ [] s = s + go previous ((_, W# size):rest) s = + case compactAllocateBlock# size previous s of + (# s', block #) -> case fillBlock block size s' of + s'' -> go block rest s'' + +sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool +sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl + where + go [] [] = True + go (_:_) [] = False + go [] (_:_) = False + go ((_, size):scs) (bs:bss) = + fromIntegral size == ByteString.length bs && go scs bss + +importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> + IO (Maybe (Compact a)) +importCompactByteStrings serialized stringList = + -- sanity check stringList first - if we throw an exception later we leak + -- memory! + if not (sanityCheckByteStrings serialized stringList) then + return Nothing + else do + state <- newIORef stringList + let filler :: Ptr Word8 -> Word -> IO () + filler to size = do + -- this pattern match will never fail + (next:rest) <- readIORef state + let (fp, off, _) = toForeignPtr next + withForeignPtr fp $ \from -> do + copyBytes to (from `plusPtr` off) (fromIntegral size) + writeIORef state rest + importCompact serialized filler diff --git a/libraries/compact/LICENSE b/libraries/compact/LICENSE new file mode 100644 index 0000000000..06b2599694 --- /dev/null +++ b/libraries/compact/LICENSE @@ -0,0 +1,41 @@ +This library (compact) is derived from code from the GHC project which +is largely (c) The University of Glasgow, and distributable under a +BSD-style license (see below). +Portions of this library were written by Giovanni Campagna +(gcampagn@cs.stanford.edu). They are available under the same license. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2001-2014, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- 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. + +- Neither name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- diff --git a/libraries/compact/README.md b/libraries/compact/README.md new file mode 100644 index 0000000000..0b7d197c88 --- /dev/null +++ b/libraries/compact/README.md @@ -0,0 +1,5 @@ +The `compact` Package +===================== + +Exposes a single data structure, called a Compact, which contains +fully evaluated data closed under pointer reachability. diff --git a/libraries/compact/Setup.hs b/libraries/compact/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/libraries/compact/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/libraries/compact/compact.cabal b/libraries/compact/compact.cabal new file mode 100644 index 0000000000..9d87ccccd3 --- /dev/null +++ b/libraries/compact/compact.cabal @@ -0,0 +1,47 @@ +name: compact +version: 1.0.0.0 +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/compact +synopsis: In memory storage of deeply evaluated data structure +category: Data +description: + This package provides a single data structure, called a Compact, + which holds a single haskell object in fully evaluated form. The + invariant is, no pointers live inside the struct that point outside + it, which ensures efficient garbage collection without ever reading + the structure contents (effectively, it works as a manually managed + "oldest generation" which is never freed until the whole is released). + + Internally, the struct is stored a single contiguous block of memory, + which allows efficient serialization and deserialization of structs + for distributed computing. +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==7.11 + +source-repository head + type: git + location: http://git.haskell.org/ghc.git + subdir: libraries/compact + +library + default-language: Haskell2010 + other-extensions: + MagicHash + BangPatterns + UnboxedTuples + CPP + + build-depends: rts == 1.0.* + build-depends: ghc-prim == 0.5.0.0 + build-depends: base >= 4.9.0 && < 4.10 + build-depends: deepseq >= 1.4 + build-depends: bytestring >= 0.10.6.0 + ghc-options: -Wall + + exposed-modules: Data.Compact + Data.Compact.Internal + Data.Compact.Serialized diff --git a/libraries/compact/tests/.gitignore b/libraries/compact/tests/.gitignore new file mode 100644 index 0000000000..c20cf7d4be --- /dev/null +++ b/libraries/compact/tests/.gitignore @@ -0,0 +1,21 @@ +*.stderr +!compact_serialize.stderr +*.stdout +.hpc.* +*.eventlog +*.genscript +compact_append +compact_simple +compact_nospace +compact_noshare +compact_loop +compact_resize +compact_inc_append +compact_inc_simple +compact_inc_nospace +compact_inc_noshare +compact_autoexpand +compact_inc_custom +compact_inc_incremental +compact_inc_monad +compact_simple_symbols diff --git a/libraries/compact/tests/Makefile b/libraries/compact/tests/Makefile new file mode 100644 index 0000000000..6a0abcf1cf --- /dev/null +++ b/libraries/compact/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/libraries/compact/tests/all.T b/libraries/compact/tests/all.T new file mode 100644 index 0000000000..fd543142e9 --- /dev/null +++ b/libraries/compact/tests/all.T @@ -0,0 +1,6 @@ +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 diff --git a/libraries/compact/tests/compact_append.hs b/libraries/compact/tests/compact_append.hs new file mode 100644 index 0000000000..59f86777b7 --- /dev/null +++ b/libraries/compact/tests/compact_append.hs @@ -0,0 +1,38 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +main = do + let val = ("hello", Just 42) :: (String, Maybe Int) + str <- newCompact 4096 val + + let val2 = ("world", 42) :: (String, Int) + str2 <- appendCompact str val2 + + -- check that values where not corrupted + assertEquals ("hello", Just 42) val + assertEquals ("world", 42) val2 + -- check the values in the compact + assertEquals ("hello", Just 42) (getCompact str) + assertEquals ("world", 42) (getCompact str2) + + performMajorGC + + -- same checks again + assertEquals ("hello", Just 42) val + assertEquals ("world", 42) val2 + -- check the values in the compact + assertEquals ("hello", Just 42) (getCompact str) + assertEquals ("world", 42) (getCompact str2) diff --git a/libraries/compact/tests/compact_autoexpand.hs b/libraries/compact/tests/compact_autoexpand.hs new file mode 100644 index 0000000000..5db0bbc55f --- /dev/null +++ b/libraries/compact/tests/compact_autoexpand.hs @@ -0,0 +1,27 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +main = do + -- create a compact large 4096 bytes (minus the size of header) + -- add a value that is 1024 cons cells, pointing to 7 INTLIKE + -- each cons cell is 1 word header, 1 word data, 1 word next + -- so total 3072 words, 12288 bytes on x86, 24576 on x86_64 + -- it should not fit in one block + let val = replicate 4096 7 :: [Int] + str <- newCompact 1 val + assertEquals val (getCompact str) + performMajorGC + assertEquals val (getCompact str) diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs new file mode 100644 index 0000000000..0111fc1bdb --- /dev/null +++ b/libraries/compact/tests/compact_loop.hs @@ -0,0 +1,47 @@ +module Main where + +import Control.Exception +import Control.DeepSeq +import System.Mem +import Text.Show + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +data Tree = Nil | Node Tree Tree Tree + +instance Eq Tree where + Nil == Nil = True + Node _ l1 r1 == Node _ l2 r2 = l1 == l2 && r1 == r2 + _ == _ = False + +instance Show Tree where + showsPrec _ Nil = showString "Nil" + showsPrec _ (Node _ l r) = showString "(Node " . shows l . + showString " " . shows r . showString ")" + +instance NFData Tree where + rnf Nil = () + rnf (Node p l r) = p `seq` rnf l `seq` rnf r `seq` () + +{-# NOINLINE test #-} +test x = do + let a = Node Nil x b + b = Node a Nil Nil + str <- newCompact 4096 a + + -- check the value in the compact + assertEquals a (getCompact str) + performMajorGC + -- check again the value in the compact + assertEquals a (getCompact str) + +main = test Nil diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs new file mode 100644 index 0000000000..e4ba88ea9e --- /dev/null +++ b/libraries/compact/tests/compact_serialize.hs @@ -0,0 +1,53 @@ +module Main where + +import Control.Exception +import Control.Monad +import System.Mem + +import Data.IORef +import Data.ByteString (ByteString, packCStringLen) +import Foreign.Ptr +import Control.DeepSeq + +import Data.Compact +import Data.Compact.Serialized + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString]) +serialize val = do + cnf <- newCompact 4096 val + + bytestrref <- newIORef undefined + scref <- newIORef undefined + withSerializedCompact cnf $ \sc -> do + writeIORef scref sc + performMajorGC + bytestrs <- forM (serializedCompactBlockList sc) $ \(ptr, size) -> do + packCStringLen (castPtr ptr, fromIntegral size) + writeIORef bytestrref bytestrs + + performMajorGC + + bytestrs <- readIORef bytestrref + sc <- readIORef scref + return (sc, bytestrs) + +main = do + let val = ("hello", 1, 42, 42, Just 42) :: + (String, Int, Int, Integer, Maybe Int) + + (sc, bytestrs) <- serialize val + performMajorGC + + mcnf <- importCompactByteStrings sc bytestrs + case mcnf of + Nothing -> assertFail "import failed" + Just cnf -> assertEquals val (getCompact cnf) diff --git a/libraries/compact/tests/compact_serialize.stderr b/libraries/compact/tests/compact_serialize.stderr new file mode 100644 index 0000000000..2483efa009 --- /dev/null +++ b/libraries/compact/tests/compact_serialize.stderr @@ -0,0 +1 @@ +Compact imported at the wrong address, will fix up internal pointers diff --git a/libraries/compact/tests/compact_simple.hs b/libraries/compact/tests/compact_simple.hs new file mode 100644 index 0000000000..c4cfbbd151 --- /dev/null +++ b/libraries/compact/tests/compact_simple.hs @@ -0,0 +1,35 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () +test func = do + let val = ("hello", 1, 42, 42, Just 42) :: + (String, Int, Int, Integer, Maybe Int) + str <- func 4096 val + + -- check that val is still good + assertEquals ("hello", 1, 42, 42, Just 42) val + -- check the value in the compact + assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str) + performMajorGC + -- check again val + assertEquals ("hello", 1, 42, 42, Just 42) val + -- check again the value in the compact + assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str) + +main = do + test newCompact + test newCompactNoShare diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs new file mode 100644 index 0000000000..7b194867de --- /dev/null +++ b/libraries/compact/tests/compact_simple_array.hs @@ -0,0 +1,60 @@ +module Main where + +import Control.Exception +import Control.Monad +import System.Mem + +import Control.Monad.ST +import Data.Array +import Data.Array.ST +import qualified Data.Array.Unboxed as U +import Control.DeepSeq + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +arrTest :: (Monad m, MArray a e m, Num e) => m (a Int e) +arrTest = do + arr <- newArray (1, 10) 0 + forM_ [1..10] $ \j -> do + writeArray arr j (fromIntegral $ 2*j + 1) + return arr + +instance NFData (U.UArray i e) where + rnf x = seq x () + +-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () +test func = do + let fromList :: Array Int Int + fromList = listArray (1, 10) [1..] + frozen :: Array Int Int + frozen = runST $ do + arr <- arrTest :: ST s (STArray s Int Int) + freeze arr + stFrozen :: Array Int Int + stFrozen = runSTArray arrTest + unboxedFrozen :: U.UArray Int Int + unboxedFrozen = runSTUArray arrTest + + let val = (fromList, frozen, stFrozen, unboxedFrozen) + str <- func 4096 val + + -- check that val is still good + assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val + -- check the value in the compact + assertEquals val (getCompact str) + performMajorGC + -- check again the value in the compact + assertEquals val (getCompact str) + +main = do + test newCompact + test newCompactNoShare diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c index cd2c7e1435..b2359107a5 100644 --- a/rts/ClosureFlags.c +++ b/rts/ClosureFlags.c @@ -84,9 +84,10 @@ StgWord16 closure_flags[] = { [SMALL_MUT_ARR_PTRS_CLEAN] = (_HNF| _NS| _MUT|_UPT ), [SMALL_MUT_ARR_PTRS_DIRTY] = (_HNF| _NS| _MUT|_UPT ), [SMALL_MUT_ARR_PTRS_FROZEN0] = (_HNF| _NS| _MUT|_UPT ), - [SMALL_MUT_ARR_PTRS_FROZEN] = (_HNF| _NS| _UPT ) + [SMALL_MUT_ARR_PTRS_FROZEN] = (_HNF| _NS| _UPT ), + [COMPACT_NFDATA] = (_HNF| _NS ), }; -#if N_CLOSURE_TYPES != 64 +#if N_CLOSURE_TYPES != 65 #error Closure types changed: update ClosureFlags.c! #endif diff --git a/rts/LdvProfile.c b/rts/LdvProfile.c index 428078bb40..26ead95061 100644 --- a/rts/LdvProfile.c +++ b/rts/LdvProfile.c @@ -142,6 +142,7 @@ processHeapClosureForDead( const StgClosure *c ) case RET_BIG: // others case INVALID_OBJECT: + case COMPACT_NFDATA: default: barf("Invalid object in processHeapClosureForDead(): %d", info->type); return 0; diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index b82eebe07f..60d8106983 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1917,6 +1917,137 @@ stg_deRefStablePtrzh ( P_ sp ) } /* ----------------------------------------------------------------------------- + CompactNFData primitives + + See Note [Compact Normal Forms] + ------------------------------------------------------------------------- */ + +stg_compactNewzh ( W_ size ) +{ + P_ str; + + again: MAYBE_GC(again); + + ("ptr" str) = ccall compactNew(MyCapability() "ptr", size); + return (str); +} + +stg_compactAppendzh ( P_ str, P_ val , W_ share) +{ + P_ root; + + again: MAYBE_GC(again); + + ("ptr" root) = ccall compactAppend(MyCapability() "ptr", str "ptr", val "ptr", share); + return (root); +} + +stg_compactResizzezh ( P_ str, W_ new_size ) +{ + again: MAYBE_GC(again); + + ccall compactResize(MyCapability() "ptr", str "ptr", new_size); + return (); +} + +stg_compactContainszh ( P_ str, P_ val ) +{ + W_ rval; + + (rval) = ccall compactContains(str "ptr", val "ptr"); + return (rval); +} + +stg_compactContainsAnyzh ( P_ val ) +{ + W_ rval; + + (rval) = ccall compactContains(0 "ptr", val "ptr"); + return (rval); +} + +stg_compactGetFirstBlockzh ( P_ str ) +{ + /* W_, not P_, because it is not a gc pointer */ + W_ block; + W_ bd; + W_ size; + + block = str - SIZEOF_StgCompactNFDataBlock::W_; + ASSERT (StgCompactNFDataBlock_owner(block) == str); + + bd = Bdescr(str); + size = bdescr_free(bd) - bdescr_start(bd); + ASSERT (size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE); + + return (block, size); +} + +stg_compactGetNextBlockzh ( P_ str, W_ block ) +{ + /* str is a pointer to the closure holding the Compact# + it is there primarily to keep everything reachable from + the GC: by having it on the stack of type P_, the GC will + see all the blocks as live (any pointer in the Compact# + keeps it alive), and will not collect the block + We don't run a GC inside this primop, but it could + happen right after, or we could be preempted. + + str is also useful for debugging, as it can be casted + to a useful C struct from the gdb command line and all + blocks can be inspected + */ + W_ bd; + W_ next_block; + W_ size; + + next_block = StgCompactNFDataBlock_next(block); + + if (next_block == 0::W_) { + return (0::W_, 0::W_); + } + + ASSERT (StgCompactNFDataBlock_owner(next_block) == str || + StgCompactNFDataBlock_owner(next_block) == NULL); + + bd = Bdescr(next_block); + size = bdescr_free(bd) - bdescr_start(bd); + ASSERT (size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE); + + return (next_block, size); +} + +stg_compactAllocateBlockzh ( W_ size, W_ previous ) +{ + W_ actual_block; + + again: MAYBE_GC(again); + + ("ptr" actual_block) = ccall compactAllocateBlock(MyCapability(), + size, + previous "ptr"); + + return (actual_block); +} + +stg_compactFixupPointerszh ( W_ first_block, W_ root ) +{ + W_ str; + P_ gcstr; + W_ ok; + + str = first_block + SIZEOF_StgCompactNFDataBlock::W_; + (ok) = ccall compactFixupPointers (str "ptr", root "ptr"); + + // Now we can let the GC know about str, because it was linked + // into the generation list and the book-keeping pointers are + // guaranteed to be valid + // (this is true even if the fixup phase failed) + gcstr = str; + return (gcstr, ok); +} + +/* ----------------------------------------------------------------------------- Bytecode object primitives ------------------------------------------------------------------------- */ diff --git a/rts/Printer.c b/rts/Printer.c index 1ee1c6c4b3..678922500c 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -386,6 +386,12 @@ printClosure( const StgClosure *obj ) break; #endif + case COMPACT_NFDATA: + debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n", + (W_)((StgCompactNFData *)obj)->totalDataW * sizeof(W_)); + break; + + default: //barf("printClosure %d",get_itbl(obj)->type); debugBelch("*** printClosure: unknown type %d ****\n", @@ -873,7 +879,8 @@ const char *closure_type_names[] = { [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME", [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME", [CATCH_STM_FRAME] = "CATCH_STM_FRAME", - [WHITEHOLE] = "WHITEHOLE" + [WHITEHOLE] = "WHITEHOLE", + [COMPACT_NFDATA] = "COMPACT_NFDATA" }; const char * diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 664ee50d70..956a250747 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -940,6 +940,24 @@ static void heapProfObject(Census *census, StgClosure *p, size_t size, } } +// Compact objects require special handling code because they +// are not stored consecutively in memory (rather, each object +// is a list of objects), and that would break the while loop +// below. But we know that each block holds at most one object +// so we don't need the loop. +// +// See Note [Compact Normal Forms] for details. +static void +heapCensusCompactList(Census *census, bdescr *bd) +{ + for (; bd != NULL; bd = bd->link) { + StgCompactNFDataBlock *block = (StgCompactNFDataBlock*)bd->start; + StgCompactNFData *str = block->owner; + heapProfObject(census, (StgClosure*)str, + compact_nfdata_full_sizeW(str), rtsTrue); + } +} + /* ----------------------------------------------------------------------------- * Code to perform a heap census. * -------------------------------------------------------------------------- */ @@ -1116,6 +1134,10 @@ heapCensusChain( Census *census, bdescr *bd ) size = sizeofW(StgTRecChunk); break; + case COMPACT_NFDATA: + barf("heapCensus, found compact object in the wrong list"); + break; + default: barf("heapCensus, unknown object: %d", info->type); } @@ -1153,6 +1175,7 @@ void heapCensus (Time t) // Are we interested in large objects? might be // confusing to include the stack in a heap profile. heapCensusChain( census, generations[g].large_objects ); + heapCensusCompactList ( census, generations[g].compact_objects ); for (n = 0; n < n_capabilities; n++) { ws = &gc_threads[n]->gens[g]; diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 3fe0f8bf9a..6cd9c89b83 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -451,6 +451,7 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child ) case CONSTR_0_1: case CONSTR_0_2: case ARR_WORDS: + case COMPACT_NFDATA: *first_child = NULL; return; diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 0aa3b28b2e..123fb9b64a 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -35,6 +35,7 @@ #include "FileLock.h" #include "LinkerInternals.h" #include "LibdwPool.h" +#include "sm/CNF.h" #if defined(PROFILING) # include "ProfHeap.h" diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index e66b4d81cb..ed9bdfb808 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -422,6 +422,15 @@ SymI_HasProto(stg_catchSTMzh) \ SymI_HasProto(stg_checkzh) \ SymI_HasProto(stg_clearCCSzh) \ + SymI_HasProto(stg_compactNewzh) \ + SymI_HasProto(stg_compactAppendzh) \ + SymI_HasProto(stg_compactResizzezh) \ + SymI_HasProto(stg_compactContainszh) \ + SymI_HasProto(stg_compactContainsAnyzh) \ + SymI_HasProto(stg_compactGetFirstBlockzh) \ + SymI_HasProto(stg_compactGetNextBlockzh) \ + SymI_HasProto(stg_compactAllocateBlockzh) \ + SymI_HasProto(stg_compactFixupPointerszh) \ SymI_HasProto(closure_flags) \ SymI_HasProto(cmp_thread) \ SymI_HasProto(createAdjustor) \ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 905f81ec2e..6c1edf70b5 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -614,6 +614,18 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE { foreign "C" barf("MVAR_TSO_QUEUE object entered!") never returns; } /* ---------------------------------------------------------------------------- + COMPACT_NFDATA (a blob of data in NF with no outgoing pointers) + + Just return immediately because the structure is in NF already + ------------------------------------------------------------------------- */ + +INFO_TABLE( stg_COMPACT_NFDATA, 0, 0, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") + () +{ + return (); +} + +/* ---------------------------------------------------------------------------- CHARLIKE and INTLIKE closures. These are static representations of Chars and small Ints, so that diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index 6c2e96414e..c729c1874f 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -795,6 +795,7 @@ countAllocdBlocks(bdescr *bd) W_ n; for (n=0; bd != NULL; bd=bd->link) { n += bd->blocks; + // hack for megablock groups: see (*1) above if (bd->blocks > BLOCKS_PER_MBLOCK) { n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK) diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c new file mode 100644 index 0000000000..3c681c2ee2 --- /dev/null +++ b/rts/sm/CNF.c @@ -0,0 +1,1352 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 1998-2014 + * + * GC support for immutable non-GCed structures, also known as Compact + * Normal Forms (CNF for short). This provides the RTS support for + * the 'compact' package and the Data.Compact module. + * + * ---------------------------------------------------------------------------*/ + +#define _GNU_SOURCE + +#include "PosixSource.h" +#include <string.h> +#include "Rts.h" +#include "RtsUtils.h" + +#include "Capability.h" +#include "GC.h" +#include "Storage.h" +#include "CNF.h" +#include "Hash.h" +#include "HeapAlloc.h" +#include "BlockAlloc.h" + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#ifdef HAVE_LIMITS_H +#include <limits.h> +#endif +#include <dlfcn.h> +#include <endian.h> + +/** + * Note [Compact Normal Forms] + * + * A Compact Normal Form, is at its essence a chain of memory blocks (multiple + * of block allocator blocks) containing other closures inside. + * + * Each block starts with a header, of type StgCompactNFDataBlock, that points + * to the first and to the next block in the chain. Right after the header + * in the first block we have a closure of type StgCompactNFData, which holds + * compact-wide metadata. This closure is the Compact# that Cmm and Haskell + * see, and it's mostly a regular Haskell closure. + * + * Blocks are appended to the chain automatically as needed, or manually with a + * compactResize() call, which also adjust the size of automatically appended + * blocks. + * + * Objects can be appended to the block currently marked to the nursery, or any + * of the later blocks if the nursery block is too full to fit the entire + * object. For each block in the chain (which can be multiple block allocator + * blocks), we use the bdescr of its beginning to store how full it is. + * After an object is appended, it is scavenged for any outgoing pointers, + * and all pointed to objects are appended, recursively, in a manner similar + * to copying GC (further discussion in the note [Appending to a Compact]) + * + * We also flag each bdescr in each block allocator block of a compact + * (including those there were obtained as second or later from a single + * allocGroup(n) call) with the BF_COMPACT. This allows the GC to quickly + * realize that a given pointer is in a compact region, and trigger the + * CNF path. + * + * These two facts combined mean that in any compact block where some object + * begins bdescrs must be valid. For this simplicity this is achieved by + * restricting the maximum size of a compact block to 252 block allocator + * blocks (so that the total with the bdescr is one megablock). + * + * Compacts as a whole live in special list in each generation, where the + * list is held through the bd->link field of the bdescr of the StgCompactNFData + * closure (as for large objects). They live in a different list than large + * objects because the operation to free them is different (all blocks in + * a compact must be freed individually), and stats/sanity behavior are + * slightly different. This is also the reason that compact allocates memory + * using a special function instead of just calling allocate(). + * + * Compacts are also suitable for network or disk serialization, and to + * that extent they support a pointer fixup operation, which adjusts pointers + * from a previous layout of the chain in memory to the new allocation. + * This works by constructing a temporary binary search table (in the C heap) + * of the old block addresses (which are known from the block header), and + * then searching for each pointer in the table, and adjusting it. + * It relies on ABI compatibility and static linking (or no ASLR) because it + * does not attempt to reconstruct info tables, and uses info tables to detect + * pointers. In practice this means only the exact same binary should be + * used. + */ + +typedef enum { + ALLOCATE_APPEND, + ALLOCATE_NEW, + ALLOCATE_IMPORT_NEW, + ALLOCATE_IMPORT_APPEND, +} AllocateOp; + +static StgCompactNFDataBlock * +compactAllocateBlockInternal(Capability *cap, + StgWord aligned_size, + StgCompactNFDataBlock *first, + AllocateOp operation) +{ + StgCompactNFDataBlock *self; + bdescr *block, *head; + uint32_t n_blocks; + generation *g; + + n_blocks = aligned_size / BLOCK_SIZE; + + // Attempting to allocate an object larger than maxHeapSize + // should definitely be disallowed. (bug #1791) + if ((RtsFlags.GcFlags.maxHeapSize > 0 && + n_blocks >= RtsFlags.GcFlags.maxHeapSize) || + n_blocks >= HS_INT32_MAX) // avoid overflow when + // calling allocGroup() below + { + heapOverflow(); + // heapOverflow() doesn't exit (see #2592), but we aren't + // in a position to do a clean shutdown here: we + // either have to allocate the memory or exit now. + // Allocating the memory would be bad, because the user + // has requested that we not exceed maxHeapSize, so we + // just exit. + stg_exit(EXIT_HEAPOVERFLOW); + } + + // It is imperative that first is the first block in the compact + // (or NULL if the compact does not exist yet) + // because the evacuate code does not update the generation of + // blocks other than the first (so we would get the statistics + // wrong and crash in Sanity) + if (first != NULL) { + block = Bdescr((P_)first); + g = block->gen; + } else { + g = g0; + } + + ACQUIRE_SM_LOCK; + block = allocGroup(n_blocks); + switch (operation) { + case ALLOCATE_NEW: + ASSERT (first == NULL); + ASSERT (g == g0); + dbl_link_onto(block, &g0->compact_objects); + g->n_compact_blocks += block->blocks; + g->n_new_large_words += aligned_size / sizeof(StgWord); + break; + + case ALLOCATE_IMPORT_NEW: + dbl_link_onto(block, &g0->compact_blocks_in_import); + /* fallthrough */ + case ALLOCATE_IMPORT_APPEND: + ASSERT (first == NULL); + ASSERT (g == g0); + g->n_compact_blocks_in_import += block->blocks; + g->n_new_large_words += aligned_size / sizeof(StgWord); + break; + + case ALLOCATE_APPEND: + g->n_compact_blocks += block->blocks; + if (g == g0) + g->n_new_large_words += aligned_size / sizeof(StgWord); + break; + + default: +#ifdef DEBUG + ASSERT(!"code should not be reached"); +#else + __builtin_unreachable(); +#endif + } + RELEASE_SM_LOCK; + + cap->total_allocated += aligned_size / sizeof(StgWord); + + self = (StgCompactNFDataBlock*) block->start; + self->self = self; + self->next = NULL; + + head = block; + initBdescr(head, g, g); + head->flags = BF_COMPACT; + for (block = head + 1, n_blocks --; n_blocks > 0; block++, n_blocks--) { + block->link = head; + block->blocks = 0; + block->flags = BF_COMPACT; + } + + return self; +} + +static inline StgCompactNFDataBlock * +compactGetFirstBlock(StgCompactNFData *str) +{ + return (StgCompactNFDataBlock*) ((W_)str - sizeof(StgCompactNFDataBlock)); +} + +static inline StgCompactNFData * +firstBlockGetCompact(StgCompactNFDataBlock *block) +{ + return (StgCompactNFData*) ((W_)block + sizeof(StgCompactNFDataBlock)); +} + +static void +freeBlockChain(StgCompactNFDataBlock *block) +{ + StgCompactNFDataBlock *next; + bdescr *bd; + + for ( ; block; block = next) { + next = block->next; + bd = Bdescr((StgPtr)block); + ASSERT((bd->flags & BF_EVACUATED) == 0); + freeGroup(bd); + } +} + +void +compactFree(StgCompactNFData *str) +{ + StgCompactNFDataBlock *block; + + block = compactGetFirstBlock(str); + freeBlockChain(block); +} + +void +compactMarkKnown(StgCompactNFData *str) +{ + bdescr *bd; + StgCompactNFDataBlock *block; + + block = compactGetFirstBlock(str); + for ( ; block; block = block->next) { + bd = Bdescr((StgPtr)block); + bd->flags |= BF_KNOWN; + } +} + +StgWord +countCompactBlocks(bdescr *outer) +{ + StgCompactNFDataBlock *block; + W_ count; + + count = 0; + while (outer) { + bdescr *inner; + + block = (StgCompactNFDataBlock*)(outer->start); + do { + inner = Bdescr((P_)block); + ASSERT (inner->flags & BF_COMPACT); + + count += inner->blocks; + block = block->next; + } while(block); + + outer = outer->link; + } + + return count; +} + +StgCompactNFData * +compactNew (Capability *cap, StgWord size) +{ + StgWord aligned_size; + StgCompactNFDataBlock *block; + StgCompactNFData *self; + bdescr *bd; + + aligned_size = BLOCK_ROUND_UP(size + sizeof(StgCompactNFDataBlock) + + sizeof(StgCompactNFDataBlock)); + if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK) + aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK; + + block = compactAllocateBlockInternal(cap, aligned_size, NULL, + ALLOCATE_NEW); + + self = firstBlockGetCompact(block); + SET_INFO((StgClosure*)self, &stg_COMPACT_NFDATA_info); + self->totalDataW = aligned_size / sizeof(StgWord); + self->autoBlockW = aligned_size / sizeof(StgWord); + self->nursery = block; + self->last = block; + + block->owner = self; + + bd = Bdescr((P_)block); + bd->free = (StgPtr)((W_)self + sizeof(StgCompactNFData)); + ASSERT (bd->free == (StgPtr)self + sizeofW(StgCompactNFData)); + + self->totalW = bd->blocks * BLOCK_SIZE_W; + + return self; +} + +static StgCompactNFDataBlock * +compactAppendBlock (Capability *cap, + StgCompactNFData *str, + StgWord aligned_size) +{ + StgCompactNFDataBlock *block; + bdescr *bd; + + block = compactAllocateBlockInternal(cap, aligned_size, + compactGetFirstBlock(str), + ALLOCATE_APPEND); + block->owner = str; + block->next = NULL; + + ASSERT (str->last->next == NULL); + str->last->next = block; + str->last = block; + if (str->nursery == NULL) + str->nursery = block; + str->totalDataW += aligned_size / sizeof(StgWord); + + bd = Bdescr((P_)block); + bd->free = (StgPtr)((W_)block + sizeof(StgCompactNFDataBlock)); + ASSERT (bd->free == (StgPtr)block + sizeofW(StgCompactNFDataBlock)); + + str->totalW += bd->blocks * BLOCK_SIZE_W; + + return block; +} + +void +compactResize (Capability *cap, StgCompactNFData *str, StgWord new_size) +{ + StgWord aligned_size; + + aligned_size = BLOCK_ROUND_UP(new_size + sizeof(StgCompactNFDataBlock)); + if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK) + aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK; + + str->autoBlockW = aligned_size / sizeof(StgWord); + + compactAppendBlock(cap, str, aligned_size); +} + +/* Note [Appending to a Compact] + + This is a simple reimplementation of the copying GC. + One could be tempted to reuse the actual GC code here, but he + would quickly find out that it would bring all the generational + GC complexity for no need at all. + + Plus, we don't need to scavenge/evacuate all kinds of weird + objects here, just constructors and primitives. Thunks are + expected to be evaluated before appending by the API layer + (in Haskell, above the primop which is implemented here). + Also, we have a different policy for large objects: instead + of relinking to the new large object list, we fully copy + them inside the compact and scavenge them normally. + + Note that if we allowed thunks and lazy evaluation the compact + would be a mutable object, which would create all sorts of + GC problems (besides, evaluating a thunk could exaust the + compact space or yield an invalid object, and we would have + no way to signal that to the user) + + Just like the real evacuate/scavenge pairs, we need to handle + object loops. We would want to use the same strategy of rewriting objects + with forwarding pointer, but in a real GC, at the end the + blocks from the old space are dropped (dropping all forwarding + pointers at the same time), which we can't do here as we don't + know all pointers to the objects being evacuated. Also, in parallel + we don't know which other threads are evaluating the thunks + that we just corrupted at the same time. + + So instead we use a hash table of "visited" objects, and add + the pointer as we copy it. To reduce the overhead, we also offer + a version of the API that does not preserve sharing (TODO). + + You might be tempted to replace the objects with StdInd to + the object in the compact, but you would be wrong: the haskell + code assumes that objects in the heap only become more evaluated + (thunks to blackholes to inds to actual objects), and in + particular it assumes that if a pointer is tagged the object + is directly referenced and the values can be read directly, + without entering the closure. + + FIXME: any better idea than the hash table? +*/ + +static void +unroll_memcpy(StgPtr to, StgPtr from, StgWord size) +{ + for (; size > 0; size--) + *(to++) = *(from++); +} + +static rtsBool +allocate_in_compact (StgCompactNFDataBlock *block, StgWord sizeW, StgPtr *at) +{ + bdescr *bd; + StgPtr top; + StgPtr free; + + bd = Bdescr((StgPtr)block); + top = bd->start + BLOCK_SIZE_W * bd->blocks; + if (bd->free + sizeW > top) + return rtsFalse; + + free = bd->free; + bd->free += sizeW; + *at = free; + + return rtsTrue; +} + +static rtsBool +block_is_full (StgCompactNFDataBlock *block) +{ + bdescr *bd; + StgPtr top; + StgWord sizeW; + + bd = Bdescr((StgPtr)block); + top = bd->start + BLOCK_SIZE_W * bd->blocks; + + // We consider a block full if we could not fit + // an entire closure with 7 payload items + // (this leaves a slop of 64 bytes at most, but + // it avoids leaving a block almost empty to fit + // a large byte array, while at the same time + // it avoids trying to allocate a large closure + // in a chain of almost empty blocks) + sizeW = sizeofW(StgHeader) + 7; + return (bd->free + sizeW > top); +} + +static inline StgWord max(StgWord a, StgWord b) +{ + if (a > b) + return a; + else + return b; +} + +static rtsBool +allocate_loop (Capability *cap, + StgCompactNFData *str, + StgWord sizeW, + StgPtr *at) +{ + StgCompactNFDataBlock *block; + StgWord next_size; + + // try the nursery first + retry: + if (str->nursery != NULL) { + if (allocate_in_compact(str->nursery, sizeW, at)) + return rtsTrue; + + if (block_is_full (str->nursery)) { + str->nursery = str->nursery->next; + goto retry; + } + + // try subsequent blocks + block = str->nursery->next; + while (block != NULL) { + if (allocate_in_compact(block, sizeW, at)) + return rtsTrue; + + block = block->next; + } + } + + next_size = max(str->autoBlockW * sizeof(StgWord), + BLOCK_ROUND_UP(sizeW * sizeof(StgWord))); + if (next_size >= BLOCKS_PER_MBLOCK * BLOCK_SIZE) + next_size = BLOCKS_PER_MBLOCK * BLOCK_SIZE; + if (next_size < sizeW * sizeof(StgWord) + sizeof(StgCompactNFDataBlock)) + return rtsFalse; + + block = compactAppendBlock(cap, str, next_size); + ASSERT (str->nursery != NULL); + return allocate_in_compact(block, sizeW, at); +} + +static void +copy_tag (Capability *cap, + StgCompactNFData *str, + HashTable *hash, + StgClosure **p, + StgClosure *from, + StgWord tag) +{ + StgPtr to; + StgWord sizeW; + + sizeW = closure_sizeW(from); + + if (!allocate_loop(cap, str, sizeW, &to)) { + barf("Failed to copy object in compact, object too large\n"); + return; + } + + // unroll memcpy for small sizes because we can + // benefit of known alignment + // (32 extracted from my magic hat) + if (sizeW < 32) + unroll_memcpy(to, (StgPtr)from, sizeW); + else + memcpy(to, from, sizeW * sizeof(StgWord)); + + if (hash != NULL) + insertHashTable(hash, (StgWord)from, to); + + *p = TAG_CLOSURE(tag, (StgClosure*)to); +} + +STATIC_INLINE rtsBool +object_in_compact (StgCompactNFData *str, StgClosure *p) +{ + bdescr *bd; + + if (!HEAP_ALLOCED(p)) + return rtsFalse; + + bd = Bdescr((P_)p); + return (bd->flags & BF_COMPACT) != 0 && + objectGetCompact(p) == str; +} + +static void +simple_evacuate (Capability *cap, + StgCompactNFData *str, + HashTable *hash, + StgClosure **p) +{ + StgWord tag; + StgClosure *from; + void *already; + + from = *p; + tag = GET_CLOSURE_TAG(from); + from = UNTAG_CLOSURE(from); + + // If the object referenced is already in this compact + // (for example by reappending an object that was obtained + // by compactGetRoot) then do nothing + if (object_in_compact(str, from)) + return; + + switch (get_itbl(from)->type) { + case BLACKHOLE: + // If tag == 0, the indirectee is the TSO that claimed the tag + // + // Not useful and not NFData + from = ((StgInd*)from)->indirectee; + if (GET_CLOSURE_TAG(from) == 0) { + debugBelch("Claimed but not updated BLACKHOLE in Compact," + " not normal form"); + return; + } + + *p = from; + return simple_evacuate(cap, str, hash, p); + + case IND: + case IND_STATIC: + // follow chains of indirections, don't evacuate them + from = ((StgInd*)from)->indirectee; + *p = from; + // Evac.c uses a goto, but let's rely on a smart compiler + // and get readable code instead + return simple_evacuate(cap, str, hash, p); + + default: + // This object was evacuated already, return the existing + // pointer + if (hash != NULL && + (already = lookupHashTable (hash, (StgWord)from))) { + *p = TAG_CLOSURE(tag, (StgClosure*)already); + return; + } + + copy_tag(cap, str, hash, p, from, tag); + } +} + +static void +simple_scavenge_mut_arr_ptrs (Capability *cap, + StgCompactNFData *str, + HashTable *hash, + StgMutArrPtrs *a) +{ + StgPtr p, q; + + p = (StgPtr)&a->payload[0]; + q = (StgPtr)&a->payload[a->ptrs]; + for (; p < q; p++) { + simple_evacuate(cap, str, hash, (StgClosure**)p); + } +} + +static void +simple_scavenge_block (Capability *cap, + StgCompactNFData *str, + StgCompactNFDataBlock *block, + HashTable *hash, + StgPtr p) +{ + const StgInfoTable *info; + bdescr *bd = Bdescr((P_)block); + + while (p < bd->free) { + ASSERT (LOOKS_LIKE_CLOSURE_PTR(p)); + info = get_itbl((StgClosure*)p); + + switch (info->type) { + case CONSTR_1_0: + simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[0]); + case CONSTR_0_1: + p += sizeofW(StgClosure) + 1; + break; + + case CONSTR_2_0: + simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[1]); + case CONSTR_1_1: + simple_evacuate(cap, str, hash, &((StgClosure*)p)->payload[0]); + case CONSTR_0_2: + p += sizeofW(StgClosure) + 2; + break; + + case CONSTR: + case PRIM: + case CONSTR_NOCAF_STATIC: + case CONSTR_STATIC: + { + StgPtr end; + + end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs; + for (p = (P_)((StgClosure *)p)->payload; p < end; p++) { + simple_evacuate(cap, str, hash, (StgClosure **)p); + } + p += info->layout.payload.nptrs; + break; + } + + case ARR_WORDS: + p += arr_words_sizeW((StgArrBytes*)p); + break; + + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + simple_scavenge_mut_arr_ptrs(cap, str, hash, (StgMutArrPtrs*)p); + p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); + break; + + case SMALL_MUT_ARR_PTRS_FROZEN: + case SMALL_MUT_ARR_PTRS_FROZEN0: + { + uint32_t i; + StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p; + + for (i = 0; i < arr->ptrs; i++) + simple_evacuate(cap, str, hash, &arr->payload[i]); + + p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs; + break; + } + + case IND: + case BLACKHOLE: + case IND_STATIC: + // They get shortcircuited by simple_evaluate() + barf("IND/BLACKHOLE in Compact"); + break; + + default: + barf("Invalid non-NFData closure in Compact\n"); + } + } +} + +static void +scavenge_loop (Capability *cap, + StgCompactNFData *str, + StgCompactNFDataBlock *first_block, + HashTable *hash, + StgPtr p) +{ + // Scavenge the first block + simple_scavenge_block(cap, str, first_block, hash, p); + + // Note: simple_scavenge_block can change str->last, which + // changes this check, in addition to iterating through + while (first_block != str->last) { + // we can't allocate in blocks that were already scavenged + // so push the nursery forward + if (str->nursery == first_block) + str->nursery = str->nursery->next; + + first_block = first_block->next; + simple_scavenge_block(cap, str, first_block, hash, + (P_)first_block + sizeofW(StgCompactNFDataBlock)); + } +} + +#ifdef DEBUG +static rtsBool +objectIsWHNFData (StgClosure *what) +{ + switch (get_itbl(what)->type) { + case CONSTR: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_2_0: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + case ARR_WORDS: + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + case SMALL_MUT_ARR_PTRS_FROZEN: + case SMALL_MUT_ARR_PTRS_FROZEN0: + return rtsTrue; + + case IND: + case BLACKHOLE: + return objectIsWHNFData(UNTAG_CLOSURE(((StgInd*)what)->indirectee)); + + default: + return rtsFalse; + } +} + +static rtsBool +verify_mut_arr_ptrs (StgCompactNFData *str, + StgMutArrPtrs *a) +{ + StgPtr p, q; + + p = (StgPtr)&a->payload[0]; + q = (StgPtr)&a->payload[a->ptrs]; + for (; p < q; p++) { + if (!object_in_compact(str, UNTAG_CLOSURE(*(StgClosure**)p))) + return rtsFalse; + } + + return rtsTrue; +} + +static rtsBool +verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) +{ + bdescr *bd; + StgPtr p; + const StgInfoTable *info; + StgClosure *q; + + p = (P_)firstBlockGetCompact(block); + bd = Bdescr((P_)block); + while (p < bd->free) { + q = (StgClosure*)p; + + if (!LOOKS_LIKE_CLOSURE_PTR(q)) + return rtsFalse; + + info = get_itbl(q); + switch (info->type) { + case CONSTR_1_0: + if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0]))) + return rtsFalse; + case CONSTR_0_1: + p += sizeofW(StgClosure) + 1; + break; + + case CONSTR_2_0: + if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[1]))) + return rtsFalse; + case CONSTR_1_1: + if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0]))) + return rtsFalse; + case CONSTR_0_2: + p += sizeofW(StgClosure) + 2; + break; + + case CONSTR: + case PRIM: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + { + uint32_t i; + + for (i = 0; i < info->layout.payload.ptrs; i++) + if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[i]))) + return rtsFalse; + + p += sizeofW(StgClosure) + info->layout.payload.ptrs + + info->layout.payload.nptrs; + break; + } + + case ARR_WORDS: + p += arr_words_sizeW((StgArrBytes*)p); + break; + + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + if (!verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p)) + return rtsFalse; + p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); + break; + + case SMALL_MUT_ARR_PTRS_FROZEN: + case SMALL_MUT_ARR_PTRS_FROZEN0: + { + uint32_t i; + StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p; + + for (i = 0; i < arr->ptrs; i++) + if (!object_in_compact(str, UNTAG_CLOSURE(arr->payload[i]))) + return rtsFalse; + + p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs; + break; + } + + case COMPACT_NFDATA: + p += sizeofW(StgCompactNFData); + break; + + default: + return rtsFalse; + } + } + + return rtsTrue; +} + +static rtsBool +verify_consistency_loop (StgCompactNFData *str) +{ + StgCompactNFDataBlock *block; + + block = compactGetFirstBlock(str); + do { + if (!verify_consistency_block(str, block)) + return rtsFalse; + block = block->next; + } while (block && block->owner); + + return rtsTrue; +} +#endif + + +StgPtr +compactAppend (Capability *cap, + StgCompactNFData *str, + StgClosure *what, + StgWord share) +{ + StgClosure *root; + StgClosure *tagged_root; + HashTable *hash; + StgCompactNFDataBlock *evaced_block; + + ASSERT(objectIsWHNFData(UNTAG_CLOSURE(what))); + + tagged_root = what; + simple_evacuate(cap, str, NULL, &tagged_root); + + root = UNTAG_CLOSURE(tagged_root); + evaced_block = objectGetCompactBlock(root); + + if (share) { + hash = allocHashTable (); + insertHashTable(hash, (StgWord)UNTAG_CLOSURE(what), root); + } else + hash = NULL; + + scavenge_loop(cap, str, evaced_block, hash, (P_)root); + + if (share) + freeHashTable(hash, NULL); + + ASSERT(verify_consistency_loop(str)); + + return (StgPtr)tagged_root; +} + +StgWord +compactContains (StgCompactNFData *str, StgPtr what) +{ + bdescr *bd; + + // This check is the reason why this needs to be + // implemented in C instead of (possibly faster) Cmm + if (!HEAP_ALLOCED (what)) + return 0; + + // Note that we don't care about tags, they are eaten + // away by the Bdescr operation anyway + bd = Bdescr((P_)what); + return (bd->flags & BF_COMPACT) != 0 && + (str == NULL || objectGetCompact((StgClosure*)what) == str); +} + +StgCompactNFDataBlock * +compactAllocateBlock(Capability *cap, + StgWord size, + StgCompactNFDataBlock *previous) +{ + StgWord aligned_size; + StgCompactNFDataBlock *block; + bdescr *bd; + + aligned_size = BLOCK_ROUND_UP(size); + + // We do not link the new object into the generation ever + // - we cannot let the GC know about this object until we're done + // importing it and we have fixed up all info tables and stuff + // + // but we do update n_compact_blocks, otherwise memInventory() + // in Sanity will think we have a memory leak, because it compares + // the blocks he knows about with the blocks obtained by the + // block allocator + // (if by chance a memory leak does happen due to a bug somewhere + // else, memInventory will also report that all compact blocks + // associated with this compact are leaked - but they are not really, + // we have a pointer to them and we're not losing track of it, it's + // just we can't use the GC until we're done with the import) + // + // (That btw means that the high level import code must be careful + // not to lose the pointer, so don't use the primops directly + // unless you know what you're doing!) + + // Other trickery: we pass NULL as first, which means our blocks + // are always in generation 0 + // This is correct because the GC has never seen the blocks so + // it had no chance of promoting them + + block = compactAllocateBlockInternal(cap, aligned_size, NULL, + previous != NULL ? ALLOCATE_IMPORT_APPEND : ALLOCATE_IMPORT_NEW); + if (previous != NULL) + previous->next = block; + + bd = Bdescr((P_)block); + bd->free = (P_)((W_)bd->start + size); + + return block; +} + +STATIC_INLINE rtsBool +any_needs_fixup(StgCompactNFDataBlock *block) +{ + // ->next pointers are always valid, even if some blocks were + // not allocated where we want them, because compactAllocateAt() + // will take care to adjust them + + do { + if (block->self != block) + return rtsTrue; + block = block->next; + } while (block && block->owner); + + return rtsFalse; +} + +#ifdef DEBUG +static void +spew_failing_pointer(StgWord *fixup_table, uint32_t count, StgWord address) +{ + uint32_t i; + StgWord key, value; + StgCompactNFDataBlock *block; + bdescr *bd; + StgWord size; + + debugBelch("Failed to adjust 0x%lx. Block dump follows...\n", + address); + + for (i = 0; i < count; i++) { + key = fixup_table [2 * i]; + value = fixup_table [2 * i + 1]; + + block = (StgCompactNFDataBlock*)value; + bd = Bdescr((P_)block); + size = (W_)bd->free - (W_)bd->start; + + debugBelch("%d: was 0x%lx-0x%lx, now 0x%lx-0x%lx\n", i, + key, key+size, value, value+size); + } +} +#endif + +STATIC_INLINE StgCompactNFDataBlock * +find_pointer(StgWord *fixup_table, uint32_t count, StgClosure *q) +{ + StgWord address = (W_)q; + uint32_t a, b, c; + StgWord key, value; + bdescr *bd; + + a = 0; + b = count; + while (a < b-1) { + c = (a+b)/2; + + key = fixup_table[c * 2]; + value = fixup_table[c * 2 + 1]; + + if (key > address) + b = c; + else + a = c; + } + + // three cases here: 0, 1 or 2 blocks to check + for ( ; a < b; a++) { + key = fixup_table[a * 2]; + value = fixup_table[a * 2 + 1]; + + if (key > address) + goto fail; + + bd = Bdescr((P_)value); + + if (key + bd->blocks * BLOCK_SIZE <= address) + goto fail; + + return (StgCompactNFDataBlock*)value; + } + + fail: + // We should never get here + +#ifdef DEBUG + spew_failing_pointer(fixup_table, count, address); +#endif + return NULL; +} + +static rtsBool +fixup_one_pointer(StgWord *fixup_table, uint32_t count, StgClosure **p) +{ + StgWord tag; + StgClosure *q; + StgCompactNFDataBlock *block; + + q = *p; + tag = GET_CLOSURE_TAG(q); + q = UNTAG_CLOSURE(q); + + block = find_pointer(fixup_table, count, q); + if (block == NULL) + return rtsFalse; + if (block == block->self) + return rtsTrue; + + q = (StgClosure*)((W_)q - (W_)block->self + (W_)block); + *p = TAG_CLOSURE(tag, q); + + return rtsTrue; +} + +static rtsBool +fixup_mut_arr_ptrs (StgWord *fixup_table, + uint32_t count, + StgMutArrPtrs *a) +{ + StgPtr p, q; + + p = (StgPtr)&a->payload[0]; + q = (StgPtr)&a->payload[a->ptrs]; + for (; p < q; p++) { + if (!fixup_one_pointer(fixup_table, count, (StgClosure**)p)) + return rtsFalse; + } + + return rtsTrue; +} + +static rtsBool +fixup_block(StgCompactNFDataBlock *block, StgWord *fixup_table, uint32_t count) +{ + const StgInfoTable *info; + bdescr *bd; + StgPtr p; + + bd = Bdescr((P_)block); + p = bd->start + sizeofW(StgCompactNFDataBlock); + while (p < bd->free) { + ASSERT (LOOKS_LIKE_CLOSURE_PTR(p)); + info = get_itbl((StgClosure*)p); + + switch (info->type) { + case CONSTR_1_0: + if (!fixup_one_pointer(fixup_table, count, + &((StgClosure*)p)->payload[0])) + return rtsFalse; + case CONSTR_0_1: + p += sizeofW(StgClosure) + 1; + break; + + case CONSTR_2_0: + if (!fixup_one_pointer(fixup_table, count, + &((StgClosure*)p)->payload[1])) + return rtsFalse; + case CONSTR_1_1: + if (!fixup_one_pointer(fixup_table, count, + &((StgClosure*)p)->payload[0])) + return rtsFalse; + case CONSTR_0_2: + p += sizeofW(StgClosure) + 2; + break; + + case CONSTR: + case PRIM: + case CONSTR_STATIC: + case CONSTR_NOCAF_STATIC: + { + StgPtr end; + + end = (P_)((StgClosure *)p)->payload + info->layout.payload.ptrs; + for (p = (P_)((StgClosure *)p)->payload; p < end; p++) { + if (!fixup_one_pointer(fixup_table, count, (StgClosure **)p)) + return rtsFalse; + } + p += info->layout.payload.nptrs; + break; + } + + case ARR_WORDS: + p += arr_words_sizeW((StgArrBytes*)p); + break; + + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + fixup_mut_arr_ptrs(fixup_table, count, (StgMutArrPtrs*)p); + p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); + break; + + case SMALL_MUT_ARR_PTRS_FROZEN: + case SMALL_MUT_ARR_PTRS_FROZEN0: + { + uint32_t i; + StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p; + + for (i = 0; i < arr->ptrs; i++) { + if (!fixup_one_pointer(fixup_table, count, + &arr->payload[i])) + return rtsFalse; + } + + p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs; + break; + } + + case COMPACT_NFDATA: + if (p == (bd->start + sizeofW(StgCompactNFDataBlock))) { + // Ignore the COMPACT_NFDATA header + // (it will be fixed up later) + p += sizeofW(StgCompactNFData); + break; + } + + // fall through + + default: + debugBelch("Invalid non-NFData closure (type %d) in Compact\n", + info->type); + return rtsFalse; + } + } + + return rtsTrue; +} + +static int +cmp_fixup_table_item (const void *e1, const void *e2) +{ + const StgWord *w1 = e1; + const StgWord *w2 = e2; + + return *w1 - *w2; +} + +static StgWord * +build_fixup_table (StgCompactNFDataBlock *block, uint32_t *pcount) +{ + uint32_t count; + StgCompactNFDataBlock *tmp; + StgWord *table; + + count = 0; + tmp = block; + do { + count++; + tmp = tmp->next; + } while(tmp && tmp->owner); + + table = stgMallocBytes(sizeof(StgWord) * 2 * count, "build_fixup_table"); + + count = 0; + do { + table[count * 2] = (W_)block->self; + table[count * 2 + 1] = (W_)block; + count++; + block = block->next; + } while(block && block->owner); + + qsort(table, count, sizeof(StgWord) * 2, cmp_fixup_table_item); + + *pcount = count; + return table; +} + +static rtsBool +fixup_loop(StgCompactNFDataBlock *block, StgClosure **proot) +{ + StgWord *table; + rtsBool ok; + uint32_t count; + + table = build_fixup_table (block, &count); + + do { + if (!fixup_block(block, table, count)) { + ok = rtsFalse; + goto out; + } + + block = block->next; + } while(block && block->owner); + + ok = fixup_one_pointer(table, count, proot); + + out: + stgFree(table); + return ok; +} + +static void +fixup_early(StgCompactNFData *str, StgCompactNFDataBlock *block) +{ + StgCompactNFDataBlock *last; + + do { + last = block; + block = block->next; + } while(block); + + str->last = last; +} + +static void +fixup_late(StgCompactNFData *str, StgCompactNFDataBlock *block) +{ + StgCompactNFDataBlock *nursery; + bdescr *bd; + StgWord totalW; + StgWord totalDataW; + + nursery = block; + totalW = 0; + totalDataW = 0; + do { + block->self = block; + + bd = Bdescr((P_)block); + totalW += bd->blocks * BLOCK_SIZE_W; + + if (block->owner != NULL) { + if (bd->free != bd->start) + nursery = block; + block->owner = str; + totalDataW += bd->blocks * BLOCK_SIZE_W; + } + + block = block->next; + } while(block); + + str->nursery = nursery; + str->totalW = totalW; + str->totalDataW = totalDataW; +} + +static StgClosure * +maybe_fixup_internal_pointers (StgCompactNFDataBlock *block, + StgClosure *root) +{ + rtsBool ok; + StgClosure **proot; + + // Check for fast path + if (!any_needs_fixup(block)) + return root; + + debugBelch("Compact imported at the wrong address, will fix up" + " internal pointers\n"); + + // I am PROOT! + proot = &root; + + ok = fixup_loop(block, proot); + if (!ok) + *proot = NULL; + + return *proot; +} + +StgPtr +compactFixupPointers(StgCompactNFData *str, + StgClosure *root) +{ + StgCompactNFDataBlock *block; + bdescr *bd; + StgWord total_blocks; + + block = compactGetFirstBlock(str); + + fixup_early(str, block); + + root = maybe_fixup_internal_pointers(block, root); + + // Do the late fixup even if we did not fixup all + // internal pointers, we need that for GC and Sanity + fixup_late(str, block); + + // Now we're ready to let the GC, Sanity, the profiler + // etc. know about this object + bd = Bdescr((P_)block); + + total_blocks = str->totalW / BLOCK_SIZE_W; + + ACQUIRE_SM_LOCK; + ASSERT (bd->gen == g0); + ASSERT (g0->n_compact_blocks_in_import >= total_blocks); + g0->n_compact_blocks_in_import -= total_blocks; + g0->n_compact_blocks += total_blocks; + dbl_link_remove(bd, &g0->compact_blocks_in_import); + dbl_link_onto(bd, &g0->compact_objects); + RELEASE_SM_LOCK; + +#if DEBUG + if (root) + verify_consistency_loop(str); +#endif + + return (StgPtr)root; +} diff --git a/rts/sm/CNF.h b/rts/sm/CNF.h new file mode 100644 index 0000000000..b34d9c96c1 --- /dev/null +++ b/rts/sm/CNF.h @@ -0,0 +1,71 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 1998-2014 + * + * GC support for immutable non-GCed structures + * + * Documentation on the architecture of the Garbage Collector can be + * found in the online commentary: + * + * http://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC + * + * ---------------------------------------------------------------------------*/ + +#ifndef SM_CNF_H +#define SM_CNF_H + +#include "BeginPrivate.h" + +void initCompact (void); +void exitCompact (void); + +StgCompactNFData *compactNew (Capability *cap, + StgWord size); +StgPtr compactAppend(Capability *cap, + StgCompactNFData *str, + StgClosure *what, + StgWord share); +void compactResize(Capability *cap, + StgCompactNFData *str, + StgWord new_size); +void compactFree (StgCompactNFData *str); +void compactMarkKnown(StgCompactNFData *str); +StgWord compactContains(StgCompactNFData *str, + StgPtr what); +StgWord countCompactBlocks(bdescr *outer); + +StgCompactNFDataBlock *compactAllocateBlock(Capability *cap, + StgWord size, + StgCompactNFDataBlock *previous); +StgPtr compactFixupPointers(StgCompactNFData *str, + StgClosure *root); + +INLINE_HEADER StgCompactNFDataBlock *objectGetCompactBlock (StgClosure *closure); +INLINE_HEADER StgCompactNFDataBlock *objectGetCompactBlock (StgClosure *closure) +{ + bdescr *object_block, *head_block; + + object_block = Bdescr((StgPtr)closure); + + ASSERT ((object_block->flags & BF_COMPACT) != 0); + + if (object_block->blocks == 0) + head_block = object_block->link; + else + head_block = object_block; + + ASSERT ((head_block->flags & BF_COMPACT) != 0); + + return (StgCompactNFDataBlock*)(head_block->start); +} + +INLINE_HEADER StgCompactNFData *objectGetCompact (StgClosure *closure); +INLINE_HEADER StgCompactNFData *objectGetCompact (StgClosure *closure) +{ + StgCompactNFDataBlock *block = objectGetCompactBlock (closure); + return block->owner; +} + +#include "EndPrivate.h" + +#endif // SM_COMPACT_H diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index ec178e91ef..3528fabb7b 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -470,6 +470,7 @@ update_fwd_large( bdescr *bd ) switch (info->type) { case ARR_WORDS: + case COMPACT_NFDATA: // nothing to follow continue; diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index e53461de63..1f9c5cc8cd 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -25,6 +25,7 @@ #include "Prelude.h" #include "Trace.h" #include "LdvProfile.h" +#include "CNF.h" #if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC) StgWord64 whitehole_spin = 0; @@ -245,7 +246,7 @@ copy(StgClosure **p, const StgInfoTable *info, This just consists of removing the object from the (doubly-linked) gen->large_objects list, and linking it on to the (singly-linked) - gen->new_large_objects list, from where it will be scavenged later. + gct->todo_large_objects list, from where it will be scavenged later. Convention: bd->flags has BF_EVACUATED set for a large object that has been evacuated, or unset otherwise. @@ -305,12 +306,13 @@ evacuate_large(StgPtr p) bd->flags |= BF_EVACUATED; initBdescr(bd, new_gen, new_gen->to); - // If this is a block of pinned objects, we don't have to scan - // these objects, because they aren't allowed to contain any + // If this is a block of pinned or compact objects, we don't have to scan + // these objects, because they aren't allowed to contain any outgoing // pointers. For these blocks, we skip the scavenge stage and put // them straight on the scavenged_large_objects list. if (bd->flags & BF_PINNED) { ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS); + if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); } dbl_link_onto(bd, &new_gen->scavenged_large_objects); new_gen->n_scavenged_large_blocks += bd->blocks; @@ -356,6 +358,110 @@ evacuate_static_object (StgClosure **link_field, StgClosure *q) } /* ---------------------------------------------------------------------------- + Evacuate an object inside a CompactNFData + + Don't actually evacuate the object. Instead, evacuate the structure + (which is a large object, so it is just relinked onto the new list + of large objects of the generation). + + It is assumed that objects in the struct live in the same generation + as the struct itself all the time. + ------------------------------------------------------------------------- */ +STATIC_INLINE void +evacuate_compact (StgPtr p) +{ + StgCompactNFData *str; + bdescr *bd; + generation *gen, *new_gen; + uint32_t gen_no, new_gen_no; + + str = objectGetCompact((StgClosure*)p); + ASSERT(get_itbl((StgClosure*)str)->type == COMPACT_NFDATA); + + bd = Bdescr((StgPtr)str); + gen_no = bd->gen_no; + + // already evacuated? (we're about to do the same check, + // but we avoid taking the spin-lock) + if (bd->flags & BF_EVACUATED) { + /* Don't forget to set the gct->failed_to_evac flag if we didn't get + * the desired destination (see comments in evacuate()). + */ + if (gen_no < gct->evac_gen_no) { + gct->failed_to_evac = rtsTrue; + TICK_GC_FAILED_PROMOTION(); + } + return; + } + + gen = bd->gen; + gen_no = bd->gen_no; + ACQUIRE_SPIN_LOCK(&gen->sync); + + // already evacuated? + if (bd->flags & BF_EVACUATED) { + /* Don't forget to set the gct->failed_to_evac flag if we didn't get + * the desired destination (see comments in evacuate()). + */ + if (gen_no < gct->evac_gen_no) { + gct->failed_to_evac = rtsTrue; + TICK_GC_FAILED_PROMOTION(); + } + RELEASE_SPIN_LOCK(&gen->sync); + return; + } + + // remove from large_object list + if (bd->u.back) { + bd->u.back->link = bd->link; + } else { // first object in the list + gen->compact_objects = bd->link; + } + if (bd->link) { + bd->link->u.back = bd->u.back; + } + + /* link it on to the evacuated compact object list of the destination gen + */ + new_gen_no = bd->dest_no; + + if (new_gen_no < gct->evac_gen_no) { + if (gct->eager_promotion) { + new_gen_no = gct->evac_gen_no; + } else { + gct->failed_to_evac = rtsTrue; + } + } + + new_gen = &generations[new_gen_no]; + + // Note: for speed we only update the generation of the first block here + // This means that bdescr of subsequent blocks will think they are in + // the wrong generation + // (This should not be a problem because there is no code that checks + // for that - the only code touching the generation of the block is + // in the GC, and that should never see blocks other than the first) + bd->flags |= BF_EVACUATED; + initBdescr(bd, new_gen, new_gen->to); + + if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); } + dbl_link_onto(bd, &new_gen->live_compact_objects); + new_gen->n_live_compact_blocks += str->totalW / BLOCK_SIZE_W; + if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); } + + RELEASE_SPIN_LOCK(&gen->sync); + + // Note: the object did not move in memory, because it lives + // in pinned (BF_COMPACT) allocation, so we do not need to rewrite it + // or muck with forwarding pointers + // Also there is no tag to worry about on the struct (tags are used + // for constructors and functions, but a struct is neither). There + // might be a tag on the object pointer, but again we don't change + // the pointer because we don't move the object so we don't need to + // rewrite the tag. +} + +/* ---------------------------------------------------------------------------- Evacuate This is called (eventually) for every live object in the system. @@ -459,8 +565,7 @@ loop: bd = Bdescr((P_)q); - if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED)) != 0) { - + if ((bd->flags & (BF_LARGE | BF_MARKED | BF_EVACUATED | BF_COMPACT)) != 0) { // pointer into to-space: just return it. It might be a pointer // into a generation that we aren't collecting (> N), or it // might just be a pointer into to-space. The latter doesn't @@ -478,6 +583,15 @@ loop: return; } + // Check for compact before checking for large, this allows doing the + // right thing for objects that are half way in the middle of the first + // block of a compact (and would be treated as large objects even though + // they are not) + if (bd->flags & BF_COMPACT) { + evacuate_compact((P_)q); + return; + } + /* evacuate large objects by re-linking them onto a different list. */ if (bd->flags & BF_LARGE) { @@ -735,6 +849,12 @@ loop: copy(p,info,q,sizeofW(StgTRecChunk),gen_no); return; + case COMPACT_NFDATA: + // CompactNFData objects are at least one block plus the header + // so they are larger than the large_object_threshold (80% of + // block size) and never copied by value + barf("evacuate: compact nfdata is not large"); + return; default: barf("evacuate: strange closure type %d", (int)(INFO_PTR_TO_STRUCT(info)->type)); } diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 54798719a4..7796f30965 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -47,6 +47,7 @@ #include "RaiseAsync.h" #include "Stable.h" #include "CheckUnload.h" +#include "CNF.h" #include <string.h> // for memset() #include <unistd.h> @@ -592,6 +593,23 @@ GarbageCollect (uint32_t collect_gen, gen->n_large_blocks = gen->n_scavenged_large_blocks; gen->n_large_words = countOccupied(gen->large_objects); gen->n_new_large_words = 0; + + /* COMPACT_NFDATA. The currently live compacts are chained + * to live_compact_objects, quite like large objects. And + * objects left on the compact_objects list are dead. + * + * We don't run a simple freeChain because want to give the + * CNF module some chance to free memory that freeChain would + * not see (namely blocks appended to a CNF through a compactResize). + * + * See Note [Compact Normal Forms] for details. + */ + for (bd = gen->compact_objects; bd; bd = next) { + next = bd->link; + compactFree(((StgCompactNFDataBlock*)bd->start)->owner); + } + gen->compact_objects = gen->live_compact_objects; + gen->n_compact_blocks = gen->n_live_compact_blocks; } else // for generations > N { @@ -605,15 +623,27 @@ GarbageCollect (uint32_t collect_gen, gen->n_large_words += bd->free - bd->start; } + // And same for compacts + for (bd = gen->live_compact_objects; bd; bd = next) { + next = bd->link; + dbl_link_onto(bd, &gen->compact_objects); + } + // add the new blocks we promoted during this GC gen->n_large_blocks += gen->n_scavenged_large_blocks; + gen->n_compact_blocks += gen->n_live_compact_blocks; } ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); ASSERT(countOccupied(gen->large_objects) == gen->n_large_words); + // We can run the same assertion on compact objects because there + // is memory "the GC doesn't see" (directly), but which is still + // accounted in gen->n_compact_blocks gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; + gen->live_compact_objects = NULL; + gen->n_live_compact_blocks = 0; // Count "live" data live_words += genLiveWords(gen); @@ -1207,6 +1237,8 @@ prepare_collected_gen (generation *gen) // initialise the large object queues. ASSERT(gen->scavenged_large_objects == NULL); ASSERT(gen->n_scavenged_large_blocks == 0); + ASSERT(gen->live_compact_objects == NULL); + ASSERT(gen->n_live_compact_blocks == 0); // grab all the partial blocks stashed in the gc_thread workspaces and // move them to the old_blocks list of this gen. @@ -1246,6 +1278,11 @@ prepare_collected_gen (generation *gen) bd->flags &= ~BF_EVACUATED; } + // mark the compact objects as from-space + for (bd = gen->compact_objects; bd; bd = bd->link) { + bd->flags &= ~BF_EVACUATED; + } + // for a compacted generation, we need to allocate the bitmap if (gen->mark) { StgWord bitmap_size; // in bytes @@ -1472,7 +1509,8 @@ resize_generations (void) words = oldest_gen->n_words; } live = (words + BLOCK_SIZE_W - 1) / BLOCK_SIZE_W + - oldest_gen->n_large_blocks; + oldest_gen->n_large_blocks + + oldest_gen->n_compact_blocks; // default max size for all generations except zero size = stg_max(live * RtsFlags.GcFlags.oldGenFactor, diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 62d53e046d..6f6b15c4e8 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -28,6 +28,7 @@ #include "Printer.h" #include "Arena.h" #include "RetainerProfile.h" +#include "CNF.h" /* ----------------------------------------------------------------------------- Forward decls. @@ -424,7 +425,7 @@ checkClosure( const StgClosure* p ) } default: - barf("checkClosure (closure type %d)", info->type); + barf("checkClosure (closure type %d)", info->type); } } @@ -485,6 +486,37 @@ checkLargeObjects(bdescr *bd) } static void +checkCompactObjects(bdescr *bd) +{ + // Compact objects are similar to large objects, + // but they have a StgCompactNFDataBlock at the beginning, + // before the actual closure + + for ( ; bd != NULL; bd = bd->link) { + StgCompactNFDataBlock *block, *last; + StgCompactNFData *str; + StgWord totalW; + + ASSERT (bd->flags & BF_COMPACT); + + block = (StgCompactNFDataBlock*)bd->start; + str = block->owner; + ASSERT ((W_)str == (W_)block + sizeof(StgCompactNFDataBlock)); + + totalW = 0; + for ( ; block ; block = block->next) { + last = block; + ASSERT (block->owner == str); + + totalW += Bdescr((P_)block)->blocks * BLOCK_SIZE_W; + } + + ASSERT (str->totalW == totalW); + ASSERT (str->last == last); + } +} + +static void checkSTACK (StgStack *stack) { StgPtr sp = stack->sp; @@ -715,6 +747,7 @@ static void checkGeneration (generation *gen, } checkLargeObjects(gen->large_objects); + checkCompactObjects(gen->compact_objects); } /* Full heap sanity check. */ @@ -744,6 +777,14 @@ void checkSanity (rtsBool after_gc, rtsBool major_gc) } } +static void +markCompactBlocks(bdescr *bd) +{ + for (; bd != NULL; bd = bd->link) { + compactMarkKnown(((StgCompactNFDataBlock*)bd->start)->owner); + } +} + // If memInventory() calculates that we have a memory leak, this // function will try to find the block(s) that are leaking by marking // all the ones that we know about, and search through memory to find @@ -764,6 +805,7 @@ findMemoryLeak (void) } markBlocks(generations[g].blocks); markBlocks(generations[g].large_objects); + markCompactBlocks(generations[g].compact_objects); } for (i = 0; i < n_nurseries; i++) { @@ -833,8 +875,11 @@ genBlocks (generation *gen) { ASSERT(countBlocks(gen->blocks) == gen->n_blocks); ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + ASSERT(countCompactBlocks(gen->compact_objects) == gen->n_compact_blocks); + ASSERT(countCompactBlocks(gen->compact_blocks_in_import) == gen->n_compact_blocks_in_import); return gen->n_blocks + gen->n_old_blocks + - countAllocdBlocks(gen->large_objects); + countAllocdBlocks(gen->large_objects) + + gen->n_compact_blocks + gen->n_compact_blocks_in_import; } void diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 18a30d3bdf..1549df5021 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -795,6 +795,13 @@ scavenge_block (bdescr *bd) break; } + case COMPACT_NFDATA: + // CompactNFData blocks live in compact lists, which we don't + // scavenge, because there nothing to scavenge in them + // so we should never ever see them + barf("scavenge: found unexpected Compact structure"); + break; + default: barf("scavenge: unimplemented/strange closure type %d @ %p", info->type, p); @@ -1953,7 +1960,7 @@ scavenge_large (gen_workspace *ws) // take this object *off* the large objects list and put it on // the scavenged large objects list. This is so that we can - // treat new_large_objects as a stack and push new objects on + // treat todo_large_objects as a stack and push new objects on // the front when evacuating. ws->todo_large_objects = bd->link; diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 7c41f8c64b..3f8889658f 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -100,8 +100,12 @@ initGeneration (generation *gen, int g) gen->n_large_blocks = 0; gen->n_large_words = 0; gen->n_new_large_words = 0; + gen->compact_objects = NULL; + gen->n_compact_blocks = 0; gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; + gen->live_compact_objects = NULL; + gen->n_live_compact_blocks = 0; gen->mark = 0; gen->compact = 0; gen->bitmap = NULL; @@ -1208,12 +1212,13 @@ W_ countOccupied (bdescr *bd) W_ genLiveWords (generation *gen) { - return gen->n_words + gen->n_large_words; + return gen->n_words + gen->n_large_words + + gen->n_compact_blocks * BLOCK_SIZE_W; } W_ genLiveBlocks (generation *gen) { - return gen->n_blocks + gen->n_large_blocks; + return gen->n_blocks + gen->n_large_blocks + gen->n_compact_blocks; } W_ gcThreadLiveWords (uint32_t i, uint32_t g) @@ -1266,7 +1271,8 @@ calcNeeded (rtsBool force_major, memcount *blocks_needed) gen = &generations[g]; blocks = gen->n_blocks // or: gen->n_words / BLOCK_SIZE_W (?) - + gen->n_large_blocks; + + gen->n_large_blocks + + gen->n_compact_blocks; // we need at least this much space needed += blocks; diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs index 63e2233f8b..fb292b1394 100644 --- a/utils/deriveConstants/Main.hs +++ b/utils/deriveConstants/Main.hs @@ -391,7 +391,7 @@ wanteds os = concat ,structField Both "bdescr" "blocks" ,structField C "bdescr" "gen_no" ,structField C "bdescr" "link" - ,structField C "bdescr" "flags" + ,structField Both "bdescr" "flags" ,structSize C "generation" ,structField C "generation" "n_new_large_words" @@ -563,6 +563,17 @@ wanteds os = concat ,closureField C "MessageBlackHole" "tso" ,closureField C "MessageBlackHole" "bh" + ,closureSize C "StgCompactNFData" + ,closureField C "StgCompactNFData" "totalW" + ,closureField C "StgCompactNFData" "autoBlockW" + ,closureField C "StgCompactNFData" "nursery" + ,closureField C "StgCompactNFData" "last" + + ,structSize C "StgCompactNFDataBlock" + ,structField C "StgCompactNFDataBlock" "self" + ,structField C "StgCompactNFDataBlock" "owner" + ,structField C "StgCompactNFDataBlock" "next" + ,structField_ C "RtsFlags_ProfFlags_showCCSOnException" "RTS_FLAGS" "ProfFlags.showCCSOnException" ,structField_ C "RtsFlags_DebugFlags_apply" diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 294591444d..07eab0dacb 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -804,6 +804,7 @@ ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy" +ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy" ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for () ppType (TyVar "a") = "alphaTy" |