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