Drop NFData constraint from compact.
[ghc.git] / libraries / compact / Data / Compact / Serialized.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE MagicHash #-}
4 {-# LANGUAGE UnboxedTuples #-}
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : Data.Compact.Serialized
9 -- Copyright : (c) The University of Glasgow 2001-2009
10 -- (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
11 -- License : BSD-style (see the file LICENSE)
12 --
13 -- Maintainer : libraries@haskell.org
14 -- Stability : unstable
15 -- Portability : non-portable (GHC Extensions)
16 --
17 -- This module contains support for serializing a Compact for network
18 -- transmission and on-disk storage.
19 --
20 -- /Since: 1.0.0/
21
22 module Data.Compact.Serialized(
23 SerializedCompact(..),
24 withSerializedCompact,
25 importCompact,
26 importCompactByteStrings,
27 ) where
28
29 import GHC.Prim
30 import GHC.Types
31 import GHC.Word (Word8)
32
33 import GHC.Ptr (Ptr(..), plusPtr)
34
35 import Control.Concurrent
36 import qualified Data.ByteString as ByteString
37 import Data.ByteString.Internal(toForeignPtr)
38 import Data.IORef(newIORef, readIORef, writeIORef)
39 import Foreign.ForeignPtr(withForeignPtr)
40 import Foreign.Marshal.Utils(copyBytes)
41
42 import Data.Compact.Internal
43
44 -- | A serialized version of the 'Compact' metadata (each block with
45 -- address and size and the address of the root). This structure is
46 -- meant to be sent alongside the actual 'Compact' data. It can be
47 -- sent out of band in advance if the data is to be sent over RDMA
48 -- (which requires both sender and receiver to have pinned buffers).
49 data SerializedCompact a = SerializedCompact
50 { serializedCompactBlockList :: [(Ptr a, Word)]
51 , serializedCompactRoot :: Ptr a
52 }
53
54 addrIsNull :: Addr# -> Bool
55 addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr)
56
57 compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
58 compactGetFirstBlock buffer =
59 IO (\s -> case compactGetFirstBlock# buffer s of
60 (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
61
62 compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
63 compactGetNextBlock buffer block =
64 IO (\s -> case compactGetNextBlock# buffer block s of
65 (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
66
67 mkBlockList :: Compact# -> IO [(Ptr a, Word)]
68 mkBlockList buffer = compactGetFirstBlock buffer >>= go
69 where
70 go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
71 go (Ptr block, _) | addrIsNull block = return []
72 go item@(Ptr block, _) = do
73 next <- compactGetNextBlock buffer block
74 rest <- go next
75 return $ item : rest
76
77 -- We MUST mark withSerializedCompact as NOINLINE
78 -- Otherwise the compiler will eliminate the call to touch#
79 -- causing the Compact# to be potentially GCed too eagerly,
80 -- before func had a chance to copy everything into its own
81 -- buffers/sockets/whatever
82
83 -- | Serialize the 'Compact', and call the provided function with
84 -- with the 'Compact' serialized representation. It is not safe
85 -- to return the pointer from the action and use it after
86 -- the action completes: all uses must be inside this bracket,
87 -- since we cannot guarantee that the compact region will stay
88 -- live from the 'Ptr' object. For example, it would be
89 -- unsound to use 'unsafeInterleaveIO' to lazily construct
90 -- a lazy bytestring from the 'Ptr'.
91 --
92 {-# NOINLINE withSerializedCompact #-}
93 withSerializedCompact :: Compact a ->
94 (SerializedCompact a -> IO c) -> IO c
95 withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
96 rootPtr <- IO (\s -> case anyToAddr# root s of
97 (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
98 blockList <- mkBlockList buffer
99 let serialized = SerializedCompact blockList rootPtr
100 r <- func serialized
101 IO (\s -> case touch# buffer s of
102 s' -> (# s', r #) )
103
104 fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
105 (# State# RealWorld, Maybe (Compact a) #)
106 fixupPointers firstBlock rootAddr s =
107 case compactFixupPointers# firstBlock rootAddr s of
108 (# s', buffer, adjustedRoot #) ->
109 if addrIsNull adjustedRoot then (# s', Nothing #)
110 else case addrToAny# adjustedRoot of
111 (# root #) -> case mkCompact buffer root s' of
112 (# s'', c #) -> (# s'', Just c #)
113
114 -- | Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The
115 -- provided function will be called with the address and size of each
116 -- newly allocated block in succession, and should fill the memory
117 -- from the external source (eg. by reading from a socket or from disk)
118 -- 'importCompact' can return Nothing if the 'Compact' was corrupt
119 -- or it had pointers that could not be adjusted.
120 importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) ->
121 IO (Maybe (Compact a))
122
123 -- what we would like is
124 {-
125 importCompactPtrs ((firstAddr, firstSize):rest) = do
126 (firstBlock, compact) <- compactAllocateAt firstAddr firstSize
127 #nullAddr
128 fillBlock firstBlock firstAddr firstSize
129 let go prev [] = return ()
130 go prev ((addr, size):rest) = do
131 (block, _) <- compactAllocateAt addr size prev
132 fillBlock block addr size
133 go block rest
134 go firstBlock rest
135 if isTrue# (compactFixupPointers compact) then
136 return $ Just compact
137 else
138 return Nothing
139
140 But we can't do that because IO Addr# is not valid (kind mismatch)
141 This check exists to prevent a polymorphic data constructor from using
142 an unlifted type (which would break GC) - it would not a problem for IO
143 because IO stores a function, not a value, but the kind check is there
144 anyway.
145 Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor
146 we can do IO (Addr#, Word#) (that would break the GC for real!)
147
148 And therefore we need to do everything with State# explicitly.
149 -}
150
151 -- just do shut up GHC
152 importCompact (SerializedCompact [] _) _ = return Nothing
153 importCompact (SerializedCompact blocks root) filler = do
154 -- I'm not sure why we need a bang pattern here, given that
155 -- these are obviously strict lets, but ghc complains otherwise
156 let !((_, W# firstSize):otherBlocks) = blocks
157 let !(Ptr rootAddr) = root
158 IO $ \s0 ->
159 case compactAllocateBlock# firstSize nullAddr# s0 of {
160 (# s1, firstBlock #) ->
161 case fillBlock firstBlock firstSize s1 of { s2 ->
162 case go firstBlock otherBlocks s2 of { s3 ->
163 fixupPointers firstBlock rootAddr s3
164 }}}
165 where
166 -- note that the case statements above are strict even though
167 -- they don't seem to inspect their argument because State#
168 -- is an unlifted type
169 fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld
170 fillBlock addr size s = case filler (Ptr addr) (W# size) of
171 IO action -> case action s of
172 (# s', _ #) -> s'
173
174 go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
175 go _ [] s = s
176 go previous ((_, W# size):rest) s =
177 case compactAllocateBlock# size previous s of
178 (# s', block #) -> case fillBlock block size s' of
179 s'' -> go block rest s''
180
181 sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool
182 sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl
183 where
184 go [] [] = True
185 go (_:_) [] = False
186 go [] (_:_) = False
187 go ((_, size):scs) (bs:bss) =
188 fromIntegral size == ByteString.length bs && go scs bss
189
190 -- | Convenience function for importing a compact region that is represented
191 -- by a list of strict 'ByteString's.
192 --
193 importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] ->
194 IO (Maybe (Compact a))
195 importCompactByteStrings serialized stringList =
196 -- sanity check stringList first - if we throw an exception later we leak
197 -- memory!
198 if not (sanityCheckByteStrings serialized stringList) then
199 return Nothing
200 else do
201 state <- newIORef stringList
202 let filler :: Ptr Word8 -> Word -> IO ()
203 filler to size = do
204 -- this pattern match will never fail
205 (next:rest) <- readIORef state
206 let (fp, off, _) = toForeignPtr next
207 withForeignPtr fp $ \from -> do
208 copyBytes to (from `plusPtr` off) (fromIntegral size)
209 writeIORef state rest
210 importCompact serialized filler