summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/compact/Data/Compact.hs38
-rw-r--r--libraries/compact/Data/Compact/Internal.hs3
-rw-r--r--libraries/compact/Data/Compact/Serialized.hs19
-rw-r--r--libraries/compact/compact.cabal8
-rw-r--r--libraries/compact/tests/compact_function.hs4
-rw-r--r--libraries/compact/tests/compact_huge_array.hs4
-rw-r--r--libraries/compact/tests/compact_loop.hs5
-rw-r--r--libraries/compact/tests/compact_mutable.hs4
-rw-r--r--libraries/compact/tests/compact_pinned.hs1
-rw-r--r--libraries/compact/tests/compact_serialize.hs3
-rw-r--r--libraries/compact/tests/compact_simple_array.hs4
11 files changed, 31 insertions, 62 deletions
diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs
index ce6bf2bb83..f1339e503a 100644
--- a/libraries/compact/Data/Compact.hs
+++ b/libraries/compact/Data/Compact.hs
@@ -33,9 +33,8 @@
-- binary serialization), this can lead to substantial speed ups.
--
-- For example, suppose you have a function @loadBigStruct :: IO BigStruct@,
--- which loads a large data structure from the file system. First,
--- ensure that @BigStruct@ is immutable by defining an 'NFData' instance
--- for it. Then, you can "compact" the structure with the following code:
+-- which loads a large data structure from the file system. You can "compact"
+-- the structure with the following code:
--
-- @
-- do r <- 'compact' =<< loadBigStruct
@@ -79,7 +78,6 @@ module Data.Compact (
) where
import Control.Concurrent
-import Control.DeepSeq (NFData)
import GHC.Prim
import GHC.Types
@@ -101,12 +99,11 @@ getCompact (Compact _ obj _) = obj
-- not terminate if the structure contains cycles (use 'compactWithSharing'
-- instead).
--
--- 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).
+-- The object in question must not contain any functions or mutable data; if it
+-- does, 'compact' will raise an exception. In the future, we may add a type
+-- class which will help statically check if this is the case or not.
--
-compact :: NFData a => a -> IO (Compact a)
+compact :: a -> IO (Compact a)
compact = Internal.compactSized 31268 False
-- | Compact a value, retaining any internal sharing and
@@ -116,12 +113,11 @@ compact = Internal.compactSized 31268 False
-- 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).
+-- The object in question must not contain any functions or mutable data; if it
+-- does, 'compact' will raise an exception. In the future, we may add a type
+-- class which will help statically check if this is the case or not.
--
-compactWithSharing :: NFData a => a -> IO (Compact a)
+compactWithSharing :: a -> IO (Compact a)
compactWithSharing = Internal.compactSized 31268 True
-- | Add a value to an existing 'Compact'. This will help you avoid
@@ -129,19 +125,19 @@ compactWithSharing = Internal.compactSized 31268 True
-- but remember that after compaction this value will only be deallocated
-- with the entire compact region.
--
--- Behaves exactly like 'compact' with respect to sharing and the 'NFData'
--- constraint.
+-- Behaves exactly like 'compact' with respect to sharing and what data
+-- it accepts.
--
-compactAdd :: NFData a => Compact b -> a -> IO (Compact a)
+compactAdd :: 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', like 'compactAdd', but
--- behaving exactly like 'compactWithSharing' with respect to
--- sharing and the 'NFData' constraint.
+-- | Add a value to an existing 'Compact', like 'compactAdd',
+-- but behaving exactly like 'compactWithSharing' with respect to sharing and
+-- what data it accepts.
--
-compactAddWithSharing :: NFData a => Compact b -> a -> IO (Compact a)
+compactAddWithSharing :: Compact b -> a -> IO (Compact a)
compactAddWithSharing (Compact compact# _ lock) a =
withMVar lock $ \_ -> IO $ \s ->
case compactAddWithSharing# compact# a s of { (# s1, pk #) ->
diff --git a/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs
index 2857a9d615..722a62c09c 100644
--- a/libraries/compact/Data/Compact/Internal.hs
+++ b/libraries/compact/Data/Compact/Internal.hs
@@ -26,7 +26,6 @@ module Data.Compact.Internal
) where
import Control.Concurrent.MVar
-import Control.DeepSeq
import GHC.Prim
import GHC.Types
@@ -105,7 +104,7 @@ mkCompact compact# a s =
-- structure in question is, you can save time by picking an appropriate
-- block size for the compact region.
--
-compactSized :: NFData a => Int -> Bool -> a -> IO (Compact a)
+compactSized :: 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 #) ->
diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs
index bf2b4f7918..56ddb30ef4 100644
--- a/libraries/compact/Data/Compact/Serialized.hs
+++ b/libraries/compact/Data/Compact/Serialized.hs
@@ -38,7 +38,6 @@ 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
@@ -82,23 +81,23 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
-- 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.
+-- with the 'Compact' serialized representation. It is not safe
+-- to return the pointer from the action and use it after
+-- the action completes: all uses must be inside this bracket,
+-- since we cannot guarantee that the compact region will stay
+-- live from the 'Ptr' object. For example, it would be
+-- unsound to use 'unsafeInterleaveIO' to lazily construct
+-- a lazy bytestring from the 'Ptr'.
--
{-# NOINLINE withSerializedCompact #-}
-withSerializedCompact :: NFData c => Compact a ->
+withSerializedCompact :: Compact a ->
(SerializedCompact a -> IO c) -> IO c
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
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
+ r <- func serialized
IO (\s -> case touch# buffer s of
s' -> (# s', r #) )
diff --git a/libraries/compact/compact.cabal b/libraries/compact/compact.cabal
index 2a4478cf20..b80dc59324 100644
--- a/libraries/compact/compact.cabal
+++ b/libraries/compact/compact.cabal
@@ -35,11 +35,9 @@ library
UnboxedTuples
CPP
- build-depends: rts == 1.0.*
- build-depends: ghc-prim == 0.5.0.0
- build-depends: base >= 4.9.0 && < 4.11
- build-depends: deepseq >= 1.4
- build-depends: bytestring >= 0.10.6.0
+ build-depends: ghc-prim == 0.5.0.0,
+ base >= 4.9.0 && < 4.11,
+ bytestring >= 0.10.6.0
ghc-options: -Wall
exposed-modules: Data.Compact
diff --git a/libraries/compact/tests/compact_function.hs b/libraries/compact/tests/compact_function.hs
index fc4f4ca172..8193a78a99 100644
--- a/libraries/compact/tests/compact_function.hs
+++ b/libraries/compact/tests/compact_function.hs
@@ -1,10 +1,6 @@
-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_huge_array.hs b/libraries/compact/tests/compact_huge_array.hs
index 8a8374297b..87200d807d 100644
--- a/libraries/compact/tests/compact_huge_array.hs
+++ b/libraries/compact/tests/compact_huge_array.hs
@@ -8,7 +8,6 @@ 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
@@ -29,9 +28,6 @@ arrTest = 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
diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs
index c8991b05d0..5cf167c393 100644
--- a/libraries/compact/tests/compact_loop.hs
+++ b/libraries/compact/tests/compact_loop.hs
@@ -1,7 +1,6 @@
module Main where
import Control.Exception
-import Control.DeepSeq
import System.Mem
import Text.Show
@@ -29,10 +28,6 @@ instance Show Tree where
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
diff --git a/libraries/compact/tests/compact_mutable.hs b/libraries/compact/tests/compact_mutable.hs
index 2d1a7f2572..fdd7a436ce 100644
--- a/libraries/compact/tests/compact_mutable.hs
+++ b/libraries/compact/tests/compact_mutable.hs
@@ -1,13 +1,9 @@
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_pinned.hs b/libraries/compact/tests/compact_pinned.hs
index 39dda61cd7..faeb2fc6bf 100644
--- a/libraries/compact/tests/compact_pinned.hs
+++ b/libraries/compact/tests/compact_pinned.hs
@@ -1,4 +1,3 @@
-import Control.DeepSeq
import Control.Exception
import qualified Data.ByteString.Char8 as B
import Data.Compact
diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs
index 2b831e048c..f4bd2044fc 100644
--- a/libraries/compact/tests/compact_serialize.hs
+++ b/libraries/compact/tests/compact_serialize.hs
@@ -7,7 +7,6 @@ import System.Mem
import Data.IORef
import Data.ByteString (ByteString, packCStringLen)
import Foreign.Ptr
-import Control.DeepSeq
import Data.Compact
import Data.Compact.Internal
@@ -22,7 +21,7 @@ assertEquals expected actual =
else assertFail $ "expected " ++ (show expected)
++ ", got " ++ (show actual)
-serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString])
+serialize :: a -> IO (SerializedCompact a, [ByteString])
serialize val = do
cnf <- compactSized 4096 True val
diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs
index 69421c5137..88f669837f 100644
--- a/libraries/compact/tests/compact_simple_array.hs
+++ b/libraries/compact/tests/compact_simple_array.hs
@@ -8,7 +8,6 @@ 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
@@ -29,9 +28,6 @@ arrTest = 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
View Lorry Controller Status