Commit 58415741 authored by Edward Z. Yang's avatar Edward Z. Yang

Drop NFData constraint from compact.

Summary:
It's both unsound (easy to write a bogus NFData instance) and
incomplete (you might want to serialize data that doesn't have
an NFData instance, and will be fine at runtime.)  So better
just to drop it.  (By the way, we used to need the NFData
instance to "pre-evaluate" the data before we copied it into
the region, but since Simon Marlow rewrote the code to directly
evaluate and copy, this is no longer necessary.)
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonmar, austin, dfeuer, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3168
parent 992ea029
...@@ -33,9 +33,8 @@ ...@@ -33,9 +33,8 @@
-- binary serialization), this can lead to substantial speed ups. -- binary serialization), this can lead to substantial speed ups.
-- --
-- For example, suppose you have a function @loadBigStruct :: IO BigStruct@, -- For example, suppose you have a function @loadBigStruct :: IO BigStruct@,
-- which loads a large data structure from the file system. First, -- which loads a large data structure from the file system. You can "compact"
-- ensure that @BigStruct@ is immutable by defining an 'NFData' instance -- the structure with the following code:
-- for it. Then, you can "compact" the structure with the following code:
-- --
-- @ -- @
-- do r <- 'compact' =<< loadBigStruct -- do r <- 'compact' =<< loadBigStruct
...@@ -79,7 +78,6 @@ module Data.Compact ( ...@@ -79,7 +78,6 @@ module Data.Compact (
) where ) where
import Control.Concurrent import Control.Concurrent
import Control.DeepSeq (NFData)
import GHC.Prim import GHC.Prim
import GHC.Types import GHC.Types
...@@ -101,12 +99,11 @@ getCompact (Compact _ obj _) = obj ...@@ -101,12 +99,11 @@ getCompact (Compact _ obj _) = obj
-- not terminate if the structure contains cycles (use 'compactWithSharing' -- not terminate if the structure contains cycles (use 'compactWithSharing'
-- instead). -- instead).
-- --
-- The NFData constraint is just to ensure that the object contains no -- The object in question must not contain any functions or mutable data; if it
-- functions, 'compact' does not actually use it. If your object -- does, 'compact' will raise an exception. In the future, we may add a type
-- contains any functions, then 'compact' will fail. (and your -- class which will help statically check if this is the case or not.
-- 'NFData' instance is lying).
-- --
compact :: NFData a => a -> IO (Compact a) compact :: a -> IO (Compact a)
compact = Internal.compactSized 31268 False compact = Internal.compactSized 31268 False
-- | Compact a value, retaining any internal sharing and -- | Compact a value, retaining any internal sharing and
...@@ -116,12 +113,11 @@ compact = Internal.compactSized 31268 False ...@@ -116,12 +113,11 @@ compact = Internal.compactSized 31268 False
-- by maintaining a hash table mapping uncompacted objects to -- by maintaining a hash table mapping uncompacted objects to
-- compacted objects. -- compacted objects.
-- --
-- The 'NFData' constraint is just to ensure that the object contains no -- The object in question must not contain any functions or mutable data; if it
-- functions, `compact` does not actually use it. If your object -- does, 'compact' will raise an exception. In the future, we may add a type
-- contains any functions, then 'compactWithSharing' will fail. (and -- class which will help statically check if this is the case or not.
-- your 'NFData' instance is lying).
-- --
compactWithSharing :: NFData a => a -> IO (Compact a) compactWithSharing :: a -> IO (Compact a)
compactWithSharing = Internal.compactSized 31268 True compactWithSharing = Internal.compactSized 31268 True
-- | Add a value to an existing 'Compact'. This will help you avoid -- | Add a value to an existing 'Compact'. This will help you avoid
...@@ -129,19 +125,19 @@ compactWithSharing = Internal.compactSized 31268 True ...@@ -129,19 +125,19 @@ compactWithSharing = Internal.compactSized 31268 True
-- but remember that after compaction this value will only be deallocated -- but remember that after compaction this value will only be deallocated
-- with the entire compact region. -- with the entire compact region.
-- --
-- Behaves exactly like 'compact' with respect to sharing and the 'NFData' -- Behaves exactly like 'compact' with respect to sharing and what data
-- constraint. -- 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 -> compactAdd (Compact compact# _ lock) a = withMVar lock $ \_ -> IO $ \s ->
case compactAdd# compact# a s of { (# s1, pk #) -> case compactAdd# compact# a s of { (# s1, pk #) ->
(# s1, Compact compact# pk lock #) } (# s1, Compact compact# pk lock #) }
-- | Add a value to an existing 'Compact', like 'compactAdd', but -- | Add a value to an existing 'Compact', like 'compactAdd',
-- behaving exactly like 'compactWithSharing' with respect to -- but behaving exactly like 'compactWithSharing' with respect to sharing and
-- sharing and the 'NFData' constraint. -- 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 = compactAddWithSharing (Compact compact# _ lock) a =
withMVar lock $ \_ -> IO $ \s -> withMVar lock $ \_ -> IO $ \s ->
case compactAddWithSharing# compact# a s of { (# s1, pk #) -> case compactAddWithSharing# compact# a s of { (# s1, pk #) ->
......
...@@ -26,7 +26,6 @@ module Data.Compact.Internal ...@@ -26,7 +26,6 @@ module Data.Compact.Internal
) where ) where
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.DeepSeq
import GHC.Prim import GHC.Prim
import GHC.Types import GHC.Types
...@@ -105,7 +104,7 @@ mkCompact compact# a s = ...@@ -105,7 +104,7 @@ mkCompact compact# a s =
-- structure in question is, you can save time by picking an appropriate -- structure in question is, you can save time by picking an appropriate
-- block size for the compact region. -- 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 -> compactSized (I# size) share a = IO $ \s0 ->
case compactNew# (int2Word# size) s0 of { (# s1, compact# #) -> case compactNew# (int2Word# size) s0 of { (# s1, compact# #) ->
case compactAddPrim compact# a s1 of { (# s2, pk #) -> case compactAddPrim compact# a s1 of { (# s2, pk #) ->
......
...@@ -38,7 +38,6 @@ import Data.ByteString.Internal(toForeignPtr) ...@@ -38,7 +38,6 @@ import Data.ByteString.Internal(toForeignPtr)
import Data.IORef(newIORef, readIORef, writeIORef) import Data.IORef(newIORef, readIORef, writeIORef)
import Foreign.ForeignPtr(withForeignPtr) import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Marshal.Utils(copyBytes) import Foreign.Marshal.Utils(copyBytes)
import Control.DeepSeq(NFData, force)
import Data.Compact.Internal import Data.Compact.Internal
...@@ -82,23 +81,23 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go ...@@ -82,23 +81,23 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
-- buffers/sockets/whatever -- buffers/sockets/whatever
-- | Serialize the 'Compact', and call the provided function with -- | Serialize the 'Compact', and call the provided function with
-- with the 'Compact' serialized representation. The resulting -- with the 'Compact' serialized representation. It is not safe
-- action will be executed synchronously before this function -- to return the pointer from the action and use it after
-- completes. -- 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 #-} {-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: NFData c => Compact a -> withSerializedCompact :: Compact a ->
(SerializedCompact a -> IO c) -> IO c (SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
rootPtr <- IO (\s -> case anyToAddr# root s of rootPtr <- IO (\s -> case anyToAddr# root s of
(# s', rootAddr #) -> (# s', Ptr rootAddr #) ) (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
blockList <- mkBlockList buffer blockList <- mkBlockList buffer
let serialized = SerializedCompact blockList rootPtr let serialized = SerializedCompact blockList rootPtr
-- we must be strict, to avoid smart uses of ByteStrict.Lazy that r <- func serialized
-- 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 IO (\s -> case touch# buffer s of
s' -> (# s', r #) ) s' -> (# s', r #) )
......
...@@ -35,11 +35,9 @@ library ...@@ -35,11 +35,9 @@ library
UnboxedTuples UnboxedTuples
CPP CPP
build-depends: rts == 1.0.* build-depends: ghc-prim == 0.5.0.0,
build-depends: ghc-prim == 0.5.0.0 base >= 4.9.0 && < 4.11,
build-depends: base >= 4.9.0 && < 4.11 bytestring >= 0.10.6.0
build-depends: deepseq >= 1.4
build-depends: bytestring >= 0.10.6.0
ghc-options: -Wall ghc-options: -Wall
exposed-modules: Data.Compact exposed-modules: Data.Compact
......
import Control.DeepSeq
import Control.Exception import Control.Exception
import Data.Compact import Data.Compact
data HiddenFunction = HiddenFunction (Int -> Int) data HiddenFunction = HiddenFunction (Int -> Int)
instance NFData HiddenFunction where
rnf x = x `seq` () -- ignore the function inside
main = compact (HiddenFunction (+1)) main = compact (HiddenFunction (+1))
...@@ -8,7 +8,6 @@ import Control.Monad.ST ...@@ -8,7 +8,6 @@ import Control.Monad.ST
import Data.Array import Data.Array
import Data.Array.ST import Data.Array.ST
import qualified Data.Array.Unboxed as U import qualified Data.Array.Unboxed as U
import Control.DeepSeq
import Data.Compact import Data.Compact
import Data.Compact.Internal import Data.Compact.Internal
...@@ -29,9 +28,6 @@ arrTest = do ...@@ -29,9 +28,6 @@ arrTest = do
writeArray arr j (fromIntegral $ 2*j + 1) writeArray arr j (fromIntegral $ 2*j + 1)
return arr return arr
instance NFData (U.UArray i e) where
rnf x = seq x ()
-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () -- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
test func = do test func = do
let fromList :: Array Int Int let fromList :: Array Int Int
......
module Main where module Main where
import Control.Exception import Control.Exception
import Control.DeepSeq
import System.Mem import System.Mem
import Text.Show import Text.Show
...@@ -29,10 +28,6 @@ instance Show Tree where ...@@ -29,10 +28,6 @@ instance Show Tree where
showsPrec _ (Node _ l r) = showString "(Node " . shows l . showsPrec _ (Node _ l r) = showString "(Node " . shows l .
showString " " . shows r . showString ")" 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 #-} {-# NOINLINE test #-}
test x = do test x = do
let a = Node Nil x b let a = Node Nil x b
......
import Control.Concurrent import Control.Concurrent
import Control.DeepSeq
import Control.Exception import Control.Exception
import Data.Compact import Data.Compact
data HiddenMVar = HiddenMVar (MVar ()) data HiddenMVar = HiddenMVar (MVar ())
instance NFData HiddenMVar where
rnf x = x `seq` () -- ignore the function inside
main = do main = do
m <- newEmptyMVar m <- newEmptyMVar
compact (HiddenMVar m) compact (HiddenMVar m)
import Control.DeepSeq
import Control.Exception import Control.Exception
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Compact import Data.Compact
......
...@@ -7,7 +7,6 @@ import System.Mem ...@@ -7,7 +7,6 @@ import System.Mem
import Data.IORef import Data.IORef
import Data.ByteString (ByteString, packCStringLen) import Data.ByteString (ByteString, packCStringLen)
import Foreign.Ptr import Foreign.Ptr
import Control.DeepSeq
import Data.Compact import Data.Compact
import Data.Compact.Internal import Data.Compact.Internal
...@@ -22,7 +21,7 @@ assertEquals expected actual = ...@@ -22,7 +21,7 @@ assertEquals expected actual =
else assertFail $ "expected " ++ (show expected) else assertFail $ "expected " ++ (show expected)
++ ", got " ++ (show actual) ++ ", got " ++ (show actual)
serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString]) serialize :: a -> IO (SerializedCompact a, [ByteString])
serialize val = do serialize val = do
cnf <- compactSized 4096 True val cnf <- compactSized 4096 True val
......
...@@ -8,7 +8,6 @@ import Control.Monad.ST ...@@ -8,7 +8,6 @@ import Control.Monad.ST
import Data.Array import Data.Array
import Data.Array.ST import Data.Array.ST
import qualified Data.Array.Unboxed as U import qualified Data.Array.Unboxed as U
import Control.DeepSeq
import Data.Compact import Data.Compact
import Data.Compact.Internal import Data.Compact.Internal
...@@ -29,9 +28,6 @@ arrTest = do ...@@ -29,9 +28,6 @@ arrTest = do
writeArray arr j (fromIntegral $ 2*j + 1) writeArray arr j (fromIntegral $ 2*j + 1)
return arr return arr
instance NFData (U.UArray i e) where
rnf x = seq x ()
-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO () -- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
test func = do test func = do
let fromList :: Array Int Int let fromList :: Array Int Int
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment