diff options
Diffstat (limited to 'libraries')
34 files changed, 473 insertions, 163 deletions
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 |