diff options
63 files changed, 1571 insertions, 910 deletions
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 49f78faa72..15fb785058 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2444,14 +2444,6 @@ primop CompactNewOp "compactNew#" GenPrimOp has_side_effects = True out_of_line = True -primop CompactAppendOp "compactAppend#" GenPrimOp - Compact# -> a -> Int# -> State# RealWorld -> (# State# RealWorld, a #) - { Append an object to a compact, return the new address in the Compact. - The third argument is 1 if sharing should be preserved, 0 otherwise. } - with - has_side_effects = True - out_of_line = True - primop CompactResizeOp "compactResize#" GenPrimOp Compact# -> Word# -> State# RealWorld -> State# RealWorld @@ -2515,6 +2507,34 @@ primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp has_side_effects = True out_of_line = True +primop CompactAdd "compactAdd#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Recursively add a closure and its transitive closure to a + {\texttt Compact\#}, evaluating any unevaluated components at the + same time. Note: {\texttt compactAdd\#} is not thread-safe, so + only one thread may call {\texttt compactAdd\#} with a particular + {\texttt Compact#} at any given time. The primop does not + enforce any mutual exclusion; the caller is expected to + arrange this. } + with + has_side_effects = True + out_of_line = True + +primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Like {\texttt compactAdd\#}, but retains sharing and cycles + during compaction. } + with + has_side_effects = True + out_of_line = True + +primop CompactSize "compactSize#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Word# #) + { Return the size (in bytes) of the total amount of data in the Compact# } + with + has_side_effects = True + out_of_line = True + ------------------------------------------------------------------------ section "Unsafe pointer equality" -- (#1 Bad Guy: Alastair Reid :) diff --git a/docs/users_guide/sooner.rst b/docs/users_guide/sooner.rst index fb9d626865..8b7a985ef2 100644 --- a/docs/users_guide/sooner.rst +++ b/docs/users_guide/sooner.rst @@ -311,6 +311,13 @@ Use a bigger heap! consume, or perhaps try passing :ghc-flag:`-H` without any argument to let GHC calculate a value based on the amount of live data. +Compact your data: + The ``Data.Compact`` library (in the ``compact`` package) provides + a way to make garbage collection more efficient for long-lived + data structures. Compacting a data structure collects the objects + together in memory, where they are treated as a single object by + the garbage collector and not traversed individually. + .. _smaller: Smaller: producing a program that is smaller diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 21ff2ab1c5..62d0800e68 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -95,6 +95,7 @@ typedef struct _DEBUG_FLAGS { bool hpc; /* 'c' coverage */ bool sparks; /* 'r' */ bool numa; /* '--debug-numa' */ + bool compact; /* 'C' */ } DEBUG_FLAGS; /* See Note [Synchronization of flags and base APIs] */ diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index f5ca5cd850..90198f20e8 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -421,12 +421,6 @@ closure_sizeW_ (const StgClosure *p, const StgInfoTable *info) return bco_sizeW((StgBCO *)p); case TREC_CHUNK: return sizeofW(StgTRecChunk); - case COMPACT_NFDATA: - // Nothing should ever call closure_sizeW() on a StgCompactNFData - // because CompactNFData is a magical object/list-of-objects that - // requires special paths pretty much everywhere in the GC - barf("closure_sizeW() called on a StgCompactNFData. " - "This should never happen."); default: return sizeW_fromITBL(info); } diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h index 4dda0a7f3a..2c62552b2f 100644 --- a/includes/rts/storage/Closures.h +++ b/includes/rts/storage/Closures.h @@ -419,49 +419,61 @@ typedef struct MessageBlackHole_ { StgClosure *bh; } MessageBlackHole; -// This is not a closure, it a bare -// structure that lives at the beginning of -// each consecutive block group in a -// compact structure +/* ---------------------------------------------------------------------------- + Compact Regions + ------------------------------------------------------------------------- */ + +// +// A compact region is a list of blocks. Each block starts with an +// StgCompactNFDataBlock structure, and the list is chained through the next +// field of these structs. (the link field of the bdescr is used to chain +// together multiple compact region on the compact_objects field of a +// generation). // // See Note [Compact Normal Forms] for details +// typedef struct StgCompactNFDataBlock_ { - struct StgCompactNFDataBlock_ *self; // the address of this block - // this is copied over to the receiving - // end when serializing a compact, so - // the receiving end can allocate the - // block at best as it can, and then - // verify if pointer adjustment is - // needed or not by comparing self with - // the actual address; the same data - // is sent over as SerializedCompact - // metadata, but having it here - // simplifies the fixup implementation - struct StgCompactNFData_ *owner; // the closure who owns this - // block (used in objectGetCompact) - struct StgCompactNFDataBlock_ *next; // chain of blocks used for - // serialization and freeing + struct StgCompactNFDataBlock_ *self; + // the address of this block this is copied over to the + // receiving end when serializing a compact, so the receiving + // end can allocate the block at best as it can, and then + // verify if pointer adjustment is needed or not by comparing + // self with the actual address; the same data is sent over as + // SerializedCompact metadata, but having it here simplifies + // the fixup implementation. + struct StgCompactNFData_ *owner; + // the closure who owns this block (used in objectGetCompact) + struct StgCompactNFDataBlock_ *next; + // chain of blocks used for serialization and freeing } StgCompactNFDataBlock; +// +// This is the Compact# primitive object. +// typedef struct StgCompactNFData_ { - StgHeader header; // for sanity and other checks in practice, - // nothing should ever need the compact info - // pointer (we don't even need fwding - // pointers because it's a large object) - StgWord totalW; // for proper accounting in evac, includes - // slop, and removes the first block in - // larger than megablock allocation - // essentially meaningless, but if we got it - // wrong sanity would complain loudly - StgWord totalDataW; // for stats/profiling only, it's the - // full amount of memory used by this - // compact, including the portions not - // yet used - StgWord autoBlockW; // size of automatically appended blocks - StgCompactNFDataBlock *nursery; // where to (try to) allocate from when - // appending - StgCompactNFDataBlock *last; // the last block of the chain (to know where - // to append new blocks for resize) + StgHeader header; + // for sanity and other checks in practice, nothing should ever + // need the compact info pointer (we don't even need fwding + // pointers because it's a large object) + StgWord totalW; + // Total number of words in all blocks in the compact + StgWord autoBlockW; + // size of automatically appended blocks + StgPtr hp, hpLim; + // the beginning and end of the free area in the nursery block. This is + // just a convenience so that we can avoid multiple indirections through + // the nursery pointer below during compaction. + StgCompactNFDataBlock *nursery; + // where to (try to) allocate from when appending + StgCompactNFDataBlock *last; + // the last block of the chain (to know where to append new + // blocks for resize) + struct hashtable *hash; + // the hash table for the current compaction, or NULL if + // there's no (sharing-preserved) compaction in progress. + StgClosure *result; + // Used temporarily to store the result of compaction. Doesn't need to be + // a GC root. } StgCompactNFData; diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 07a7752ed2..65562b2c4b 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -151,7 +151,8 @@ RTS_ENTRY(stg_END_STM_WATCH_QUEUE); RTS_ENTRY(stg_END_INVARIANT_CHECK_QUEUE); RTS_ENTRY(stg_END_STM_CHUNK_LIST); RTS_ENTRY(stg_NO_TREC); -RTS_ENTRY(stg_COMPACT_NFDATA); +RTS_ENTRY(stg_COMPACT_NFDATA_CLEAN); +RTS_ENTRY(stg_COMPACT_NFDATA_DIRTY); /* closures */ @@ -411,6 +412,8 @@ RTS_FUN_DECL(stg_makeStableNamezh); RTS_FUN_DECL(stg_makeStablePtrzh); RTS_FUN_DECL(stg_deRefStablePtrzh); +RTS_FUN_DECL(stg_compactAddzh); +RTS_FUN_DECL(stg_compactAddWithSharingzh); RTS_FUN_DECL(stg_compactNewzh); RTS_FUN_DECL(stg_compactAppendzh); RTS_FUN_DECL(stg_compactResizzezh); @@ -421,6 +424,7 @@ RTS_FUN_DECL(stg_compactGetFirstBlockzh); RTS_FUN_DECL(stg_compactGetNextBlockzh); RTS_FUN_DECL(stg_compactAllocateBlockzh); RTS_FUN_DECL(stg_compactFixupPointerszh); +RTS_FUN_DECL(stg_compactSizzezh); RTS_FUN_DECL(stg_forkzh); RTS_FUN_DECL(stg_forkOnzh); diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index a6c1083834..88938e2ee2 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -49,6 +49,7 @@ module Control.Exception ( BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..), AllocationLimitExceeded(..), + CompactionFailed(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index 9dd96488bc..3e7ac0f9e8 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -32,6 +32,7 @@ module Control.Exception.Base ( BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..), AllocationLimitExceeded(..), + CompactionFailed(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 69d2c330c9..a8d63d3b28 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -24,6 +24,8 @@ module GHC.IO.Exception ( Deadlock(..), AllocationLimitExceeded(..), allocationLimitExceeded, AssertionFailed(..), + CompactionFailed(..), + cannotCompactFunction, cannotCompactPinned, cannotCompactMutable, SomeAsyncException(..), asyncExceptionToException, asyncExceptionFromException, @@ -127,6 +129,35 @@ allocationLimitExceeded = toException AllocationLimitExceeded ----- +-- |Compaction found an object that cannot be compacted. Functions +-- cannot be compacted, nor can mutable objects or pinned objects. +-- See 'Data.Compact.compact'. +-- +-- @since 4.10.0.0 +data CompactionFailed = CompactionFailed String + +-- | @since 4.10.0.0 +instance Exception CompactionFailed where + +-- | @since 4.10.0.0 +instance Show CompactionFailed where + showsPrec _ (CompactionFailed why) = + showString ("compaction failed: " ++ why) + +cannotCompactFunction :: SomeException -- for the RTS +cannotCompactFunction = + toException (CompactionFailed "cannot compact functions") + +cannotCompactPinned :: SomeException -- for the RTS +cannotCompactPinned = + toException (CompactionFailed "cannot compact pinned objects") + +cannotCompactMutable :: SomeException -- for the RTS +cannotCompactMutable = + toException (CompactionFailed "cannot compact mutable objects") + +----- + -- |'assert' was applied to 'False'. newtype AssertionFailed = AssertionFailed String diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs index 7cedd1c27a..85d1b623b4 100644 --- a/libraries/compact/Data/Compact.hs +++ b/libraries/compact/Data/Compact.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-name-shadowing #-} ----------------------------------------------------------------------------- -- | @@ -18,72 +19,102 @@ -- holding fully evaluated data in a consecutive block of memory. -- -- /Since: 1.0.0/ + module Data.Compact ( + -- * The Compact type Compact, + + -- * Compacting data + compact, + compactWithSharing, + compactAdd, + compactAddWithSharing, + + -- * Inspecting a Compact getCompact, inCompact, isCompact, + compactSize, - newCompact, - newCompactNoShare, - appendCompact, - appendCompactNoShare, + -- * Other utilities + compactResize, ) where --- Write down all GHC.Prim deps explicitly to keep them at minimum -import GHC.Prim (Compact#, - compactNew#, - State#, - RealWorld, - Int#, - ) --- We need to import Word from GHC.Types to see the representation --- and to able to access the Word# to pass down the primops -import GHC.Types (IO(..), Word(..)) - -import Control.DeepSeq (NFData, force) - -import Data.Compact.Internal(Compact(..), - isCompact, - inCompact, - compactAppendEvaledInternal) - --- |Retrieve the object that was stored in a Compact +import Control.Concurrent +import Control.DeepSeq (NFData) +import GHC.Prim +import GHC.Types + +import Data.Compact.Internal as Internal + +-- | Retrieve the object that was stored in a 'Compact' getCompact :: Compact a -> a -getCompact (Compact _ obj) = obj - -compactAppendInternal :: NFData a => Compact# -> a -> Int# -> - State# RealWorld -> (# State# RealWorld, Compact a #) -compactAppendInternal buffer root share s = - case force root of - !eval -> compactAppendEvaledInternal buffer eval share s - -compactAppendInternalIO :: NFData a => Int# -> Compact b -> a -> IO (Compact a) -compactAppendInternalIO share (Compact buffer _) root = - IO (\s -> compactAppendInternal buffer root share s) - --- |Append a value to a 'Compact', and return a new 'Compact' --- that shares the same buffer but a different root object. -appendCompact :: NFData a => Compact b -> a -> IO (Compact a) -appendCompact = compactAppendInternalIO 1# - --- |Append a value to a 'Compact'. This function differs from --- 'appendCompact' in that it will not preserve internal sharing --- in the passed in value (and it will diverge on cyclic structures). -appendCompactNoShare :: NFData a => Compact b -> a -> IO (Compact a) -appendCompactNoShare = compactAppendInternalIO 0# - -compactNewInternal :: NFData a => Int# -> Word -> a -> IO (Compact a) -compactNewInternal share (W# size) root = - IO (\s -> case compactNew# size s of - (# s', buffer #) -> compactAppendInternal buffer root share s' ) - --- |Create a new 'Compact', with the provided value as suggested block --- size (which will be adjusted if unsuitable), and append the given --- value to it, as if calling 'appendCompact' -newCompact :: NFData a => Word -> a -> IO (Compact a) -newCompact = compactNewInternal 1# - --- |Create a new 'Compact', but append the value using 'appendCompactNoShare' -newCompactNoShare :: NFData a => Word -> a -> IO (Compact a) -newCompactNoShare = compactNewInternal 0# +getCompact (Compact _ obj _) = obj + +-- | Compact a value. /O(size of unshared data)/ +-- +-- If the structure contains any internal sharing, the shared data +-- will be duplicated during the compaction process. Loops if the +-- structure constains cycles. +-- +-- The NFData constraint is just to ensure that the object contains no +-- functions, 'compact' does not actually use it. If your object +-- contains any functions, then 'compact' will fail. (and your +-- 'NFData' instance is lying). +-- +compact :: NFData a => a -> IO (Compact a) +compact = Internal.compactSized 31268 False + +-- | Compact a value, retaining any internal sharing and +-- cycles. /O(size of data)/ +-- +-- This is typically about 10x slower than 'compact', because it works +-- by maintaining a hash table mapping uncompacted objects to +-- compacted objects. +-- +-- The 'NFData' constraint is just to ensure that the object contains no +-- functions, `compact` does not actually use it. If your object +-- contains any functions, then 'compactWithSharing' will fail. (and +-- your 'NFData' instance is lying). +-- +compactWithSharing :: NFData a => a -> IO (Compact a) +compactWithSharing = Internal.compactSized 31268 True + +-- | Add a value to an existing 'Compact'. Behaves exactly like +-- 'compact' with respect to sharing and the 'NFData' constraint. +compactAdd :: NFData a => Compact b -> a -> IO (Compact a) +compactAdd (Compact compact# _ lock) a = withMVar lock $ \_ -> IO $ \s -> + case compactAdd# compact# a s of { (# s1, pk #) -> + (# s1, Compact compact# pk lock #) } + +-- | Add a value to an existing 'Compact'. Behaves exactly like +-- 'compactWithSharing' with respect to sharing and the 'NFData' +-- constraint. +compactAddWithSharing :: NFData a => Compact b -> a -> IO (Compact a) +compactAddWithSharing (Compact compact# _ lock) a = + withMVar lock $ \_ -> IO $ \s -> + case compactAddWithSharing# compact# a s of { (# s1, pk #) -> + (# s1, Compact compact# pk lock #) } + + +-- | Check if the second argument is inside the 'Compact' +inCompact :: Compact b -> a -> IO Bool +inCompact (Compact buffer _ _) !val = + IO (\s -> case compactContains# buffer val s of + (# s', v #) -> (# s', isTrue# v #) ) + +-- | Check if the argument is in any 'Compact' +isCompact :: a -> IO Bool +isCompact !val = + IO (\s -> case compactContainsAny# val s of + (# s', v #) -> (# s', isTrue# v #) ) + +compactSize :: Compact a -> IO Word +compactSize (Compact buffer _ lock) = withMVar lock $ \_ -> IO $ \s0 -> + case compactSize# buffer s0 of (# s1, sz #) -> (# s1, W# sz #) + +compactResize :: Compact a -> Word -> IO () +compactResize (Compact oldBuffer _ lock) (W# new_size) = + withMVar lock $ \_ -> IO $ \s -> + case compactResize# oldBuffer new_size s of + s' -> (# s', () #) diff --git a/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs index 36cd438b1e..2780d19b1a 100644 --- a/libraries/compact/Data/Compact/Internal.hs +++ b/libraries/compact/Data/Compact/Internal.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} @@ -22,57 +21,82 @@ -- -- /Since: 1.0.0/ -module Data.Compact.Internal( - Compact(..), - compactResize, - isCompact, - inCompact, +module Data.Compact.Internal + ( Compact(..) + , mkCompact + , compactSized + ) where - compactAppendEvaledInternal, -) where +import Control.Concurrent.MVar +import Control.DeepSeq +import GHC.Prim +import GHC.Types --- Write down all GHC.Prim deps explicitly to keep them at minimum -import GHC.Prim (Compact#, - compactAppend#, - compactResize#, - compactContains#, - compactContainsAny#, - State#, - RealWorld, - Int#, - ) --- We need to import Word from GHC.Types to see the representation --- and to able to access the Word# to pass down the primops -import GHC.Types (IO(..), Word(..), isTrue#) - --- | A 'Compact' contains fully evaluated, pure, and immutable data. If --- any object in the compact is alive, then the whole compact is --- alive. This means that 'Compact's are very cheap to keep around, --- because the data inside a compact does not need to be traversed by --- the garbage collector. However, the tradeoff is that the memory --- that contains a 'Compact' cannot be recovered until the whole 'Compact' --- is garbage. -data Compact a = Compact Compact# a - --- |Check if the second argument is inside the Compact -inCompact :: Compact b -> a -> IO Bool -inCompact (Compact buffer _) !val = - IO (\s -> case compactContains# buffer val s of - (# s', v #) -> (# s', isTrue# v #) ) - --- |Check if the argument is in any Compact -isCompact :: a -> IO Bool -isCompact !val = - IO (\s -> case compactContainsAny# val s of - (# s', v #) -> (# s', isTrue# v #) ) +-- | A 'Compact' contains fully evaluated, pure, immutable data. +-- +-- 'Compact' serves two purposes: +-- +-- * Data stored in a 'Compact' has no garbage collection overhead. +-- The garbage collector considers the whole 'Compact' to be alive +-- if there is a reference to any object within it. +-- +-- * A 'Compact' can be serialized, stored, and deserialized again. +-- The serialized data can only be deserialized by the exact binary +-- that created it, but it can be stored indefinitely before +-- deserialization. +-- +-- Compacts are self-contained, so compacting data involves copying +-- it; if you have data that lives in two 'Compact's, each will have a +-- separate copy of the data. +-- +-- The cost of compaction is similar to the cost of GC for the same +-- data, but it is perfomed only once. However, retainining internal +-- sharing during the compaction process is very costly, so it is +-- optional; there are two ways to create a 'Compact': 'compact' and +-- 'compactWithSharing'. +-- +-- Data can be added to an existing 'Compact' with 'compactAdd' or +-- 'compactAddWithSharing'. +-- +-- Data in a compact doesn't ever move, so compacting data is also a +-- way to pin arbitrary data structures in memory. +-- +-- There are some limitations on what can be compacted: +-- +-- * Functions. Compaction only applies to data. +-- +-- * Pinned 'ByteArray#' objects cannot be compacted. This is for a +-- good reason: the memory is pinned so that it can be referenced by +-- address (the address might be stored in a C data structure, for +-- example), so we can't make a copy of it to store in the 'Compact'. +-- +-- * Mutable objects also cannot be compacted, because subsequent +-- mutation would destroy the property that a compact is +-- self-contained. +-- +-- If compaction encounters any of the above, a 'CompactionFailed' +-- exception will be thrown by the compaction operation. +-- +data Compact a = Compact Compact# a (MVar ()) + -- we can *read* from a Compact without taking a lock, but only + -- one thread can be writing to the compact at any given time. + -- The MVar here is to enforce mutual exclusion among writers. + -- Note: the MVar protects the Compact# only, not the pure value 'a' -compactResize :: Compact a -> Word -> IO () -compactResize (Compact oldBuffer _) (W# new_size) = - IO (\s -> case compactResize# oldBuffer new_size s of - s' -> (# s', () #) ) +mkCompact + :: Compact# -> a -> State# RealWorld -> (# State# RealWorld, Compact a #) +mkCompact compact# a s = + case unIO (newMVar ()) s of { (# s1, lock #) -> + (# s1, Compact compact# a lock #) } + where + unIO (IO a) = a -compactAppendEvaledInternal :: Compact# -> a -> Int# -> State# RealWorld -> - (# State# RealWorld, Compact a #) -compactAppendEvaledInternal buffer root share s = - case compactAppend# buffer root share s of - (# s', adjustedRoot #) -> (# s', Compact buffer adjustedRoot #) +compactSized :: NFData a => Int -> Bool -> a -> IO (Compact a) +compactSized (I# size) share a = IO $ \s0 -> + case compactNew# (int2Word# size) s0 of { (# s1, compact# #) -> + case compactAddPrim compact# a s1 of { (# s2, pk #) -> + mkCompact compact# pk s2 }} + where + compactAddPrim + | share = compactAddWithSharing# + | otherwise = compactAdd# diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs index e58f9eef83..bdc2aff733 100644 --- a/libraries/compact/Data/Compact/Serialized.hs +++ b/libraries/compact/Data/Compact/Serialized.hs @@ -29,30 +29,13 @@ module Data.Compact.Serialized( importCompactByteStrings, ) where --- Write down all GHC.Prim deps explicitly to keep them at minimum -import GHC.Prim (Compact#, - compactGetFirstBlock#, - compactGetNextBlock#, - compactAllocateBlock#, - compactFixupPointers#, - touch#, - Addr#, - nullAddr#, - eqAddr#, - addrToAny#, - anyToAddr#, - State#, - RealWorld, - Word#, - ) - --- We need to import Word from GHC.Types to see the representation --- and to able to access the Word# to pass down the primops -import GHC.Types (IO(..), Word(..), isTrue#) +import GHC.Prim +import GHC.Types import GHC.Word (Word8) import GHC.Ptr (Ptr(..), plusPtr) +import Control.Concurrent import qualified Data.ByteString as ByteString import Data.ByteString.Internal(toForeignPtr) import Data.IORef(newIORef, readIORef, writeIORef) @@ -60,16 +43,16 @@ import Foreign.ForeignPtr(withForeignPtr) import Foreign.Marshal.Utils(copyBytes) import Control.DeepSeq(NFData, force) -import Data.Compact.Internal(Compact(..)) +import Data.Compact.Internal -- |A serialized version of the 'Compact' metadata (each block with -- address and size and the address of the root). This structure is -- meant to be sent alongside the actual 'Compact' data. It can be -- sent out of band in advance if the data is to be sent over RDMA -- (which requires both sender and receiver to have pinned buffers). -data SerializedCompact a = SerializedCompact { - serializedCompactBlockList :: [(Ptr a, Word)], - serializedCompactRoot :: Ptr a +data SerializedCompact a = SerializedCompact + { serializedCompactBlockList :: [(Ptr a, Word)] + , serializedCompactRoot :: Ptr a } addrIsNull :: Addr# -> Bool @@ -109,7 +92,7 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go {-# NOINLINE withSerializedCompact #-} withSerializedCompact :: NFData c => Compact a -> (SerializedCompact a -> IO c) -> IO c -withSerializedCompact (Compact buffer root) func = do +withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do rootPtr <- IO (\s -> case anyToAddr# root s of (# s', rootAddr #) -> (# s', Ptr rootAddr #) ) blockList <- mkBlockList buffer @@ -129,7 +112,8 @@ fixupPointers firstBlock rootAddr s = (# s', buffer, adjustedRoot #) -> if addrIsNull adjustedRoot then (# s', Nothing #) else case addrToAny# adjustedRoot of - (# root #) -> (# s', Just $ Compact buffer root #) + (# root #) -> case mkCompact buffer root s' of + (# s'', c #) -> (# s'', Just c #) -- |Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The -- provided function will be called with the address and size of each @@ -175,11 +159,13 @@ importCompact (SerializedCompact blocks root) filler = do -- these are obviously strict lets, but ghc complains otherwise let !((_, W# firstSize):otherBlocks) = blocks let !(Ptr rootAddr) = root - IO (\s0 -> case compactAllocateBlock# firstSize nullAddr# s0 of - (# s1, firstBlock #) -> - case fillBlock firstBlock firstSize s1 of - s2 -> case go firstBlock otherBlocks s2 of - s3-> fixupPointers firstBlock rootAddr s3 ) + IO $ \s0 -> + case compactAllocateBlock# firstSize nullAddr# s0 of { + (# s1, firstBlock #) -> + case fillBlock firstBlock firstSize s1 of { s2 -> + case go firstBlock otherBlocks s2 of { s3 -> + fixupPointers firstBlock rootAddr s3 + }}} where -- note that the case statements above are strict even though -- they don't seem to inspect their argument because State# diff --git a/libraries/compact/tests/.gitignore b/libraries/compact/tests/.gitignore index c20cf7d4be..8887a1bbea 100644 --- a/libraries/compact/tests/.gitignore +++ b/libraries/compact/tests/.gitignore @@ -1,6 +1,3 @@ -*.stderr -!compact_serialize.stderr -*.stdout .hpc.* *.eventlog *.genscript diff --git a/libraries/compact/tests/all.T b/libraries/compact/tests/all.T index fd543142e9..bdcf522cf6 100644 --- a/libraries/compact/tests/all.T +++ b/libraries/compact/tests/all.T @@ -1,6 +1,19 @@ -test('compact_simple', omit_ways(['ghci']), compile_and_run, ['']) -test('compact_loop', omit_ways(['ghci']), compile_and_run, ['']) -test('compact_append', omit_ways(['ghci']), compile_and_run, ['']) -test('compact_autoexpand', omit_ways(['ghci']), compile_and_run, ['']) -test('compact_simple_array', omit_ways(['ghci']), compile_and_run, ['']) -test('compact_serialize', omit_ways(['ghci']), compile_and_run, [''])
\ No newline at end of file +setTestOpts(extra_ways(['sanity'])) + +test('compact_simple', normal, compile_and_run, ['']) +test('compact_loop', normal, compile_and_run, ['']) +test('compact_append', normal, compile_and_run, ['']) +test('compact_autoexpand', normal, compile_and_run, ['']) +test('compact_simple_array', normal, compile_and_run, ['']) +test('compact_huge_array', normal, compile_and_run, ['']) +test('compact_serialize', normal, compile_and_run, ['']) +test('compact_largemap', normal, compile_and_run, ['']) +test('compact_threads', [ extra_run_opts('1000') ], compile_and_run, ['']) +test('compact_cycle', extra_run_opts('+RTS -K1m'), compile_and_run, ['']) +test('compact_function', exit_code(1), compile_and_run, ['']) +test('compact_mutable', exit_code(1), compile_and_run, ['']) +test('compact_pinned', exit_code(1), compile_and_run, ['']) +test('compact_gc', normal, compile_and_run, ['']) +test('compact_share', normal, compile_and_run, ['']) +test('compact_bench', [ ignore_stdout, extra_run_opts('100') ], + compile_and_run, ['']) diff --git a/libraries/compact/tests/compact_append.hs b/libraries/compact/tests/compact_append.hs index 59f86777b7..e61262eea6 100644 --- a/libraries/compact/tests/compact_append.hs +++ b/libraries/compact/tests/compact_append.hs @@ -16,10 +16,10 @@ assertEquals expected actual = main = do let val = ("hello", Just 42) :: (String, Maybe Int) - str <- newCompact 4096 val + str <- compactWithSharing val let val2 = ("world", 42) :: (String, Int) - str2 <- appendCompact str val2 + str2 <- compactAddWithSharing str val2 -- check that values where not corrupted assertEquals ("hello", Just 42) val diff --git a/libraries/compact/tests/compact_autoexpand.hs b/libraries/compact/tests/compact_autoexpand.hs index 5db0bbc55f..5134380777 100644 --- a/libraries/compact/tests/compact_autoexpand.hs +++ b/libraries/compact/tests/compact_autoexpand.hs @@ -4,6 +4,7 @@ import Control.Exception import System.Mem import Data.Compact +import Data.Compact.Internal assertFail :: String -> IO () assertFail msg = throwIO $ AssertionFailed msg @@ -21,7 +22,7 @@ main = do -- 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 + str <- compactSized 1 True val assertEquals val (getCompact str) performMajorGC assertEquals val (getCompact str) diff --git a/libraries/compact/tests/compact_bench.hs b/libraries/compact/tests/compact_bench.hs new file mode 100644 index 0000000000..3764c3e3e1 --- /dev/null +++ b/libraries/compact/tests/compact_bench.hs @@ -0,0 +1,28 @@ +import Control.Exception +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map +import Data.Time.Clock +import Text.Printf +import System.Environment +import System.Mem +import Control.DeepSeq + +-- Benchmark compact against compactWithSharing. e.g. +-- ./compact_bench 1000000 + +main = do + [n] <- map read <$> getArgs + let m = Map.fromList [(x,[x*1000..x*1000+10]) | x <- [1..(n::Integer)]] + evaluate (force m) + timeIt "compact" $ compact m >>= compactSize >>= print + timeIt "compactWithSharing" $ compactWithSharing m >>= compactSize >>= print + +timeIt :: String -> IO a -> IO a +timeIt str io = do + performMajorGC + t0 <- getCurrentTime + a <- io + t1 <- getCurrentTime + printf "%s: %.2f\n" str (realToFrac (t1 `diffUTCTime` t0) :: Double) + return a diff --git a/libraries/compact/tests/compact_bytestring.hs b/libraries/compact/tests/compact_bytestring.hs new file mode 100644 index 0000000000..16c486ba58 --- /dev/null +++ b/libraries/compact/tests/compact_bytestring.hs @@ -0,0 +1,8 @@ +import qualified Data.ByteString.Char8 as B +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map + +main = do + c <- compact (Map.fromList [(B.pack (show x), x) | x <- [1..(10000::Int)]]) + print (getCompact c) diff --git a/libraries/compact/tests/compact_cycle.hs b/libraries/compact/tests/compact_cycle.hs new file mode 100644 index 0000000000..4c771a1d34 --- /dev/null +++ b/libraries/compact/tests/compact_cycle.hs @@ -0,0 +1,10 @@ +import Control.Exception +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map +import System.Exit + +main = do + c <- compactWithSharing (cycle "abc") -- magic! + print (length (show (take 100 (getCompact c)))) + print =<< compactSize c diff --git a/libraries/compact/tests/compact_cycle.stdout b/libraries/compact/tests/compact_cycle.stdout new file mode 100644 index 0000000000..6fc8a53046 --- /dev/null +++ b/libraries/compact/tests/compact_cycle.stdout @@ -0,0 +1,2 @@ +102 +32768 diff --git a/libraries/compact/tests/compact_function.hs b/libraries/compact/tests/compact_function.hs new file mode 100644 index 0000000000..fc4f4ca172 --- /dev/null +++ b/libraries/compact/tests/compact_function.hs @@ -0,0 +1,10 @@ +import Control.DeepSeq +import Control.Exception +import Data.Compact + +data HiddenFunction = HiddenFunction (Int -> Int) + +instance NFData HiddenFunction where + rnf x = x `seq` () -- ignore the function inside + +main = compact (HiddenFunction (+1)) diff --git a/libraries/compact/tests/compact_function.stderr b/libraries/compact/tests/compact_function.stderr new file mode 100644 index 0000000000..197da0460b --- /dev/null +++ b/libraries/compact/tests/compact_function.stderr @@ -0,0 +1 @@ +compact_function: compaction failed: cannot compact functions diff --git a/libraries/compact/tests/compact_gc.hs b/libraries/compact/tests/compact_gc.hs new file mode 100644 index 0000000000..a88e87d958 --- /dev/null +++ b/libraries/compact/tests/compact_gc.hs @@ -0,0 +1,12 @@ +import Control.Monad +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map + +main = do + let m = Map.fromList [(x,show x) | x <- [1..(10000::Int)]] + c <- compactWithSharing m + print =<< compactSize c + c <- foldM (\c _ -> do c <- compactWithSharing (getCompact c); print =<< compactSize c; return c) c [1..10] + print (length (show (getCompact c))) + print =<< compactSize c diff --git a/libraries/compact/tests/compact_gc.stdout b/libraries/compact/tests/compact_gc.stdout new file mode 100644 index 0000000000..c44d58836d --- /dev/null +++ b/libraries/compact/tests/compact_gc.stdout @@ -0,0 +1,13 @@ +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +2228224 +137798 +2228224 diff --git a/libraries/compact/tests/compact_huge_array.hs b/libraries/compact/tests/compact_huge_array.hs new file mode 100644 index 0000000000..8a8374297b --- /dev/null +++ b/libraries/compact/tests/compact_huge_array.hs @@ -0,0 +1,61 @@ +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 +import Data.Compact.Internal + +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, 300000) [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 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 (compactSized 4096 True) + test (compactSized 4096 False) diff --git a/libraries/compact/tests/compact_largemap.hs b/libraries/compact/tests/compact_largemap.hs new file mode 100644 index 0000000000..0c72a32c75 --- /dev/null +++ b/libraries/compact/tests/compact_largemap.hs @@ -0,0 +1,10 @@ +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map + +main = do + let m = Map.fromList [(x,show x) | x <- [1..(10000::Integer)]] + c <- compactWithSharing m + print (length (show (getCompact c))) + c <- compact m + print (length (show (getCompact c))) diff --git a/libraries/compact/tests/compact_largemap.stdout b/libraries/compact/tests/compact_largemap.stdout new file mode 100644 index 0000000000..4825984a93 --- /dev/null +++ b/libraries/compact/tests/compact_largemap.stdout @@ -0,0 +1,2 @@ +137798 +137798 diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs index 0111fc1bdb..c8991b05d0 100644 --- a/libraries/compact/tests/compact_loop.hs +++ b/libraries/compact/tests/compact_loop.hs @@ -6,6 +6,7 @@ import System.Mem import Text.Show import Data.Compact +import Data.Compact.Internal assertFail :: String -> IO () assertFail msg = throwIO $ AssertionFailed msg @@ -36,7 +37,7 @@ instance NFData Tree where test x = do let a = Node Nil x b b = Node a Nil Nil - str <- newCompact 4096 a + str <- compactSized 4096 True a -- check the value in the compact assertEquals a (getCompact str) diff --git a/libraries/compact/tests/compact_mutable.hs b/libraries/compact/tests/compact_mutable.hs new file mode 100644 index 0000000000..2d1a7f2572 --- /dev/null +++ b/libraries/compact/tests/compact_mutable.hs @@ -0,0 +1,13 @@ +import Control.Concurrent +import Control.DeepSeq +import Control.Exception +import Data.Compact + +data HiddenMVar = HiddenMVar (MVar ()) + +instance NFData HiddenMVar where + rnf x = x `seq` () -- ignore the function inside + +main = do + m <- newEmptyMVar + compact (HiddenMVar m) diff --git a/libraries/compact/tests/compact_mutable.stderr b/libraries/compact/tests/compact_mutable.stderr new file mode 100644 index 0000000000..9a4bd2892e --- /dev/null +++ b/libraries/compact/tests/compact_mutable.stderr @@ -0,0 +1 @@ +compact_mutable: compaction failed: cannot compact mutable objects diff --git a/libraries/compact/tests/compact_pinned.hs b/libraries/compact/tests/compact_pinned.hs new file mode 100644 index 0000000000..a2a45bb7b9 --- /dev/null +++ b/libraries/compact/tests/compact_pinned.hs @@ -0,0 +1,6 @@ +import Control.DeepSeq +import Control.Exception +import qualified Data.ByteString.Char8 as B +import Data.Compact + +main = compact (B.pack "abc") diff --git a/libraries/compact/tests/compact_pinned.stderr b/libraries/compact/tests/compact_pinned.stderr new file mode 100644 index 0000000000..1f470a0d49 --- /dev/null +++ b/libraries/compact/tests/compact_pinned.stderr @@ -0,0 +1 @@ +compact_pinned: compaction failed: cannot compact pinned objects diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs index e4ba88ea9e..2b831e048c 100644 --- a/libraries/compact/tests/compact_serialize.hs +++ b/libraries/compact/tests/compact_serialize.hs @@ -10,6 +10,7 @@ import Foreign.Ptr import Control.DeepSeq import Data.Compact +import Data.Compact.Internal import Data.Compact.Serialized assertFail :: String -> IO () @@ -23,7 +24,7 @@ assertEquals expected actual = serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString]) serialize val = do - cnf <- newCompact 4096 val + cnf <- compactSized 4096 True val bytestrref <- newIORef undefined scref <- newIORef undefined diff --git a/libraries/compact/tests/compact_share.hs b/libraries/compact/tests/compact_share.hs new file mode 100644 index 0000000000..73654e430b --- /dev/null +++ b/libraries/compact/tests/compact_share.hs @@ -0,0 +1,14 @@ +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map + +main = do + let m1 = Map.fromList [(x,show x) | x <- [1..(10000::Integer)]] + m2 = Map.fromList [(x,y) | x <- [1..(10000::Integer)], + Just y <- [Map.lookup x m1]] + c <- compact (m1,m2) + print (length (show (getCompact c))) + print =<< compactSize c + c <- compactWithSharing (m1,m2) + print (length (show (getCompact c))) + print =<< compactSize c diff --git a/libraries/compact/tests/compact_share.stdout b/libraries/compact/tests/compact_share.stdout new file mode 100644 index 0000000000..0969fdf956 --- /dev/null +++ b/libraries/compact/tests/compact_share.stdout @@ -0,0 +1,4 @@ +275599 +3801088 +275599 +2228224 diff --git a/libraries/compact/tests/compact_simple.hs b/libraries/compact/tests/compact_simple.hs index c4cfbbd151..83b24da4e7 100644 --- a/libraries/compact/tests/compact_simple.hs +++ b/libraries/compact/tests/compact_simple.hs @@ -18,7 +18,7 @@ assertEquals expected actual = test func = do let val = ("hello", 1, 42, 42, Just 42) :: (String, Int, Int, Integer, Maybe Int) - str <- func 4096 val + str <- func val -- check that val is still good assertEquals ("hello", 1, 42, 42, Just 42) val @@ -30,6 +30,8 @@ test func = do -- check again the value in the compact assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str) + print =<< compactSize str + main = do - test newCompact - test newCompactNoShare + test compactWithSharing + test compact diff --git a/libraries/compact/tests/compact_simple.stdout b/libraries/compact/tests/compact_simple.stdout new file mode 100644 index 0000000000..5549a58580 --- /dev/null +++ b/libraries/compact/tests/compact_simple.stdout @@ -0,0 +1,2 @@ +32768 +32768 diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs index 7b194867de..69421c5137 100644 --- a/libraries/compact/tests/compact_simple_array.hs +++ b/libraries/compact/tests/compact_simple_array.hs @@ -11,6 +11,7 @@ import qualified Data.Array.Unboxed as U import Control.DeepSeq import Data.Compact +import Data.Compact.Internal assertFail :: String -> IO () assertFail msg = throwIO $ AssertionFailed msg @@ -45,7 +46,7 @@ test func = do unboxedFrozen = runSTUArray arrTest let val = (fromList, frozen, stFrozen, unboxedFrozen) - str <- func 4096 val + str <- func val -- check that val is still good assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val @@ -56,5 +57,5 @@ test func = do assertEquals val (getCompact str) main = do - test newCompact - test newCompactNoShare + test (compactSized 4096 True) + test (compactSized 4096 False) diff --git a/libraries/compact/tests/compact_threads.hs b/libraries/compact/tests/compact_threads.hs new file mode 100644 index 0000000000..99d6fe2409 --- /dev/null +++ b/libraries/compact/tests/compact_threads.hs @@ -0,0 +1,21 @@ +import Control.Concurrent +import Control.Monad +import Data.Compact +import Data.Compact.Internal +import qualified Data.Map as Map +import Data.Maybe +import System.Environment + +main = do + [n] <- map read <$> getArgs + c <- compact () + as <- forM [1..(n::Int)] $ \i -> async (compactAdd c (Just i)) + bs <- forM as $ \a -> async (getCompact <$> takeMVar a) + xs <- mapM takeMVar bs + print (sum (catMaybes xs)) + +async :: IO a -> IO (MVar a) +async io = do + m <- newEmptyMVar + forkIO (io >>= putMVar m) + return m diff --git a/libraries/compact/tests/compact_threads.stdout b/libraries/compact/tests/compact_threads.stdout new file mode 100644 index 0000000000..837e12b406 --- /dev/null +++ b/libraries/compact/tests/compact_threads.stdout @@ -0,0 +1 @@ +500500 diff --git a/rts/Compact.cmm b/rts/Compact.cmm new file mode 100644 index 0000000000..fe54d2ad39 --- /dev/null +++ b/rts/Compact.cmm @@ -0,0 +1,437 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2015-2016 + * + * Support for compact regions. See Note [Compact Normal Forms] in + * rts/sm/CNF.c + * + * ---------------------------------------------------------------------------*/ + +#include "Cmm.h" +#include "sm/ShouldCompact.h" + + +// +// compactAddWithSharing# +// :: State# RealWorld +// -> Compact# +// -> a +// -> (# State# RealWorld, a #) +// +stg_compactAddWithSharingzh (P_ compact, P_ p) +{ + W_ hash; + ASSERT(StgCompactNFData_hash(compact) == NULL); + (hash) = ccall allocHashTable(); + StgCompactNFData_hash(compact) = hash; + + // Note [compactAddWorker result] + // + // compactAddWorker needs somewhere to store the result - this is + // so that it can be tail-recursive. It must be an address that + // doesn't move during GC, so we can't use heap or stack. + // Therefore we have a special field in the StgCompactNFData + // object to hold the final result of compaction. + W_ pp; + pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result; + call stg_compactAddWorkerzh(compact, p, pp); + ccall freeHashTable(StgCompactNFData_hash(compact), NULL); + StgCompactNFData_hash(compact) = NULL; +#ifdef DEBUG + ccall verifyCompact(compact); +#endif + return (P_[pp]); +} + + +// +// compactAdd# +// :: State# RealWorld +// -> Compact# +// -> a +// -> (# State# RealWorld, a #) +// +stg_compactAddzh (P_ compact, P_ p) +{ + ASSERT(StgCompactNFData_hash(compact) == NULL); + + W_ pp; // See Note [compactAddWorker result] + pp = compact + SIZEOF_StgHeader + OFFSET_StgCompactNFData_result; + call stg_compactAddWorkerzh(compact, p, pp); +#ifdef DEBUG + ccall verifyCompact(compact); +#endif + return (P_[pp]); +} + + +// +// Allocate space for a new object in the compact region. We first try +// the fast method using the hp/hpLim fields of StgCompactNFData, and +// if that fails we fall back to calling allocateForCompact() which +// will append a new block if necessary. +// +#define ALLOCATE(compact,sizeW,p,to, tag) \ + hp = StgCompactNFData_hp(compact); \ + if (hp + WDS(sizeW) <= StgCompactNFData_hpLim(compact)) { \ + to = hp; \ + StgCompactNFData_hp(compact) = hp + WDS(sizeW); \ + } else { \ + ("ptr" to) = ccall allocateForCompact( \ + MyCapability() "ptr", compact "ptr", sizeW); \ + } \ + if (StgCompactNFData_hash(compact) != NULL) { \ + ccall insertCompactHash(MyCapability(), compact, p, tag | to); \ + } + + +// +// Look up a pointer in the hash table if we're doing sharing. +// +#define CHECK_HASH() \ + hash = StgCompactNFData_hash(compact); \ + if (hash != NULL) { \ + ("ptr" hashed) = ccall lookupHashTable(hash "ptr", p "ptr"); \ + if (hashed != NULL) { \ + P_[pp] = hashed; \ + return (); \ + } \ + } + +// +// Evacuate and copy an object and its transitive closure into a +// compact. This function is called recursively as we traverse the +// data structure. It takes the location to store the address of the +// compacted object as an argument, so that it can be tail-recursive. +// +stg_compactAddWorkerzh ( + P_ compact, // The Compact# object + P_ p, // The object to compact + W_ pp) // Where to store a pointer to the compacted object +{ + W_ type, info, should, hash, hp, tag; + P_ p; + P_ hashed; + + again: MAYBE_GC(again); + STK_CHK_GEN(); + +eval: + tag = GETTAG(p); + p = UNTAG(p); + info = %INFO_PTR(p); + type = TO_W_(%INFO_TYPE(%STD_INFO(info))); + + switch [0 .. N_CLOSURE_TYPES] type { + + // Unevaluated things must be evaluated first: + case + THUNK, + THUNK_1_0, + THUNK_0_1, + THUNK_2_0, + THUNK_1_1, + THUNK_0_2, + THUNK_STATIC, + AP, + AP_STACK, + BLACKHOLE, + THUNK_SELECTOR : { + (P_ evald) = call %ENTRY_CODE(info) (p); + p = evald; + goto eval; + } + + // Follow indirections: + case IND, IND_STATIC: { + p = StgInd_indirectee(p); + goto eval; + } + + // Mutable things are not allowed: + case + MVAR_CLEAN, + MVAR_DIRTY, + TVAR, + MUT_ARR_PTRS_CLEAN, + MUT_ARR_PTRS_DIRTY, + MUT_ARR_PTRS_CLEAN, + MUT_VAR_CLEAN, + MUT_VAR_DIRTY, + WEAK, + PRIM, + MUT_PRIM, + TSO, + STACK, + TREC_CHUNK, + WHITEHOLE, + SMALL_MUT_ARR_PTRS_CLEAN, + SMALL_MUT_ARR_PTRS_DIRTY, + COMPACT_NFDATA: { + jump stg_raisezh(base_GHCziIOziException_cannotCompactMutable_closure); + } + + // We shouldn't see any functions, if this data structure was NFData. + case + FUN, + FUN_1_0, + FUN_0_1, + FUN_2_0, + FUN_1_1, + FUN_0_2, + FUN_STATIC, + BCO, + PAP: { + jump stg_raisezh(base_GHCziIOziException_cannotCompactFunction_closure); + } + + case ARR_WORDS: { + + (should) = ccall shouldCompact(compact "ptr", p "ptr"); + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + if (should == SHOULDCOMPACT_PINNED) { + jump stg_raisezh(base_GHCziIOziException_cannotCompactPinned_closure); + } + + CHECK_HASH(); + + P_ to; + W_ size; + size = SIZEOF_StgArrBytes + StgArrBytes_bytes(p); + ALLOCATE(compact, ROUNDUP_BYTES_TO_WDS(size), p, to, tag); + P_[pp] = to; + prim %memcpy(to, p, size, 1); + return(); + } + + case + MUT_ARR_PTRS_FROZEN0, + MUT_ARR_PTRS_FROZEN: { + + (should) = ccall shouldCompact(compact "ptr", p "ptr"); + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + + CHECK_HASH(); + + W_ i, size, cards, ptrs; + size = SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_size(p)); + ptrs = StgMutArrPtrs_ptrs(p); + cards = SIZEOF_StgMutArrPtrs + WDS(ptrs); + ALLOCATE(compact, BYTES_TO_WDS(size), p, to, tag); + P_[pp] = tag | to; + SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p)); + StgMutArrPtrs_ptrs(to) = ptrs; + StgMutArrPtrs_size(to) = StgMutArrPtrs_size(p); + prim %memcpy(to + cards, p + cards , size - cards, 1); + i = 0; + loop0: + if (i < ptrs) { + W_ q; + q = to + SIZEOF_StgMutArrPtrs + WDS(i); + call stg_compactAddWorkerzh( + compact, P_[p + SIZEOF_StgMutArrPtrs + WDS(i)], q); + i = i + 1; + goto loop0; + } + return(); + } + + case + SMALL_MUT_ARR_PTRS_FROZEN0, + SMALL_MUT_ARR_PTRS_FROZEN: { + // (P_ to) = allocateForCompact(cap, compact, size); + // use prim memcpy + ccall barf("stg_compactAddWorkerzh: TODO: SMALL_MUT_ARR_PTRS"); + } + + // Everything else we should copy and evaluate the components: + case + CONSTR, + CONSTR_1_0, + CONSTR_2_0, + CONSTR_1_1: { + + (should) = ccall shouldCompact(compact "ptr", p "ptr"); + if (should == SHOULDCOMPACT_IN_CNF) { P_[pp] = p; return(); } + + constructor: + + CHECK_HASH(); + + W_ i, ptrs, nptrs, size; + P_ to; + ptrs = TO_W_(%INFO_PTRS(%STD_INFO(info))); + nptrs = TO_W_(%INFO_NPTRS(%STD_INFO(info))); + size = BYTES_TO_WDS(SIZEOF_StgHeader) + ptrs + nptrs; + + ALLOCATE(compact, size, p, to, tag); + P_[pp] = tag | to; + SET_HDR(to, StgHeader_info(p), StgHeader_ccs(p)); + + // First, copy the non-pointers + if (nptrs > 0) { + i = ptrs; + loop1: + StgClosure_payload(to,i) = StgClosure_payload(p,i); + i = i + 1; + if (i < ptrs + nptrs) goto loop1; + } + + // Next, recursively compact and copy the pointers + if (ptrs == 0) { return(); } + i = 0; + loop2: + W_ q; + q = to + SIZEOF_StgHeader + OFFSET_StgClosure_payload + WDS(i); + // Tail-call the last one. This means we don't build up a deep + // stack when compacting lists. + if (i == ptrs - 1) { + jump stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q); + } + call stg_compactAddWorkerzh(compact, StgClosure_payload(p,i), q); + i = i + 1; + goto loop2; + } + + // these might be static closures that we can avoid copying into + // the compact if they don't refer to CAFs. + case + CONSTR_0_1, + CONSTR_0_2, + CONSTR_NOCAF: { + + (should) = ccall shouldCompact(compact "ptr", p "ptr"); + if (should == SHOULDCOMPACT_IN_CNF || + should == SHOULDCOMPACT_STATIC) { P_[pp] = p; return(); } + + goto constructor; + }} + + ccall barf("stg_compactWorkerzh"); +} + +stg_compactSizzezh (P_ compact) +{ + return (StgCompactNFData_totalW(compact) * SIZEOF_W); +} + +stg_compactNewzh ( W_ size ) +{ + P_ str; + + again: MAYBE_GC(again); + + ("ptr" str) = ccall compactNew(MyCapability() "ptr", size); + return (str); +} + +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); + + // We have to save Hp back to the nursery, otherwise the size will + // be wrong. + bd = Bdescr(StgCompactNFData_nursery(str)); + bdescr_free(bd) = StgCompactNFData_hp(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); +} + diff --git a/rts/Hash.c b/rts/Hash.c index 1f8c0ca00c..8f32ac3076 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -198,9 +198,11 @@ lookupHashTable(const HashTable *table, StgWord key) segment = bucket / HSEGSIZE; index = bucket % HSEGSIZE; - for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) - if (table->compare(hl->key, key)) + CompareFunction *cmp = table->compare; + for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) { + if (cmp(hl->key, key)) return (void *) hl->data; + } /* It's not there */ return NULL; @@ -374,6 +376,33 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) ) } /* ----------------------------------------------------------------------------- + * Map a function over all the keys/values in a HashTable + * -------------------------------------------------------------------------- */ + +void +mapHashTable(HashTable *table, void *data, MapHashFn fn) +{ + long segment; + long index; + HashList *hl; + + /* The last bucket with something in it is table->max + table->split - 1 */ + segment = (table->max + table->split - 1) / HSEGSIZE; + index = (table->max + table->split - 1) % HSEGSIZE; + + while (segment >= 0) { + while (index >= 0) { + for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) { + fn(data, hl->key, hl->data); + } + index--; + } + segment--; + index = HSEGSIZE - 1; + } +} + +/* ----------------------------------------------------------------------------- * When we initialize a hash table, we set up the first segment as well, * initializing all of the first segment's hash buckets to NULL. * -------------------------------------------------------------------------- */ diff --git a/rts/Hash.h b/rts/Hash.h index ebefd6f6c4..5d085b033c 100644 --- a/rts/Hash.h +++ b/rts/Hash.h @@ -33,6 +33,10 @@ int keyCountHashTable (HashTable *table); // int keysHashTable(HashTable *table, StgWord keys[], int szKeys); +typedef void (*MapHashFn)(void *data, StgWord key, const void *value); + +void mapHashTable(HashTable *table, void *data, MapHashFn fn); + /* Hash table access where the keys are C strings (the strings are * assumed to be allocated by the caller, and mustn't be deallocated * until the corresponding hash table entry has been removed). diff --git a/rts/Prelude.h b/rts/Prelude.h index 0186b5092b..f34a69c1c9 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -42,6 +42,9 @@ PRELUDE_CLOSURE(base_GHCziIOziException_allocationLimitExceeded_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnThrowTo_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure); +PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactFunction_closure); +PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactPinned_closure); +PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactMutable_closure); PRELUDE_CLOSURE(base_ControlziExceptionziBase_nonTermination_closure); PRELUDE_CLOSURE(base_ControlziExceptionziBase_nestedAtomically_closure); PRELUDE_CLOSURE(base_GHCziEventziThread_blockedOnBadFD_closure); @@ -92,6 +95,9 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define allocationLimitExceeded_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_allocationLimitExceeded_closure) #define blockedIndefinitelyOnMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure) #define blockedIndefinitelyOnSTM_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure) +#define cannotCompactFunction_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_cannotCompactFunction_closure) +#define cannotCompactPinned_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_cannotCompactPinned_closure) +#define cannotCompactMutable_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_cannotCompactMutable_closure) #define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure) #define nestedAtomically_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure) #define blockedOnBadFD_closure DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure) diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4cc0dccbbc..d6cdb3d535 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1925,137 +1925,6 @@ 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 5d6e585eff..f23e0b0636 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -387,7 +387,7 @@ printClosure( const StgClosure *obj ) case COMPACT_NFDATA: debugBelch("COMPACT_NFDATA(size=%" FMT_Word ")\n", - (W_)((StgCompactNFData *)obj)->totalDataW * sizeof(W_)); + (W_)((StgCompactNFData *)obj)->totalW * sizeof(W_)); break; diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index b8f0b212f0..1368082730 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -178,6 +178,7 @@ void initRtsFlagsDefaults(void) RtsFlags.DebugFlags.hpc = false; RtsFlags.DebugFlags.sparks = false; RtsFlags.DebugFlags.numa = false; + RtsFlags.DebugFlags.compact = false; #if defined(PROFILING) RtsFlags.CcFlags.doCostCentres = 0; @@ -385,6 +386,7 @@ usage_text[] = { " -Dz DEBUG: stack squeezing", " -Dc DEBUG: program coverage", " -Dr DEBUG: sparks", +" -DC DEBUG: compact", "", " NOTE: DEBUG events are sent to stderr by default; add -l to create a", " binary event log file instead.", @@ -1664,6 +1666,9 @@ static void read_debug_flags(const char* arg) case 'r': RtsFlags.DebugFlags.sparks = true; break; + case 'C': + RtsFlags.DebugFlags.compact = true; + break; default: bad_option( arg ); } diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index e4e8857989..dd4efa69e0 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -201,6 +201,9 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) getStablePtr((StgPtr)nonTermination_closure); getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure); getStablePtr((StgPtr)allocationLimitExceeded_closure); + getStablePtr((StgPtr)cannotCompactFunction_closure); + getStablePtr((StgPtr)cannotCompactPinned_closure); + getStablePtr((StgPtr)cannotCompactMutable_closure); getStablePtr((StgPtr)nestedAtomically_closure); getStablePtr((StgPtr)runSparks_closure); diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 4f618df33d..6dc0b6f8f7 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -533,8 +533,9 @@ SymI_HasProto(stg_catchSTMzh) \ SymI_HasProto(stg_checkzh) \ SymI_HasProto(stg_clearCCSzh) \ + SymI_HasProto(stg_compactAddWithSharingzh) \ + SymI_HasProto(stg_compactAddzh) \ SymI_HasProto(stg_compactNewzh) \ - SymI_HasProto(stg_compactAppendzh) \ SymI_HasProto(stg_compactResizzezh) \ SymI_HasProto(stg_compactContainszh) \ SymI_HasProto(stg_compactContainsAnyzh) \ @@ -542,6 +543,7 @@ SymI_HasProto(stg_compactGetNextBlockzh) \ SymI_HasProto(stg_compactAllocateBlockzh) \ SymI_HasProto(stg_compactFixupPointerszh) \ + SymI_HasProto(stg_compactSizzezh) \ SymI_HasProto(closure_flags) \ SymI_HasProto(cmp_thread) \ SymI_HasProto(createAdjustor) \ diff --git a/rts/Stats.c b/rts/Stats.c index 95511f2c35..767a36fd96 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -817,7 +817,7 @@ stat_exit (void) void statDescribeGens(void) { - uint32_t g, mut, lge, i; + uint32_t g, mut, lge, compacts, i; W_ gen_slop; W_ tot_live, tot_slop; W_ gen_live, gen_blocks; @@ -825,10 +825,10 @@ statDescribeGens(void) generation *gen; debugBelch( -"----------------------------------------------------------\n" -" Gen Max Mut-list Blocks Large Live Slop\n" -" Blocks Bytes Objects \n" -"----------------------------------------------------------\n"); +"----------------------------------------------------------------------\n" +" Gen Max Mut-list Blocks Large Compacts Live Slop\n" +" Blocks Bytes Objects \n" +"----------------------------------------------------------------------\n"); tot_live = 0; tot_slop = 0; @@ -840,6 +840,10 @@ statDescribeGens(void) lge++; } + for (bd = gen->compact_objects, compacts = 0; bd; bd = bd->link) { + compacts++; + } + gen_live = genLiveWords(gen); gen_blocks = genLiveBlocks(gen); @@ -862,15 +866,15 @@ statDescribeGens(void) gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live; - debugBelch("%8" FMT_Word " %8d %8" FMT_Word " %8" FMT_Word "\n", gen_blocks, lge, + debugBelch("%8" FMT_Word " %8d %8d %9" FMT_Word " %9" FMT_Word "\n", gen_blocks, lge, compacts, gen_live*(W_)sizeof(W_), gen_slop*(W_)sizeof(W_)); tot_live += gen_live; tot_slop += gen_slop; } - debugBelch("----------------------------------------------------------\n"); - debugBelch("%41s%8" FMT_Word " %8" FMT_Word "\n", + debugBelch("----------------------------------------------------------------------\n"); + debugBelch("%51s%9" FMT_Word " %9" FMT_Word "\n", "",tot_live*sizeof(W_),tot_slop*sizeof(W_)); - debugBelch("----------------------------------------------------------\n"); + debugBelch("----------------------------------------------------------------------\n"); debugBelch("\n"); } diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 86771aeba0..aa22c99be4 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -619,14 +619,19 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE /* ---------------------------------------------------------------------------- COMPACT_NFDATA (a blob of data in NF with no outgoing pointers) - Just return immediately because the structure is in NF already + See Note [Compact Normal Forms] in sm/CNF.c + + CLEAN/DIRTY refer to the state of the "hash" field: DIRTY means that + compaction is in progress and the hash table needs to be scanned by the GC. ------------------------------------------------------------------------- */ -INFO_TABLE( stg_COMPACT_NFDATA, 0, 0, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") +INFO_TABLE( stg_COMPACT_NFDATA_CLEAN, 0, 5, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") () -{ - return (); -} +{ foreign "C" barf("COMPACT_NFDATA_CLEAN object entered!") never returns; } + +INFO_TABLE( stg_COMPACT_NFDATA_DIRTY, 0, 5, COMPACT_NFDATA, "COMPACT_NFDATA", "COMPACT_NFDATA") + () +{ foreign "C" barf("COMPACT_NFDATA_DIRTY object entered!") never returns; } /* ---------------------------------------------------------------------------- CHARLIKE and INTLIKE closures. diff --git a/rts/Trace.h b/rts/Trace.h index ccdad7a06c..383c4099dd 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -62,6 +62,7 @@ enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM, #define DEBUG_squeeze RtsFlags.DebugFlags.squeeze #define DEBUG_hpc RtsFlags.DebugFlags.hpc #define DEBUG_sparks RtsFlags.DebugFlags.sparks +#define DEBUG_compact RtsFlags.DebugFlags.compact // events extern int TRACE_sched; diff --git a/rts/package.conf.in b/rts/package.conf.in index 1da44a4cd1..338fcb1abf 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -98,6 +98,9 @@ ld-options: , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" , "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure" + , "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure" + , "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure" + , "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure" , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure" @@ -190,6 +193,9 @@ ld-options: , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" , "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure" + , "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure" + , "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure" + , "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure" , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure" diff --git a/rts/sm/CNF.c b/rts/sm/CNF.c index 2eb7cd208a..7dfaced7ef 100644 --- a/rts/sm/CNF.c +++ b/rts/sm/CNF.c @@ -22,6 +22,8 @@ #include "Hash.h" #include "HeapAlloc.h" #include "BlockAlloc.h" +#include "Trace.h" +#include "sm/ShouldCompact.h" #ifdef HAVE_UNISTD_H #include <unistd.h> @@ -30,60 +32,122 @@ #include <limits.h> #endif -/** - * 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. - */ +/* + Note [Compact Normal Forms] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + A compact normal form (CNF) is a region of memory containing one or more + Haskell data structures. The goals are: + + * The CNF lives or dies as a single unit as far as the GC is concerned. The + GC does not traverse the data inside the CNF. + + * A CNF can be "serialized" (stored on disk or transmitted over a network). + To "deserialize", all we need to do is adjust the addresses of the pointers + within the CNF ("fixup"), Deserializing can only be done in the context of + the same Haskell binary that produced the CNF. + + Structure + ~~~~~~~~~ + + * In Data.Compact.Internal we have + data Compact a = Compact Compact# a + + * The Compact# primitive object is operated on by the primitives. + + * A single CNF looks like this: + + .---------, .-------------------------------. ,------------- + | Compact | ,--+-> StgCompactNFDataBlock | ,--->| StgCompac... + +---------+ `--+--- self | | | self + | .----+-. ,--+--- owner | | | wner + +---------+ | | | next ----------------------+---' | next --------> + | . | | | |-------------------------------+ +------------- + `----+----' `--+--+-> StgCompactNFData (Compact#) | | more data... + | | totalW | | + | | autoblockW | | + | | nursery | | + | | hash | | + | | last | | + | |-------------------------------| | + `------------+--> data ... | | + | | | + | | | + `-------------------------------' `------------- + + * Each block in a CNF starts with a StgCompactNFDataBlock header + + * The blocks in a CNF are chained through the next field + + * Multiple CNFs are chained together using the bdescr->link and bdescr->u.prev + fields of the bdescr. + + * The first block of a CNF (only) contains the StgCompactNFData (aka + Compact#), right after the StgCompactNFDataBlock header. + + * The data inside a CNF block is ordinary closures + + * During compaction (with sharing enabled) the hash field points to + a HashTable mapping heap addresses outside the compact to + addresses within it. If a GC strikes during compaction, this + HashTable must be scanned by the GC. + + Invariants + ~~~~~~~~~~ + + (1) A CNF is self-contained. The data within it does not have any external + pointers. EXCEPT: pointers to static constructors that are guaranteed to + never refer (directly or indirectly) to CAFs are allowed, because the + garbage collector does not have to track or follow these. + + (2) A CNF contains only immutable data: no THUNKS, FUNs, or mutable + objects. This helps maintain invariant (1). + + Details + ~~~~~~~ + + 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, @@ -200,12 +264,14 @@ firstBlockGetCompact(StgCompactNFDataBlock *block) return (StgCompactNFData*) ((W_)block + sizeof(StgCompactNFDataBlock)); } -static void -freeBlockChain(StgCompactNFDataBlock *block) +void +compactFree(StgCompactNFData *str) { - StgCompactNFDataBlock *next; + StgCompactNFDataBlock *block, *next; bdescr *bd; + block = compactGetFirstBlock(str); + for ( ; block; block = next) { next = block->next; bd = Bdescr((StgPtr)block); @@ -215,15 +281,6 @@ freeBlockChain(StgCompactNFDataBlock *block) } void -compactFree(StgCompactNFData *str) -{ - StgCompactNFDataBlock *block; - - block = compactGetFirstBlock(str); - freeBlockChain(block); -} - -void compactMarkKnown(StgCompactNFData *str) { bdescr *bd; @@ -261,6 +318,40 @@ countCompactBlocks(bdescr *outer) return count; } +#ifdef DEBUG +// Like countCompactBlocks, but adjusts the size so each mblock is assumed to +// only contain BLOCKS_PER_MBLOCK blocks. Used in memInventory(). +StgWord +countAllocdCompactBlocks(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; + // See BlockAlloc.c:countAllocdBlocks() + if (inner->blocks > BLOCKS_PER_MBLOCK) { + count -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK) + * (inner->blocks/(MBLOCK_SIZE/BLOCK_SIZE)); + } + block = block->next; + } while(block); + + outer = outer->link; + } + + return count; +} +#endif + StgCompactNFData * compactNew (Capability *cap, StgWord size) { @@ -269,8 +360,11 @@ compactNew (Capability *cap, StgWord size) StgCompactNFData *self; bdescr *bd; - aligned_size = BLOCK_ROUND_UP(size + sizeof(StgCompactNFDataBlock) + aligned_size = BLOCK_ROUND_UP(size + sizeof(StgCompactNFData) + sizeof(StgCompactNFDataBlock)); + + // Don't allow sizes larger than a megablock, because we can't use the + // memory after the first mblock for storing objects. if (aligned_size >= BLOCK_SIZE * BLOCKS_PER_MBLOCK) aligned_size = BLOCK_SIZE * BLOCKS_PER_MBLOCK; @@ -278,20 +372,23 @@ compactNew (Capability *cap, StgWord size) ALLOCATE_NEW); self = firstBlockGetCompact(block); - SET_INFO((StgClosure*)self, &stg_COMPACT_NFDATA_info); - self->totalDataW = aligned_size / sizeof(StgWord); + SET_HDR((StgClosure*)self, &stg_COMPACT_NFDATA_CLEAN_info, CCS_SYSTEM); self->autoBlockW = aligned_size / sizeof(StgWord); self->nursery = block; self->last = block; + self->hash = NULL; block->owner = self; bd = Bdescr((P_)block); bd->free = (StgPtr)((W_)self + sizeof(StgCompactNFData)); - ASSERT (bd->free == (StgPtr)self + sizeofW(StgCompactNFData)); + self->hp = bd->free; + self->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W; self->totalW = bd->blocks * BLOCK_SIZE_W; + debugTrace(DEBUG_compact, "compactNew: size %" FMT_Word, size); + return self; } @@ -312,9 +409,6 @@ compactAppendBlock (Capability *cap, 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)); @@ -331,94 +425,27 @@ compactResize (Capability *cap, StgCompactNFData *str, StgWord new_size) StgWord aligned_size; aligned_size = BLOCK_ROUND_UP(new_size + sizeof(StgCompactNFDataBlock)); + + // Don't allow sizes larger than a megablock, because we can't use the + // memory after the first mblock for storing objects. 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 bool -allocate_in_compact (StgCompactNFDataBlock *block, StgWord sizeW, StgPtr *at) +STATIC_INLINE bool +has_room_for (bdescr *bd, StgWord sizeW) { - bdescr *bd; - StgPtr top; - StgPtr free; - - bd = Bdescr((StgPtr)block); - top = bd->start + BLOCK_SIZE_W * bd->blocks; - if (bd->free + sizeW > top) - return false; - - free = bd->free; - bd->free += sizeW; - *at = free; - - return true; + return (bd->free < bd->start + BLOCK_SIZE_W * BLOCKS_PER_MBLOCK + && bd->free + sizeW <= bd->start + BLOCK_SIZE_W * bd->blocks); } static bool 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 @@ -427,301 +454,207 @@ block_is_full (StgCompactNFDataBlock *block) // 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); + + bd = Bdescr((StgPtr)block); + return (!has_room_for(bd,7)); } -static bool -allocate_loop (Capability *cap, - StgCompactNFData *str, - StgWord sizeW, - StgPtr *at) +void * +allocateForCompact (Capability *cap, + StgCompactNFData *str, + StgWord sizeW) { - StgCompactNFDataBlock *block; + StgPtr to; StgWord next_size; + StgCompactNFDataBlock *block; + bdescr *bd; + + ASSERT(str->nursery != NULL); + ASSERT(str->hp > Bdescr((P_)str->nursery)->start); + ASSERT(str->hp <= Bdescr((P_)str->nursery)->start + + Bdescr((P_)str->nursery)->blocks * BLOCK_SIZE_W); - // try the nursery first retry: - if (str->nursery != NULL) { - if (allocate_in_compact(str->nursery, sizeW, at)) - return true; + if (str->hp + sizeW < str->hpLim) { + to = str->hp; + str->hp += sizeW; + return to; + } + + bd = Bdescr((P_)str->nursery); + bd->free = str->hp; - if (block_is_full (str->nursery)) { + // We know it doesn't fit in the nursery + // if it is a large object, allocate a new block + if (sizeW > LARGE_OBJECT_THRESHOLD/sizeof(W_)) { + next_size = BLOCK_ROUND_UP(sizeW*sizeof(W_) + + sizeof(StgCompactNFData)); + block = compactAppendBlock(cap, str, next_size); + bd = Bdescr((P_)block); + to = bd->free; + bd->free += sizeW; + return to; + } + + // move the nursery past full blocks + if (block_is_full (str->nursery)) { + do { str->nursery = str->nursery->next; - goto retry; - } + } while (str->nursery && block_is_full(str->nursery)); - // try subsequent blocks - block = str->nursery->next; - while (block != NULL) { - if (allocate_in_compact(block, sizeW, at)) - return true; + if (str->nursery == NULL) { + str->nursery = compactAppendBlock(cap, str, + str->autoBlockW * sizeof(W_)); + } + bd = Bdescr((P_)str->nursery); + str->hp = bd->free; + str->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W; + goto retry; + } - block = block->next; + // try subsequent blocks + for (block = str->nursery->next; block != NULL; block = block->next) { + bd = Bdescr((P_)block); + if (has_room_for(bd,sizeW)) { + to = bd->free; + bd->free += sizeW; + return to; } } + // If all else fails, allocate a new block of the right size. next_size = stg_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 false; + BLOCK_ROUND_UP(sizeW * sizeof(StgWord) + + sizeof(StgCompactNFDataBlock))); block = compactAppendBlock(cap, str, next_size); - ASSERT (str->nursery != NULL); - return allocate_in_compact(block, sizeW, at); + bd = Bdescr((P_)block); + to = bd->free; + bd->free += sizeW; + return to; } -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; +void +insertCompactHash (Capability *cap, + StgCompactNFData *str, + StgClosure *p, StgClosure *to) +{ + insertHashTable(str->hash, (StgWord)p, (const void*)to); + if (str->header.info == &stg_COMPACT_NFDATA_CLEAN_info) { + str->header.info = &stg_COMPACT_NFDATA_DIRTY_info; + recordClosureMutated(cap, (StgClosure*)str); } - - // 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 bool -object_in_compact (StgCompactNFData *str, StgClosure *p) + +StgWord +compactContains (StgCompactNFData *str, StgPtr what) { bdescr *bd; - if (!HEAP_ALLOCED(p)) - return false; + // This check is the reason why this needs to be + // implemented in C instead of (possibly faster) Cmm + if (!HEAP_ALLOCED (what)) + return 0; - bd = Bdescr((P_)p); + // 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 && - objectGetCompact(p) == str; + (str == NULL || objectGetCompact((StgClosure*)what) == str); } -static void -simple_evacuate (Capability *cap, - StgCompactNFData *str, - HashTable *hash, - StgClosure **p) +StgCompactNFDataBlock * +compactAllocateBlock(Capability *cap, + StgWord size, + StgCompactNFDataBlock *previous) { - 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; - } + StgWord aligned_size; + StgCompactNFDataBlock *block; + bdescr *bd; - *p = from; - return simple_evacuate(cap, str, hash, p); + aligned_size = BLOCK_ROUND_UP(size); - 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); + // 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!) - 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; - } + // 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 - copy_tag(cap, str, hash, p, from, tag); - } -} + block = compactAllocateBlockInternal(cap, aligned_size, NULL, + previous != NULL ? ALLOCATE_IMPORT_APPEND : ALLOCATE_IMPORT_NEW); + if (previous != NULL) + previous->next = block; -static void -simple_scavenge_mut_arr_ptrs (Capability *cap, - StgCompactNFData *str, - HashTable *hash, - StgMutArrPtrs *a) -{ - StgPtr p, q; + bd = Bdescr((P_)block); + bd->free = (P_)((W_)bd->start + size); - p = (StgPtr)&a->payload[0]; - q = (StgPtr)&a->payload[a->ptrs]; - for (; p < q; p++) { - simple_evacuate(cap, str, hash, (StgClosure**)p); - } + return block; } -static void -simple_scavenge_block (Capability *cap, - StgCompactNFData *str, - StgCompactNFDataBlock *block, - HashTable *hash, - StgPtr p) +// +// shouldCompact(c,p): returns: +// SHOULDCOMPACT_IN_CNF if the object is in c +// SHOULDCOMPACT_STATIC if the object is static +// SHOULDCOMPACT_NOTIN_CNF if the object is dynamic and not in c +// +StgWord shouldCompact (StgCompactNFData *str, StgClosure *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: - { - 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; - } + bdescr *bd; - case IND: - case BLACKHOLE: - case IND_STATIC: - // They get shortcircuited by simple_evaluate() - barf("IND/BLACKHOLE in Compact"); - break; + if (!HEAP_ALLOCED(p)) + return SHOULDCOMPACT_STATIC; // we have to copy static closures too - default: - barf("Invalid non-NFData closure in Compact\n"); - } + bd = Bdescr((P_)p); + if (bd->flags & BF_PINNED) { + return SHOULDCOMPACT_PINNED; } -} - -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)); + if ((bd->flags & BF_COMPACT) && objectGetCompact(p) == str) { + return SHOULDCOMPACT_IN_CNF; + } else { + return SHOULDCOMPACT_NOTIN_CNF; } } +/* ----------------------------------------------------------------------------- + Sanity-checking a compact + -------------------------------------------------------------------------- */ + #ifdef DEBUG -static bool -objectIsWHNFData (StgClosure *what) +STATIC_INLINE void +check_object_in_compact (StgCompactNFData *str, StgClosure *p) { - 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_NOCAF: - 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 true; + bdescr *bd; - case IND: - case BLACKHOLE: - return objectIsWHNFData(UNTAG_CLOSURE(((StgInd*)what)->indirectee)); + // Only certain static closures are allowed to be referenced from + // a compact, but let's be generous here and assume that all + // static closures are OK. + if (!HEAP_ALLOCED(p)) + return; - default: - return false; - } + bd = Bdescr((P_)p); + ASSERT((bd->flags & BF_COMPACT) != 0 && objectGetCompact(p) == str); } -static bool +static void verify_mut_arr_ptrs (StgCompactNFData *str, StgMutArrPtrs *a) { @@ -730,14 +663,13 @@ verify_mut_arr_ptrs (StgCompactNFData *str, 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 false; + check_object_in_compact(str, UNTAG_CLOSURE(*(StgClosure**)p)); } - return true; + return; } -static bool +static void verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) { bdescr *bd; @@ -750,24 +682,20 @@ verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) while (p < bd->free) { q = (StgClosure*)p; - if (!LOOKS_LIKE_CLOSURE_PTR(q)) - return false; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(q)); info = get_itbl(q); switch (info->type) { case CONSTR_1_0: - if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0]))) - return false; + check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0])); case CONSTR_0_1: p += sizeofW(StgClosure) + 1; break; case CONSTR_2_0: - if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[1]))) - return false; + check_object_in_compact(str, UNTAG_CLOSURE(q->payload[1])); case CONSTR_1_1: - if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[0]))) - return false; + check_object_in_compact(str, UNTAG_CLOSURE(q->payload[0])); case CONSTR_0_2: p += sizeofW(StgClosure) + 2; break; @@ -778,10 +706,9 @@ verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) { uint32_t i; - for (i = 0; i < info->layout.payload.ptrs; i++) - if (!object_in_compact(str, UNTAG_CLOSURE(q->payload[i]))) - return false; - + for (i = 0; i < info->layout.payload.ptrs; i++) { + check_object_in_compact(str, UNTAG_CLOSURE(q->payload[i])); + } p += sizeofW(StgClosure) + info->layout.payload.ptrs + info->layout.payload.nptrs; break; @@ -793,8 +720,7 @@ verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) case MUT_ARR_PTRS_FROZEN: case MUT_ARR_PTRS_FROZEN0: - if (!verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p)) - return false; + verify_mut_arr_ptrs(str, (StgMutArrPtrs*)p); p += mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); break; @@ -805,8 +731,7 @@ verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) StgSmallMutArrPtrs *arr = (StgSmallMutArrPtrs*)p; for (i = 0; i < arr->ptrs; i++) - if (!object_in_compact(str, UNTAG_CLOSURE(arr->payload[i]))) - return false; + check_object_in_compact(str, UNTAG_CLOSURE(arr->payload[i])); p += sizeofW(StgSmallMutArrPtrs) + arr->ptrs; break; @@ -817,126 +742,34 @@ verify_consistency_block (StgCompactNFData *str, StgCompactNFDataBlock *block) break; default: - return false; + barf("verify_consistency_block"); } } - return true; + return; } -static bool +static void verify_consistency_loop (StgCompactNFData *str) { StgCompactNFDataBlock *block; block = compactGetFirstBlock(str); do { - if (!verify_consistency_block(str, block)) - return false; + verify_consistency_block(str, block); block = block->next; } while (block && block->owner); - - return true; -} -#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) +void verifyCompact (StgCompactNFData *str USED_IF_DEBUG) { - 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); + IF_DEBUG(sanity, verify_consistency_loop(str)); } +#endif // DEBUG -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; -} +/* ----------------------------------------------------------------------------- + Fixing up pointers + -------------------------------------------------------------------------- */ STATIC_INLINE bool any_needs_fixup(StgCompactNFDataBlock *block) @@ -1036,10 +869,17 @@ fixup_one_pointer(StgWord *fixup_table, uint32_t count, StgClosure **p) StgClosure *q; StgCompactNFDataBlock *block; + q = *p; tag = GET_CLOSURE_TAG(q); q = UNTAG_CLOSURE(q); + // We can encounter a pointer outside the compact if it points to + // a static constructor that does not (directly or indirectly) + // reach any CAFs. (see Note [Compact Normal Forms]) + if (!HEAP_ALLOCED(q)) + return true; + block = find_pointer(fixup_table, count, q); if (block == NULL) return false; @@ -1247,11 +1087,9 @@ fixup_late(StgCompactNFData *str, StgCompactNFDataBlock *block) StgCompactNFDataBlock *nursery; bdescr *bd; StgWord totalW; - StgWord totalDataW; nursery = block; totalW = 0; - totalDataW = 0; do { block->self = block; @@ -1262,15 +1100,17 @@ fixup_late(StgCompactNFData *str, StgCompactNFDataBlock *block) if (bd->free != bd->start) nursery = block; block->owner = str; - totalDataW += bd->blocks * BLOCK_SIZE_W; } block = block->next; } while(block); str->nursery = nursery; + bd = Bdescr((P_)nursery); + str->hp = bd->free; + str->hpLim = bd->start + bd->blocks * BLOCK_SIZE_W; + str->totalW = totalW; - str->totalDataW = totalDataW; } static StgClosure * diff --git a/rts/sm/CNF.h b/rts/sm/CNF.h index b34d9c96c1..d888b0ce31 100644 --- a/rts/sm/CNF.h +++ b/rts/sm/CNF.h @@ -21,10 +21,6 @@ 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); @@ -34,12 +30,18 @@ StgWord compactContains(StgCompactNFData *str, StgPtr what); StgWord countCompactBlocks(bdescr *outer); +#ifdef DEBUG +StgWord countAllocdCompactBlocks(bdescr *outer); +#endif + StgCompactNFDataBlock *compactAllocateBlock(Capability *cap, StgWord size, StgCompactNFDataBlock *previous); StgPtr compactFixupPointers(StgCompactNFData *str, StgClosure *root); +// Go from an arbitrary pointer into any block of a compact chain, to the +// StgCompactNFDataBlock at the beginning of the block. INLINE_HEADER StgCompactNFDataBlock *objectGetCompactBlock (StgClosure *closure); INLINE_HEADER StgCompactNFDataBlock *objectGetCompactBlock (StgClosure *closure) { @@ -59,6 +61,8 @@ INLINE_HEADER StgCompactNFDataBlock *objectGetCompactBlock (StgClosure *closure) return (StgCompactNFDataBlock*)(head_block->start); } +// Go from an arbitrary pointer into any block of a compact chain, to the +// StgCompactNFData for the whole compact chain. INLINE_HEADER StgCompactNFData *objectGetCompact (StgClosure *closure); INLINE_HEADER StgCompactNFData *objectGetCompact (StgClosure *closure) { @@ -66,6 +70,16 @@ INLINE_HEADER StgCompactNFData *objectGetCompact (StgClosure *closure) return block->owner; } +extern void *allocateForCompact (Capability *cap, + StgCompactNFData *str, + StgWord sizeW); + +extern void insertCompactHash (Capability *cap, + StgCompactNFData *str, + StgClosure *p, StgClosure *to); + +extern void verifyCompact (StgCompactNFData *str); + #include "EndPrivate.h" #endif // SM_COMPACT_H diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 0581321205..e515c7b440 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -26,6 +26,7 @@ #include "Trace.h" #include "LdvProfile.h" #include "CNF.h" +#include "Scav.h" #if defined(PROF_SPIN) && defined(THREADED_RTS) && defined(PARALLEL_GC) StgWord64 whitehole_spin = 0; @@ -360,9 +361,9 @@ 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). + These are treated in a similar way to large objects. We remove the block + from the compact_objects list of the generation it is on, and link it onto + the live_compact_objects list of the destination generation. It is assumed that objects in the struct live in the same generation as the struct itself all the time. @@ -375,6 +376,9 @@ evacuate_compact (StgPtr p) generation *gen, *new_gen; uint32_t gen_no, new_gen_no; + // We need to find the Compact# corresponding to this pointer, because it + // will give us the first block in the compact chain, which is the one we + // that gets linked onto the compact_objects list. str = objectGetCompact((StgClosure*)p); ASSERT(get_itbl((StgClosure*)str)->type == COMPACT_NFDATA); @@ -411,7 +415,7 @@ evacuate_compact (StgPtr p) return; } - // remove from large_object list + // remove from compact_objects list if (bd->u.back) { bd->u.back->link = bd->link; } else { // first object in the list @@ -444,10 +448,16 @@ evacuate_compact (StgPtr p) 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); } + if (str->hash) { + gen_workspace *ws = &gct->gens[new_gen_no]; + bd->link = ws->todo_large_objects; + ws->todo_large_objects = bd; + } else { + 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); @@ -855,12 +865,6 @@ 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/Sanity.c b/rts/sm/Sanity.c index 5a2923820c..625b12ed17 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -273,6 +273,7 @@ checkClosure( const StgClosure* p ) case TVAR: case THUNK_STATIC: case FUN_STATIC: + case COMPACT_NFDATA: { uint32_t i; for (i = 0; i < info->layout.payload.ptrs; i++) { @@ -871,7 +872,8 @@ genBlocks (generation *gen) 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) + - gen->n_compact_blocks + gen->n_compact_blocks_in_import; + countAllocdCompactBlocks(gen->compact_objects) + + countAllocdCompactBlocks(gen->compact_blocks_in_import); } void diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 940f11fea4..10ce1e46a8 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -27,6 +27,7 @@ #include "Sanity.h" #include "Capability.h" #include "LdvProfile.h" +#include "Hash.h" #include "sm/MarkWeak.h" @@ -100,6 +101,45 @@ scavengeTSO (StgTSO *tso) gct->eager_promotion = saved_eager; } +/* ---------------------------------------------------------------------------- + Scavenging compact objects + ------------------------------------------------------------------------- */ + +static void +evacuate_hash_entry(HashTable *newHash, StgWord key, const void *value) +{ + StgClosure *p = (StgClosure*)key; + + evacuate(&p); + insertHashTable(newHash, (StgWord)p, value); +} + +static void +scavenge_compact(StgCompactNFData *str) +{ + bool saved_eager; + saved_eager = gct->eager_promotion; + gct->eager_promotion = false; + + if (str->hash) { + HashTable *newHash = allocHashTable(); + mapHashTable(str->hash, (void*)newHash, (MapHashFn)evacuate_hash_entry); + freeHashTable(str->hash, NULL); + str->hash = newHash; + } + + debugTrace(DEBUG_compact, + "compact alive @%p, gen %d, %" FMT_Word " bytes", + str, Bdescr((P_)str)->gen_no, str->totalW * sizeof(W_)) + + gct->eager_promotion = saved_eager; + if (gct->failed_to_evac) { + ((StgClosure *)str)->header.info = &stg_COMPACT_NFDATA_DIRTY_info; + } else { + ((StgClosure *)str)->header.info = &stg_COMPACT_NFDATA_CLEAN_info; + } +} + /* ----------------------------------------------------------------------------- Mutable arrays of pointers -------------------------------------------------------------------------- */ @@ -796,13 +836,6 @@ 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); @@ -1557,6 +1590,10 @@ scavenge_one(StgPtr p) #endif break; + case COMPACT_NFDATA: + scavenge_compact((StgCompactNFData*)p); + break; + default: barf("scavenge_one: strange object %d", (int)(info->type)); } @@ -1974,11 +2011,18 @@ scavenge_large (gen_workspace *ws) ws->todo_large_objects = bd->link; ACQUIRE_SPIN_LOCK(&ws->gen->sync); - dbl_link_onto(bd, &ws->gen->scavenged_large_objects); - ws->gen->n_scavenged_large_blocks += bd->blocks; + if (bd->flags & BF_COMPACT) { + dbl_link_onto(bd, &ws->gen->live_compact_objects); + StgCompactNFData *str = ((StgCompactNFDataBlock*)bd->start)->owner; + ws->gen->n_live_compact_blocks += str->totalW / BLOCK_SIZE_W; + p = (StgPtr)str; + } else { + dbl_link_onto(bd, &ws->gen->scavenged_large_objects); + ws->gen->n_scavenged_large_blocks += bd->blocks; + p = bd->start; + } RELEASE_SPIN_LOCK(&ws->gen->sync); - p = bd->start; if (scavenge_one(p)) { if (ws->gen->no > 0) { recordMutableGen_GC((StgClosure *)p, ws->gen->no); diff --git a/rts/sm/ShouldCompact.h b/rts/sm/ShouldCompact.h new file mode 100644 index 0000000000..a8ae85df51 --- /dev/null +++ b/rts/sm/ShouldCompact.h @@ -0,0 +1,26 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2016 + * + * 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_SHOULDCOMPACT_H +#define SM_SHOULDCOMPACT_H + +#define SHOULDCOMPACT_STATIC 0 +#define SHOULDCOMPACT_IN_CNF 1 +#define SHOULDCOMPACT_NOTIN_CNF 2 +#define SHOULDCOMPACT_PINNED 3 + +#ifndef CMINUSMINUS +extern StgWord shouldCompact (StgCompactNFData *str, StgClosure *p); +#endif + +#endif diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 70a5621806..a527e4f962 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -102,6 +102,8 @@ initGeneration (generation *gen, int g) gen->n_new_large_words = 0; gen->compact_objects = NULL; gen->n_compact_blocks = 0; + gen->compact_blocks_in_import = NULL; + gen->n_compact_blocks_in_import = 0; gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; gen->live_compact_objects = NULL; diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def index 2091e85c9c..496893a722 100644 --- a/rts/win32/libHSbase.def +++ b/rts/win32/libHSbase.def @@ -38,6 +38,9 @@ EXPORTS base_GHCziIOziException_blockedIndefinitelyOnSTM_closure base_GHCziIOziException_allocationLimitExceeded_closure base_GHCziIOziException_stackOverflow_closure + base_GHCziIOziException_cannotCompactFunction_closure + base_GHCziIOziException_cannotCompactPinned_closure + base_GHCziIOziException_cannotCompactMutable_closure base_ControlziExceptionziBase_nonTermination_closure base_ControlziExceptionziBase_nestedAtomically_closure diff --git a/testsuite/config/ghc b/testsuite/config/ghc index b0d84535d6..b7d9cbc08c 100644 --- a/testsuite/config/ghc +++ b/testsuite/config/ghc @@ -25,6 +25,7 @@ config.run_ways = ['normal', 'hpc'] config.other_ways = ['prof', 'normal_h', 'prof_hc_hb','prof_hb', 'prof_hd','prof_hy','prof_hr', + 'sanity', 'threaded1_ls', 'threaded2_hT', 'debug_numa', 'llvm', 'debugllvm', 'profllvm', 'profoptllvm', 'profthreadedllvm', @@ -80,6 +81,7 @@ config.way_flags = { 'profasm' : ['-O', '-prof', '-static', '-fprof-auto'], 'profthreaded' : ['-O', '-prof', '-static', '-fprof-auto', '-threaded'], 'ghci' : ['--interactive', '-v0', '-ignore-dot-ghci', '-fno-ghci-history', '+RTS', '-I0.1', '-RTS'], + 'sanity' : ['-debug'], 'threaded1' : ['-threaded', '-debug'], 'threaded1_ls' : ['-threaded', '-debug'], 'threaded2' : ['-O', '-threaded', '-eventlog'], @@ -116,6 +118,7 @@ config.way_rts_flags = { 'profasm' : ['-hc', '-p'], # test heap profiling too 'profthreaded' : ['-p'], 'ghci' : [], + 'sanity' : ['-DS'], 'threaded1' : [], 'threaded1_ls' : ['-ls'], 'threaded2' : ['-N2 -ls'], diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs index fb292b1394..c03af4f958 100644 --- a/utils/deriveConstants/Main.hs +++ b/utils/deriveConstants/Main.hs @@ -568,6 +568,10 @@ wanteds os = concat ,closureField C "StgCompactNFData" "autoBlockW" ,closureField C "StgCompactNFData" "nursery" ,closureField C "StgCompactNFData" "last" + ,closureField C "StgCompactNFData" "hp" + ,closureField C "StgCompactNFData" "hpLim" + ,closureField C "StgCompactNFData" "hash" + ,closureField C "StgCompactNFData" "result" ,structSize C "StgCompactNFDataBlock" ,structField C "StgCompactNFDataBlock" "self" |