diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2016-07-29 14:11:03 +0100 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2016-12-07 10:59:35 +0000 |
| commit | 7036fde9df61b6eae9719c7f6c656778c756bec9 (patch) | |
| tree | a9d8eeaaf0d611dc7f29f2d5734b5be8218f32fc | |
| parent | 4dd6b37fd540ad0243057f4aa29a93590d98de88 (diff) | |
| download | haskell-7036fde9df61b6eae9719c7f6c656778c756bec9.tar.gz | |
Overhaul of Compact Regions (#12455)
Summary:
This commit makes various improvements and addresses some issues with
Compact Regions (aka Compact Normal Forms).
This was the most important thing I wanted to fix. Compaction
previously prevented GC from running until it was complete, which
would be a problem in a multicore setting. Now, we compact using a
hand-written Cmm routine that can be interrupted at any point. When a
GC is triggered during a sharing-enabled compaction, the GC has to
traverse and update the hash table, so this hash table is now stored
in the StgCompactNFData object.
Previously, compaction consisted of a deepseq using the NFData class,
followed by a traversal in C code to copy the data. This is now done
in a single pass with hand-written Cmm (see rts/Compact.cmm). We no
longer use the NFData instances, instead the Cmm routine evaluates
components directly as it compacts.
The new compaction is about 50% faster than the old one with no
sharing, and a little faster on average with sharing (the cost of the
hash table dominates when we're doing sharing).
Static objects that don't (transitively) refer to any CAFs don't need
to be copied into the compact region. In particular this means we
often avoid copying Char values and small Int values, because these
are static closures in the runtime.
Each Compact# object can support a single compactAdd# operation at any
given time, so the Data.Compact library now enforces mutual exclusion
using an MVar stored in the Compact object.
We now get exceptions rather than killing everything with a barf()
when we encounter an object that cannot be compacted (a function, or a
mutable object). We now also detect pinned objects, which can't be
compacted either.
The Data.Compact API has been refactored and cleaned up. A new
compactSize operation returns the size (in bytes) of the compact
object.
Most of the documentation is in the Haddock docs for the compact
library, which I've expanded and improved here.
Various comments in the code have been improved, especially the main
Note [Compact Normal Forms] in rts/sm/CNF.c.
I've added a few tests, and expanded a few of the tests that were
there. We now also run the tests with GHCi, and in a new test way
that enables sanity checking (+RTS -DS).
There's a benchmark in libraries/compact/tests/compact_bench.hs for
measuring compaction speed and comparing sharing vs. no sharing.
The field totalDataW in StgCompactNFData was unnecessary.
Test Plan:
* new unit tests
* validate
* tested manually that we can compact Data.Aeson data
Reviewers: gcampax, bgamari, ezyang, austin, niteria, hvr, erikd
Subscribers: thomie, simonpj
Differential Revision: https://phabricator.haskell.org/D2751
GHC Trac Issues: #12455
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" |