{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module GHC.Compact.Serialized(
SerializedCompact(..),
withSerializedCompact,
importCompact,
importCompactByteStrings,
) where
import GHC.Prim
import GHC.Types
import GHC.Word (Word8)
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
data SerializedCompact a = SerializedCompact
{ SerializedCompact a -> [(Ptr a, Word)]
serializedCompactBlockList :: [(Ptr a, Word)]
, SerializedCompact a -> Ptr a
serializedCompactRoot :: Ptr a
}
addrIsNull :: Addr# -> Bool
addrIsNull :: Addr# -> Bool
addrIsNull addr :: Addr#
addr = Int# -> Bool
isTrue# (Addr#
nullAddr# Addr# -> Addr# -> Int#
`eqAddr#` Addr#
addr)
compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
compactGetFirstBlock buffer :: Compact#
buffer =
(State# RealWorld -> (# State# RealWorld, (Ptr a, Word) #))
-> IO (Ptr a, Word)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\s :: State# RealWorld
s -> case Compact#
-> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
compactGetFirstBlock# Compact#
buffer State# RealWorld
s of
(# s' :: State# RealWorld
s', addr :: Addr#
addr, size :: Word#
size #) -> (# State# RealWorld
s', (Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr, Word# -> Word
W# Word#
size) #) )
compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock buffer :: Compact#
buffer block :: Addr#
block =
(State# RealWorld -> (# State# RealWorld, (Ptr a, Word) #))
-> IO (Ptr a, Word)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\s :: State# RealWorld
s -> case Compact#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Addr#, Word# #)
compactGetNextBlock# Compact#
buffer Addr#
block State# RealWorld
s of
(# s' :: State# RealWorld
s', addr :: Addr#
addr, size :: Word#
size #) -> (# State# RealWorld
s', (Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr, Word# -> Word
W# Word#
size) #) )
mkBlockList :: Compact# -> IO [(Ptr a, Word)]
mkBlockList :: Compact# -> IO [(Ptr a, Word)]
mkBlockList buffer :: Compact#
buffer = Compact# -> IO (Ptr a, Word)
forall a. Compact# -> IO (Ptr a, Word)
compactGetFirstBlock Compact#
buffer IO (Ptr a, Word)
-> ((Ptr a, Word) -> IO [(Ptr a, Word)]) -> IO [(Ptr a, Word)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Ptr a, Word) -> IO [(Ptr a, Word)]
forall a. (Ptr a, Word) -> IO [(Ptr a, Word)]
go
where
go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
go :: (Ptr a, Word) -> IO [(Ptr a, Word)]
go (Ptr block :: Addr#
block, _) | Addr# -> Bool
addrIsNull Addr#
block = [(Ptr a, Word)] -> IO [(Ptr a, Word)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
go item :: (Ptr a, Word)
item@(Ptr block :: Addr#
block, _) = do
(Ptr a, Word)
next <- Compact# -> Addr# -> IO (Ptr a, Word)
forall a. Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock Compact#
buffer Addr#
block
[(Ptr a, Word)]
rest <- (Ptr a, Word) -> IO [(Ptr a, Word)]
forall a. (Ptr a, Word) -> IO [(Ptr a, Word)]
go (Ptr a, Word)
next
[(Ptr a, Word)] -> IO [(Ptr a, Word)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Ptr a, Word)] -> IO [(Ptr a, Word)])
-> [(Ptr a, Word)] -> IO [(Ptr a, Word)]
forall a b. (a -> b) -> a -> b
$ (Ptr a, Word)
item (Ptr a, Word) -> [(Ptr a, Word)] -> [(Ptr a, Word)]
forall a. a -> [a] -> [a]
: [(Ptr a, Word)]
rest
{-# NOINLINE withSerializedCompact #-}
withSerializedCompact :: Compact a ->
(SerializedCompact a -> IO c) -> IO c
withSerializedCompact :: Compact a -> (SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact buffer :: Compact#
buffer root :: a
root lock :: MVar ()
lock) func :: SerializedCompact a -> IO c
func = MVar () -> (() -> IO c) -> IO c
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO c) -> IO c) -> (() -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \_ -> do
Ptr a
rootPtr <- (State# RealWorld -> (# State# RealWorld, Ptr a #)) -> IO (Ptr a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\s :: State# RealWorld
s -> case a -> State# RealWorld -> (# State# RealWorld, Addr# #)
forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
anyToAddr# a
root State# RealWorld
s of
(# s' :: State# RealWorld
s', rootAddr :: Addr#
rootAddr #) -> (# State# RealWorld
s', Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
rootAddr #) )
[(Ptr a, Word)]
blockList <- Compact# -> IO [(Ptr a, Word)]
forall a. Compact# -> IO [(Ptr a, Word)]
mkBlockList Compact#
buffer
let serialized :: SerializedCompact a
serialized = [(Ptr a, Word)] -> Ptr a -> SerializedCompact a
forall a. [(Ptr a, Word)] -> Ptr a -> SerializedCompact a
SerializedCompact [(Ptr a, Word)]
blockList Ptr a
rootPtr
c
r <- SerializedCompact a -> IO c
func SerializedCompact a
serialized
(State# RealWorld -> (# State# RealWorld, c #)) -> IO c
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\s :: State# RealWorld
s -> case Compact# -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# Compact#
buffer State# RealWorld
s of
s' :: State# RealWorld
s' -> (# State# RealWorld
s', c
r #) )
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
fixupPointers :: Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Maybe (Compact a) #)
fixupPointers firstBlock :: Addr#
firstBlock rootAddr :: Addr#
rootAddr s :: State# RealWorld
s =
case Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Compact#, Addr# #)
compactFixupPointers# Addr#
firstBlock Addr#
rootAddr State# RealWorld
s of
(# s' :: State# RealWorld
s', buffer :: Compact#
buffer, adjustedRoot :: Addr#
adjustedRoot #) ->
if Addr# -> Bool
addrIsNull Addr#
adjustedRoot then (# State# RealWorld
s', Maybe (Compact a)
forall a. Maybe a
Nothing #)
else case Addr# -> (# a #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
adjustedRoot of
(# root :: a
root #) -> case Compact#
-> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
forall a.
Compact#
-> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
mkCompact Compact#
buffer a
root State# RealWorld
s' of
(# s'' :: State# RealWorld
s'', c :: Compact a
c #) -> (# State# RealWorld
s'', Compact a -> Maybe (Compact a)
forall a. a -> Maybe a
Just Compact a
c #)
importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) ->
IO (Maybe (Compact a))
importCompact :: SerializedCompact a
-> (Ptr b -> Word -> IO ()) -> IO (Maybe (Compact a))
importCompact (SerializedCompact [] _) _ = Maybe (Compact a) -> IO (Maybe (Compact a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Compact a)
forall a. Maybe a
Nothing
importCompact (SerializedCompact blocks :: [(Ptr a, Word)]
blocks root :: Ptr a
root) filler :: Ptr b -> Word -> IO ()
filler = do
let !((_, W# firstSize :: Word#
firstSize):otherBlocks :: [(Ptr a, Word)]
otherBlocks) = [(Ptr a, Word)]
blocks
let !(Ptr rootAddr :: Addr#
rootAddr) = Ptr a
root
(State# RealWorld -> (# State# RealWorld, Maybe (Compact a) #))
-> IO (Maybe (Compact a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Maybe (Compact a) #))
-> IO (Maybe (Compact a)))
-> (State# RealWorld -> (# State# RealWorld, Maybe (Compact a) #))
-> IO (Maybe (Compact a))
forall a b. (a -> b) -> a -> b
$ \s0 :: State# RealWorld
s0 ->
case Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
compactAllocateBlock# Word#
firstSize Addr#
nullAddr# State# RealWorld
s0 of {
(# s1 :: State# RealWorld
s1, firstBlock :: Addr#
firstBlock #) ->
case Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock Addr#
firstBlock Word#
firstSize State# RealWorld
s1 of { s2 :: State# RealWorld
s2 ->
case Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
forall a.
Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go Addr#
firstBlock [(Ptr a, Word)]
otherBlocks State# RealWorld
s2 of { s3 :: State# RealWorld
s3 ->
Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Maybe (Compact a) #)
forall a.
Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Maybe (Compact a) #)
fixupPointers Addr#
firstBlock Addr#
rootAddr State# RealWorld
s3
}}}
where
fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock addr :: Addr#
addr size :: Word#
size s :: State# RealWorld
s = case Ptr b -> Word -> IO ()
filler (Addr# -> Ptr b
forall a. Addr# -> Ptr a
Ptr Addr#
addr) (Word# -> Word
W# Word#
size) of
IO action :: State# RealWorld -> (# State# RealWorld, () #)
action -> case State# RealWorld -> (# State# RealWorld, () #)
action State# RealWorld
s of
(# s' :: State# RealWorld
s', _ #) -> State# RealWorld
s'
go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go _ [] s :: State# RealWorld
s = State# RealWorld
s
go previous :: Addr#
previous ((_, W# size :: Word#
size):rest :: [(Ptr a, Word)]
rest) s :: State# RealWorld
s =
case Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
compactAllocateBlock# Word#
size Addr#
previous State# RealWorld
s of
(# s' :: State# RealWorld
s', block :: Addr#
block #) -> case Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock Addr#
block Word#
size State# RealWorld
s' of
s'' :: State# RealWorld
s'' -> Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
forall a.
Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go Addr#
block [(Ptr a, Word)]
rest State# RealWorld
s''
sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool
sanityCheckByteStrings :: SerializedCompact a -> [ByteString] -> Bool
sanityCheckByteStrings (SerializedCompact scl :: [(Ptr a, Word)]
scl _) bsl :: [ByteString]
bsl = [(Ptr a, Word)] -> [ByteString] -> Bool
forall a a. Integral a => [(a, a)] -> [ByteString] -> Bool
go [(Ptr a, Word)]
scl [ByteString]
bsl
where
go :: [(a, a)] -> [ByteString] -> Bool
go [] [] = Bool
True
go (_:_) [] = Bool
False
go [] (_:_) = Bool
False
go ((_, size :: a
size):scs :: [(a, a)]
scs) (bs :: ByteString
bs:bss :: [ByteString]
bss) =
a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
ByteString.length ByteString
bs Bool -> Bool -> Bool
&& [(a, a)] -> [ByteString] -> Bool
go [(a, a)]
scs [ByteString]
bss
importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] ->
IO (Maybe (Compact a))
importCompactByteStrings :: SerializedCompact a -> [ByteString] -> IO (Maybe (Compact a))
importCompactByteStrings serialized :: SerializedCompact a
serialized stringList :: [ByteString]
stringList =
if Bool -> Bool
not (SerializedCompact a -> [ByteString] -> Bool
forall a. SerializedCompact a -> [ByteString] -> Bool
sanityCheckByteStrings SerializedCompact a
serialized [ByteString]
stringList) then
Maybe (Compact a) -> IO (Maybe (Compact a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Compact a)
forall a. Maybe a
Nothing
else do
IORef [ByteString]
state <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
stringList
let filler :: Ptr Word8 -> Word -> IO ()
filler :: Ptr Word8 -> Word -> IO ()
filler to :: Ptr Word8
to size :: Word
size = do
(next :: ByteString
next:rest :: [ByteString]
rest) <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
state
let (fp :: ForeignPtr Word8
fp, off :: Int
off, _) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
next
ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \from :: Ptr Word8
from -> do
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
to (Ptr Word8
from Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size)
IORef [ByteString] -> [ByteString] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
state [ByteString]
rest
SerializedCompact a
-> (Ptr Word8 -> Word -> IO ()) -> IO (Maybe (Compact a))
forall a b.
SerializedCompact a
-> (Ptr b -> Word -> IO ()) -> IO (Maybe (Compact a))
importCompact SerializedCompact a
serialized Ptr Word8 -> Word -> IO ()
filler