diff options
Diffstat (limited to 'libraries/compact')
| -rw-r--r-- | libraries/compact/.gitignore | 4 | ||||
| -rw-r--r-- | libraries/compact/Data/Compact.hs | 89 | ||||
| -rw-r--r-- | libraries/compact/Data/Compact/Internal.hs | 78 | ||||
| -rw-r--r-- | libraries/compact/Data/Compact/Serialized.hs | 225 | ||||
| -rw-r--r-- | libraries/compact/LICENSE | 41 | ||||
| -rw-r--r-- | libraries/compact/README.md | 5 | ||||
| -rw-r--r-- | libraries/compact/Setup.hs | 6 | ||||
| -rw-r--r-- | libraries/compact/compact.cabal | 47 | ||||
| -rw-r--r-- | libraries/compact/tests/.gitignore | 21 | ||||
| -rw-r--r-- | libraries/compact/tests/Makefile | 7 | ||||
| -rw-r--r-- | libraries/compact/tests/all.T | 6 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_append.hs | 38 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_autoexpand.hs | 27 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_loop.hs | 47 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_serialize.hs | 53 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_serialize.stderr | 1 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_simple.hs | 35 | ||||
| -rw-r--r-- | libraries/compact/tests/compact_simple_array.hs | 60 |
18 files changed, 790 insertions, 0 deletions
diff --git a/libraries/compact/.gitignore b/libraries/compact/.gitignore new file mode 100644 index 0000000000..89cf73d0b3 --- /dev/null +++ b/libraries/compact/.gitignore @@ -0,0 +1,4 @@ +GNUmakefile +/dist-install/ +/dist/ +ghc.mk diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs new file mode 100644 index 0000000000..7cedd1c27a --- /dev/null +++ b/libraries/compact/Data/Compact.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Compact +-- Copyright : (c) The University of Glasgow 2001-2009 +-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : unstable +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides a data structure, called a Compact, for +-- holding fully evaluated data in a consecutive block of memory. +-- +-- /Since: 1.0.0/ +module Data.Compact ( + Compact, + getCompact, + inCompact, + isCompact, + + newCompact, + newCompactNoShare, + appendCompact, + appendCompactNoShare, + ) where + +-- Write down all GHC.Prim deps explicitly to keep them at minimum +import GHC.Prim (Compact#, + compactNew#, + State#, + RealWorld, + Int#, + ) +-- We need to import Word from GHC.Types to see the representation +-- and to able to access the Word# to pass down the primops +import GHC.Types (IO(..), Word(..)) + +import Control.DeepSeq (NFData, force) + +import Data.Compact.Internal(Compact(..), + isCompact, + inCompact, + compactAppendEvaledInternal) + +-- |Retrieve the object that was stored in a Compact +getCompact :: Compact a -> a +getCompact (Compact _ obj) = obj + +compactAppendInternal :: NFData a => Compact# -> a -> Int# -> + State# RealWorld -> (# State# RealWorld, Compact a #) +compactAppendInternal buffer root share s = + case force root of + !eval -> compactAppendEvaledInternal buffer eval share s + +compactAppendInternalIO :: NFData a => Int# -> Compact b -> a -> IO (Compact a) +compactAppendInternalIO share (Compact buffer _) root = + IO (\s -> compactAppendInternal buffer root share s) + +-- |Append a value to a 'Compact', and return a new 'Compact' +-- that shares the same buffer but a different root object. +appendCompact :: NFData a => Compact b -> a -> IO (Compact a) +appendCompact = compactAppendInternalIO 1# + +-- |Append a value to a 'Compact'. This function differs from +-- 'appendCompact' in that it will not preserve internal sharing +-- in the passed in value (and it will diverge on cyclic structures). +appendCompactNoShare :: NFData a => Compact b -> a -> IO (Compact a) +appendCompactNoShare = compactAppendInternalIO 0# + +compactNewInternal :: NFData a => Int# -> Word -> a -> IO (Compact a) +compactNewInternal share (W# size) root = + IO (\s -> case compactNew# size s of + (# s', buffer #) -> compactAppendInternal buffer root share s' ) + +-- |Create a new 'Compact', with the provided value as suggested block +-- size (which will be adjusted if unsuitable), and append the given +-- value to it, as if calling 'appendCompact' +newCompact :: NFData a => Word -> a -> IO (Compact a) +newCompact = compactNewInternal 1# + +-- |Create a new 'Compact', but append the value using 'appendCompactNoShare' +newCompactNoShare :: NFData a => Word -> a -> IO (Compact a) +newCompactNoShare = compactNewInternal 0# diff --git a/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs new file mode 100644 index 0000000000..36cd438b1e --- /dev/null +++ b/libraries/compact/Data/Compact/Internal.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Compact.Internal +-- Copyright : (c) The University of Glasgow 2001-2009 +-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : unstable +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides a data structure, called a Compact, for +-- holding fully evaluated data in a consecutive block of memory. +-- +-- This is a private implementation detail of the package and should +-- not be imported directly. +-- +-- /Since: 1.0.0/ + +module Data.Compact.Internal( + Compact(..), + compactResize, + isCompact, + inCompact, + + compactAppendEvaledInternal, +) where + +-- Write down all GHC.Prim deps explicitly to keep them at minimum +import GHC.Prim (Compact#, + compactAppend#, + compactResize#, + compactContains#, + compactContainsAny#, + State#, + RealWorld, + Int#, + ) +-- We need to import Word from GHC.Types to see the representation +-- and to able to access the Word# to pass down the primops +import GHC.Types (IO(..), Word(..), isTrue#) + +-- | A 'Compact' contains fully evaluated, pure, and immutable data. If +-- any object in the compact is alive, then the whole compact is +-- alive. This means that 'Compact's are very cheap to keep around, +-- because the data inside a compact does not need to be traversed by +-- the garbage collector. However, the tradeoff is that the memory +-- that contains a 'Compact' cannot be recovered until the whole 'Compact' +-- is garbage. +data Compact a = Compact Compact# a + +-- |Check if the second argument is inside the Compact +inCompact :: Compact b -> a -> IO Bool +inCompact (Compact buffer _) !val = + IO (\s -> case compactContains# buffer val s of + (# s', v #) -> (# s', isTrue# v #) ) + +-- |Check if the argument is in any Compact +isCompact :: a -> IO Bool +isCompact !val = + IO (\s -> case compactContainsAny# val s of + (# s', v #) -> (# s', isTrue# v #) ) + +compactResize :: Compact a -> Word -> IO () +compactResize (Compact oldBuffer _) (W# new_size) = + IO (\s -> case compactResize# oldBuffer new_size s of + s' -> (# s', () #) ) + +compactAppendEvaledInternal :: Compact# -> a -> Int# -> State# RealWorld -> + (# State# RealWorld, Compact a #) +compactAppendEvaledInternal buffer root share s = + case compactAppend# buffer root share s of + (# s', adjustedRoot #) -> (# s', Compact buffer adjustedRoot #) diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs new file mode 100644 index 0000000000..e58f9eef83 --- /dev/null +++ b/libraries/compact/Data/Compact/Serialized.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Compact.Serialized +-- Copyright : (c) The University of Glasgow 2001-2009 +-- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : unstable +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides a data structure, called a Compact, for +-- holding fully evaluated data in a consecutive block of memory. +-- +-- This module contains support for serializing a Compact for network +-- transmission and on-disk storage. +-- +-- /Since: 1.0.0/ + +module Data.Compact.Serialized( + SerializedCompact(..), + withSerializedCompact, + importCompact, + importCompactByteStrings, +) where + +-- Write down all GHC.Prim deps explicitly to keep them at minimum +import GHC.Prim (Compact#, + compactGetFirstBlock#, + compactGetNextBlock#, + compactAllocateBlock#, + compactFixupPointers#, + touch#, + Addr#, + nullAddr#, + eqAddr#, + addrToAny#, + anyToAddr#, + State#, + RealWorld, + Word#, + ) + +-- We need to import Word from GHC.Types to see the representation +-- and to able to access the Word# to pass down the primops +import GHC.Types (IO(..), Word(..), isTrue#) +import GHC.Word (Word8) + +import GHC.Ptr (Ptr(..), plusPtr) + +import qualified Data.ByteString as ByteString +import Data.ByteString.Internal(toForeignPtr) +import Data.IORef(newIORef, readIORef, writeIORef) +import Foreign.ForeignPtr(withForeignPtr) +import Foreign.Marshal.Utils(copyBytes) +import Control.DeepSeq(NFData, force) + +import Data.Compact.Internal(Compact(..)) + +-- |A serialized version of the 'Compact' metadata (each block with +-- address and size and the address of the root). This structure is +-- meant to be sent alongside the actual 'Compact' data. It can be +-- sent out of band in advance if the data is to be sent over RDMA +-- (which requires both sender and receiver to have pinned buffers). +data SerializedCompact a = SerializedCompact { + serializedCompactBlockList :: [(Ptr a, Word)], + serializedCompactRoot :: Ptr a + } + +addrIsNull :: Addr# -> Bool +addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr) + + +compactGetFirstBlock :: Compact# -> IO (Ptr a, Word) +compactGetFirstBlock buffer = + IO (\s -> case compactGetFirstBlock# buffer s of + (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) ) + +compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word) +compactGetNextBlock buffer block = + IO (\s -> case compactGetNextBlock# buffer block s of + (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) ) + +mkBlockList :: Compact# -> IO [(Ptr a, Word)] +mkBlockList buffer = compactGetFirstBlock buffer >>= go + where + go :: (Ptr a, Word) -> IO [(Ptr a, Word)] + go (Ptr block, _) | addrIsNull block = return [] + go item@(Ptr block, _) = do + next <- compactGetNextBlock buffer block + rest <- go next + return $ item : rest + +-- We MUST mark withSerializedCompact as NOINLINE +-- Otherwise the compiler will eliminate the call to touch# +-- causing the Compact# to be potentially GCed too eagerly, +-- before func had a chance to copy everything into its own +-- buffers/sockets/whatever + +-- |Serialize the 'Compact', and call the provided function with +-- with the 'Compact' serialized representation. The resulting +-- action will be executed synchronously before this function +-- completes. +{-# NOINLINE withSerializedCompact #-} +withSerializedCompact :: NFData c => Compact a -> + (SerializedCompact a -> IO c) -> IO c +withSerializedCompact (Compact buffer root) func = do + rootPtr <- IO (\s -> case anyToAddr# root s of + (# s', rootAddr #) -> (# s', Ptr rootAddr #) ) + blockList <- mkBlockList buffer + let serialized = SerializedCompact blockList rootPtr + -- we must be strict, to avoid smart uses of ByteStrict.Lazy that + -- return a thunk instead of a ByteString (but the thunk references + -- the Ptr, not the Compact#, so it will point to garbage if GC + -- happens) + !r <- fmap force $ func serialized + IO (\s -> case touch# buffer s of + s' -> (# s', r #) ) + +fixupPointers :: Addr# -> Addr# -> State# RealWorld -> + (# State# RealWorld, Maybe (Compact a) #) +fixupPointers firstBlock rootAddr s = + case compactFixupPointers# firstBlock rootAddr s of + (# s', buffer, adjustedRoot #) -> + if addrIsNull adjustedRoot then (# s', Nothing #) + else case addrToAny# adjustedRoot of + (# root #) -> (# s', Just $ Compact buffer root #) + +-- |Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The +-- provided function will be called with the address and size of each +-- newly allocated block in succession, and should fill the memory +-- from the external source (eg. by reading from a socket or from disk) +-- 'importCompact' can return Nothing if the 'Compact' was corrupt +-- or it had pointers that could not be adjusted. +importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) -> + IO (Maybe (Compact a)) + +-- what we would like is +{- + importCompactPtrs ((firstAddr, firstSize):rest) = do + (firstBlock, compact) <- compactAllocateAt firstAddr firstSize + #nullAddr + fillBlock firstBlock firstAddr firstSize + let go prev [] = return () + go prev ((addr, size):rest) = do + (block, _) <- compactAllocateAt addr size prev + fillBlock block addr size + go block rest + go firstBlock rest + if isTrue# (compactFixupPointers compact) then + return $ Just compact + else + return Nothing + +But we can't do that because IO Addr# is not valid (kind mismatch) +This check exists to prevent a polymorphic data constructor from using +an unlifted type (which would break GC) - it would not a problem for IO +because IO stores a function, not a value, but the kind check is there +anyway. +Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor +we can do IO (Addr#, Word#) (that would break the GC for real!) + +And therefore we need to do everything with State# explicitly. +-} + +-- just do shut up GHC +importCompact (SerializedCompact [] _) _ = return Nothing +importCompact (SerializedCompact blocks root) filler = do + -- I'm not sure why we need a bang pattern here, given that + -- these are obviously strict lets, but ghc complains otherwise + let !((_, W# firstSize):otherBlocks) = blocks + let !(Ptr rootAddr) = root + IO (\s0 -> case compactAllocateBlock# firstSize nullAddr# s0 of + (# s1, firstBlock #) -> + case fillBlock firstBlock firstSize s1 of + s2 -> case go firstBlock otherBlocks s2 of + s3-> fixupPointers firstBlock rootAddr s3 ) + where + -- note that the case statements above are strict even though + -- they don't seem to inspect their argument because State# + -- is an unlifted type + fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld + fillBlock addr size s = case filler (Ptr addr) (W# size) of + IO action -> case action s of + (# s', _ #) -> s' + + go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld + go _ [] s = s + go previous ((_, W# size):rest) s = + case compactAllocateBlock# size previous s of + (# s', block #) -> case fillBlock block size s' of + s'' -> go block rest s'' + +sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool +sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl + where + go [] [] = True + go (_:_) [] = False + go [] (_:_) = False + go ((_, size):scs) (bs:bss) = + fromIntegral size == ByteString.length bs && go scs bss + +importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> + IO (Maybe (Compact a)) +importCompactByteStrings serialized stringList = + -- sanity check stringList first - if we throw an exception later we leak + -- memory! + if not (sanityCheckByteStrings serialized stringList) then + return Nothing + else do + state <- newIORef stringList + let filler :: Ptr Word8 -> Word -> IO () + filler to size = do + -- this pattern match will never fail + (next:rest) <- readIORef state + let (fp, off, _) = toForeignPtr next + withForeignPtr fp $ \from -> do + copyBytes to (from `plusPtr` off) (fromIntegral size) + writeIORef state rest + importCompact serialized filler diff --git a/libraries/compact/LICENSE b/libraries/compact/LICENSE new file mode 100644 index 0000000000..06b2599694 --- /dev/null +++ b/libraries/compact/LICENSE @@ -0,0 +1,41 @@ +This library (compact) is derived from code from the GHC project which +is largely (c) The University of Glasgow, and distributable under a +BSD-style license (see below). +Portions of this library were written by Giovanni Campagna +(gcampagn@cs.stanford.edu). They are available under the same license. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2001-2014, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- diff --git a/libraries/compact/README.md b/libraries/compact/README.md new file mode 100644 index 0000000000..0b7d197c88 --- /dev/null +++ b/libraries/compact/README.md @@ -0,0 +1,5 @@ +The `compact` Package +===================== + +Exposes a single data structure, called a Compact, which contains +fully evaluated data closed under pointer reachability. diff --git a/libraries/compact/Setup.hs b/libraries/compact/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/libraries/compact/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/libraries/compact/compact.cabal b/libraries/compact/compact.cabal new file mode 100644 index 0000000000..9d87ccccd3 --- /dev/null +++ b/libraries/compact/compact.cabal @@ -0,0 +1,47 @@ +name: compact +version: 1.0.0.0 +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/compact +synopsis: In memory storage of deeply evaluated data structure +category: Data +description: + This package provides a single data structure, called a Compact, + which holds a single haskell object in fully evaluated form. The + invariant is, no pointers live inside the struct that point outside + it, which ensures efficient garbage collection without ever reading + the structure contents (effectively, it works as a manually managed + "oldest generation" which is never freed until the whole is released). + + Internally, the struct is stored a single contiguous block of memory, + which allows efficient serialization and deserialization of structs + for distributed computing. +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==7.11 + +source-repository head + type: git + location: http://git.haskell.org/ghc.git + subdir: libraries/compact + +library + default-language: Haskell2010 + other-extensions: + MagicHash + BangPatterns + UnboxedTuples + CPP + + build-depends: rts == 1.0.* + build-depends: ghc-prim == 0.5.0.0 + build-depends: base >= 4.9.0 && < 4.10 + build-depends: deepseq >= 1.4 + build-depends: bytestring >= 0.10.6.0 + ghc-options: -Wall + + exposed-modules: Data.Compact + Data.Compact.Internal + Data.Compact.Serialized diff --git a/libraries/compact/tests/.gitignore b/libraries/compact/tests/.gitignore new file mode 100644 index 0000000000..c20cf7d4be --- /dev/null +++ b/libraries/compact/tests/.gitignore @@ -0,0 +1,21 @@ +*.stderr +!compact_serialize.stderr +*.stdout +.hpc.* +*.eventlog +*.genscript +compact_append +compact_simple +compact_nospace +compact_noshare +compact_loop +compact_resize +compact_inc_append +compact_inc_simple +compact_inc_nospace +compact_inc_noshare +compact_autoexpand +compact_inc_custom +compact_inc_incremental +compact_inc_monad +compact_simple_symbols diff --git a/libraries/compact/tests/Makefile b/libraries/compact/tests/Makefile new file mode 100644 index 0000000000..6a0abcf1cf --- /dev/null +++ b/libraries/compact/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/libraries/compact/tests/all.T b/libraries/compact/tests/all.T new file mode 100644 index 0000000000..fd543142e9 --- /dev/null +++ b/libraries/compact/tests/all.T @@ -0,0 +1,6 @@ +test('compact_simple', omit_ways(['ghci']), compile_and_run, ['']) +test('compact_loop', omit_ways(['ghci']), compile_and_run, ['']) +test('compact_append', omit_ways(['ghci']), compile_and_run, ['']) +test('compact_autoexpand', omit_ways(['ghci']), compile_and_run, ['']) +test('compact_simple_array', omit_ways(['ghci']), compile_and_run, ['']) +test('compact_serialize', omit_ways(['ghci']), compile_and_run, [''])
\ No newline at end of file diff --git a/libraries/compact/tests/compact_append.hs b/libraries/compact/tests/compact_append.hs new file mode 100644 index 0000000000..59f86777b7 --- /dev/null +++ b/libraries/compact/tests/compact_append.hs @@ -0,0 +1,38 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +main = do + let val = ("hello", Just 42) :: (String, Maybe Int) + str <- newCompact 4096 val + + let val2 = ("world", 42) :: (String, Int) + str2 <- appendCompact str val2 + + -- check that values where not corrupted + assertEquals ("hello", Just 42) val + assertEquals ("world", 42) val2 + -- check the values in the compact + assertEquals ("hello", Just 42) (getCompact str) + assertEquals ("world", 42) (getCompact str2) + + performMajorGC + + -- same checks again + assertEquals ("hello", Just 42) val + assertEquals ("world", 42) val2 + -- check the values in the compact + assertEquals ("hello", Just 42) (getCompact str) + assertEquals ("world", 42) (getCompact str2) diff --git a/libraries/compact/tests/compact_autoexpand.hs b/libraries/compact/tests/compact_autoexpand.hs new file mode 100644 index 0000000000..5db0bbc55f --- /dev/null +++ b/libraries/compact/tests/compact_autoexpand.hs @@ -0,0 +1,27 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +main = do + -- create a compact large 4096 bytes (minus the size of header) + -- add a value that is 1024 cons cells, pointing to 7 INTLIKE + -- each cons cell is 1 word header, 1 word data, 1 word next + -- so total 3072 words, 12288 bytes on x86, 24576 on x86_64 + -- it should not fit in one block + let val = replicate 4096 7 :: [Int] + str <- newCompact 1 val + assertEquals val (getCompact str) + performMajorGC + assertEquals val (getCompact str) diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs new file mode 100644 index 0000000000..0111fc1bdb --- /dev/null +++ b/libraries/compact/tests/compact_loop.hs @@ -0,0 +1,47 @@ +module Main where + +import Control.Exception +import Control.DeepSeq +import System.Mem +import Text.Show + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +data Tree = Nil | Node Tree Tree Tree + +instance Eq Tree where + Nil == Nil = True + Node _ l1 r1 == Node _ l2 r2 = l1 == l2 && r1 == r2 + _ == _ = False + +instance Show Tree where + showsPrec _ Nil = showString "Nil" + showsPrec _ (Node _ l r) = showString "(Node " . shows l . + showString " " . shows r . showString ")" + +instance NFData Tree where + rnf Nil = () + rnf (Node p l r) = p `seq` rnf l `seq` rnf r `seq` () + +{-# NOINLINE test #-} +test x = do + let a = Node Nil x b + b = Node a Nil Nil + str <- newCompact 4096 a + + -- check the value in the compact + assertEquals a (getCompact str) + performMajorGC + -- check again the value in the compact + assertEquals a (getCompact str) + +main = test Nil diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs new file mode 100644 index 0000000000..e4ba88ea9e --- /dev/null +++ b/libraries/compact/tests/compact_serialize.hs @@ -0,0 +1,53 @@ +module Main where + +import Control.Exception +import Control.Monad +import System.Mem + +import Data.IORef +import Data.ByteString (ByteString, packCStringLen) +import Foreign.Ptr +import Control.DeepSeq + +import Data.Compact +import Data.Compact.Serialized + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString]) +serialize val = do + cnf <- newCompact 4096 val + + bytestrref <- newIORef undefined + scref <- newIORef undefined + withSerializedCompact cnf $ \sc -> do + writeIORef scref sc + performMajorGC + bytestrs <- forM (serializedCompactBlockList sc) $ \(ptr, size) -> do + packCStringLen (castPtr ptr, fromIntegral size) + writeIORef bytestrref bytestrs + + performMajorGC + + bytestrs <- readIORef bytestrref + sc <- readIORef scref + return (sc, bytestrs) + +main = do + let val = ("hello", 1, 42, 42, Just 42) :: + (String, Int, Int, Integer, Maybe Int) + + (sc, bytestrs) <- serialize val + performMajorGC + + mcnf <- importCompactByteStrings sc bytestrs + case mcnf of + Nothing -> assertFail "import failed" + Just cnf -> assertEquals val (getCompact cnf) diff --git a/libraries/compact/tests/compact_serialize.stderr b/libraries/compact/tests/compact_serialize.stderr new file mode 100644 index 0000000000..2483efa009 --- /dev/null +++ b/libraries/compact/tests/compact_serialize.stderr @@ -0,0 +1 @@ +Compact imported at the wrong address, will fix up internal pointers diff --git a/libraries/compact/tests/compact_simple.hs b/libraries/compact/tests/compact_simple.hs new file mode 100644 index 0000000000..c4cfbbd151 --- /dev/null +++ b/libraries/compact/tests/compact_simple.hs @@ -0,0 +1,35 @@ +module Main where + +import Control.Exception +import System.Mem + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () +test func = do + let val = ("hello", 1, 42, 42, Just 42) :: + (String, Int, Int, Integer, Maybe Int) + str <- func 4096 val + + -- check that val is still good + assertEquals ("hello", 1, 42, 42, Just 42) val + -- check the value in the compact + assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str) + performMajorGC + -- check again val + assertEquals ("hello", 1, 42, 42, Just 42) val + -- check again the value in the compact + assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str) + +main = do + test newCompact + test newCompactNoShare diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs new file mode 100644 index 0000000000..7b194867de --- /dev/null +++ b/libraries/compact/tests/compact_simple_array.hs @@ -0,0 +1,60 @@ +module Main where + +import Control.Exception +import Control.Monad +import System.Mem + +import Control.Monad.ST +import Data.Array +import Data.Array.ST +import qualified Data.Array.Unboxed as U +import Control.DeepSeq + +import Data.Compact + +assertFail :: String -> IO () +assertFail msg = throwIO $ AssertionFailed msg + +assertEquals :: (Eq a, Show a) => a -> a -> IO () +assertEquals expected actual = + if expected == actual then return () + else assertFail $ "expected " ++ (show expected) + ++ ", got " ++ (show actual) + +arrTest :: (Monad m, MArray a e m, Num e) => m (a Int e) +arrTest = do + arr <- newArray (1, 10) 0 + forM_ [1..10] $ \j -> do + writeArray arr j (fromIntegral $ 2*j + 1) + return arr + +instance NFData (U.UArray i e) where + rnf x = seq x () + +-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () +test func = do + let fromList :: Array Int Int + fromList = listArray (1, 10) [1..] + frozen :: Array Int Int + frozen = runST $ do + arr <- arrTest :: ST s (STArray s Int Int) + freeze arr + stFrozen :: Array Int Int + stFrozen = runSTArray arrTest + unboxedFrozen :: U.UArray Int Int + unboxedFrozen = runSTUArray arrTest + + let val = (fromList, frozen, stFrozen, unboxedFrozen) + str <- func 4096 val + + -- check that val is still good + assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val + -- check the value in the compact + assertEquals val (getCompact str) + performMajorGC + -- check again the value in the compact + assertEquals val (getCompact str) + +main = do + test newCompact + test newCompactNoShare |