Improve Haddock documentation for 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 import Control.DeepSeq(NFData, force)
42
43 import Data.Compact.Internal
44
45 -- | A serialized version of the 'Compact' metadata (each block with
46 -- address and size and the address of the root). This structure is
47 -- meant to be sent alongside the actual 'Compact' data. It can be
48 -- sent out of band in advance if the data is to be sent over RDMA
49 -- (which requires both sender and receiver to have pinned buffers).
50 data SerializedCompact a = SerializedCompact
51 { serializedCompactBlockList :: [(Ptr a, Word)]
52 , serializedCompactRoot :: Ptr a
53 }
54
55 addrIsNull :: Addr# -> Bool
56 addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr)
57
58 compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
59 compactGetFirstBlock buffer =
60 IO (\s -> case compactGetFirstBlock# buffer s of
61 (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
62
63 compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
64 compactGetNextBlock buffer block =
65 IO (\s -> case compactGetNextBlock# buffer block s of
66 (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) )
67
68 mkBlockList :: Compact# -> IO [(Ptr a, Word)]
69 mkBlockList buffer = compactGetFirstBlock buffer >>= go
70 where
71 go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
72 go (Ptr block, _) | addrIsNull block = return []
73 go item@(Ptr block, _) = do
74 next <- compactGetNextBlock buffer block
75 rest <- go next
76 return $ item : rest
77
78 -- We MUST mark withSerializedCompact as NOINLINE
79 -- Otherwise the compiler will eliminate the call to touch#
80 -- causing the Compact# to be potentially GCed too eagerly,
81 -- before func had a chance to copy everything into its own
82 -- buffers/sockets/whatever
83
84 -- | Serialize the 'Compact', and call the provided function with
85 -- with the 'Compact' serialized representation. The resulting
86 -- action will be executed synchronously before this function
87 -- completes.
88 --
89 {-# NOINLINE withSerializedCompact #-}
90 withSerializedCompact :: NFData c => Compact a ->
91 (SerializedCompact a -> IO c) -> IO c
92 withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
93 rootPtr <- IO (\s -> case anyToAddr# root s of
94 (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
95 blockList <- mkBlockList buffer
96 let serialized = SerializedCompact blockList rootPtr
97 -- we must be strict, to avoid smart uses of ByteStrict.Lazy that
98 -- return a thunk instead of a ByteString (but the thunk references
99 -- the Ptr, not the Compact#, so it will point to garbage if GC
100 -- happens)
101 !r <- fmap force $ func serialized
102 IO (\s -> case touch# buffer s of
103 s' -> (# s', r #) )
104
105 fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
106 (# State# RealWorld, Maybe (Compact a) #)
107 fixupPointers firstBlock rootAddr s =
108 case compactFixupPointers# firstBlock rootAddr s of
109 (# s', buffer, adjustedRoot #) ->
110 if addrIsNull adjustedRoot then (# s', Nothing #)
111 else case addrToAny# adjustedRoot of
112 (# root #) -> case mkCompact buffer root s' of
113 (# s'', c #) -> (# s'', Just c #)
114
115 -- | Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The
116 -- provided function will be called with the address and size of each
117 -- newly allocated block in succession, and should fill the memory
118 -- from the external source (eg. by reading from a socket or from disk)
119 -- 'importCompact' can return Nothing if the 'Compact' was corrupt
120 -- or it had pointers that could not be adjusted.
121 importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) ->
122 IO (Maybe (Compact a))
123
124 -- what we would like is
125 {-
126 importCompactPtrs ((firstAddr, firstSize):rest) = do
127 (firstBlock, compact) <- compactAllocateAt firstAddr firstSize
128 #nullAddr
129 fillBlock firstBlock firstAddr firstSize
130 let go prev [] = return ()
131 go prev ((addr, size):rest) = do
132 (block, _) <- compactAllocateAt addr size prev
133 fillBlock block addr size
134 go block rest
135 go firstBlock rest
136 if isTrue# (compactFixupPointers compact) then
137 return $ Just compact
138 else
139 return Nothing
140
141 But we can't do that because IO Addr# is not valid (kind mismatch)
142 This check exists to prevent a polymorphic data constructor from using
143 an unlifted type (which would break GC) - it would not a problem for IO
144 because IO stores a function, not a value, but the kind check is there
145 anyway.
146 Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor
147 we can do IO (Addr#, Word#) (that would break the GC for real!)
148
149 And therefore we need to do everything with State# explicitly.
150 -}
151
152 -- just do shut up GHC
153 importCompact (SerializedCompact [] _) _ = return Nothing
154 importCompact (SerializedCompact blocks root) filler = do
155 -- I'm not sure why we need a bang pattern here, given that
156 -- these are obviously strict lets, but ghc complains otherwise
157 let !((_, W# firstSize):otherBlocks) = blocks
158 let !(Ptr rootAddr) = root
159 IO $ \s0 ->
160 case compactAllocateBlock# firstSize nullAddr# s0 of {
161 (# s1, firstBlock #) ->
162 case fillBlock firstBlock firstSize s1 of { s2 ->
163 case go firstBlock otherBlocks s2 of { s3 ->
164 fixupPointers firstBlock rootAddr s3
165 }}}
166 where
167 -- note that the case statements above are strict even though
168 -- they don't seem to inspect their argument because State#
169 -- is an unlifted type
170 fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld
171 fillBlock addr size s = case filler (Ptr addr) (W# size) of
172 IO action -> case action s of
173 (# s', _ #) -> s'
174
175 go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
176 go _ [] s = s
177 go previous ((_, W# size):rest) s =
178 case compactAllocateBlock# size previous s of
179 (# s', block #) -> case fillBlock block size s' of
180 s'' -> go block rest s''
181
182 sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool
183 sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl
184 where
185 go [] [] = True
186 go (_:_) [] = False
187 go [] (_:_) = False
188 go ((_, size):scs) (bs:bss) =
189 fromIntegral size == ByteString.length bs && go scs bss
190
191 -- | Convenience function for importing a compact region that is represented
192 -- by a list of strict 'ByteString's.
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