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