{-# 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.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
data SerializedCompact a = SerializedCompact
{ forall a. SerializedCompact a -> [(Ptr (), Word)]
serializedCompactBlockList :: [(Ptr (), Word)]
, forall a. SerializedCompact a -> Ptr ()
serializedCompactRoot :: Ptr ()
}
addrIsNull :: Addr# -> Bool
addrIsNull :: Addr# -> Bool
addrIsNull Addr#
addr = Int# -> Bool
isTrue# (Addr#
nullAddr# Addr# -> Addr# -> Int#
`eqAddr#` Addr#
addr)
compactGetFirstBlock :: Compact# -> IO (Ptr a, Word)
compactGetFirstBlock :: forall a. Compact# -> IO (Ptr a, Word)
compactGetFirstBlock Compact#
buffer =
(State# RealWorld -> (# State# RealWorld, (Ptr a, Word) #))
-> IO (Ptr a, Word)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case Compact#
-> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
compactGetFirstBlock# Compact#
buffer State# RealWorld
s of
(# State# RealWorld
s', Addr#
addr, 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 :: forall a. Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock Compact#
buffer Addr#
block =
(State# RealWorld -> (# State# RealWorld, (Ptr a, Word) #))
-> IO (Ptr a, Word)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case Compact#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Addr#, Word# #)
compactGetNextBlock# Compact#
buffer Addr#
block State# RealWorld
s of
(# State# RealWorld
s', Addr#
addr, 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 :: forall a. Compact# -> IO [(Ptr a, Word)]
mkBlockList 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 :: forall a. (Ptr a, Word) -> IO [(Ptr a, Word)]
go (Ptr Addr#
block, Word
_) | 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 Addr#
block, Word
_) = 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
withSerializedCompact :: Compact a ->
(SerializedCompact a -> IO c) -> IO c
withSerializedCompact :: forall a c. Compact a -> (SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact Compact#
buffer a
root MVar ()
lock) 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 ()
rootPtr <- (State# RealWorld -> (# State# RealWorld, Ptr () #)) -> IO (Ptr ())
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\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
(# State# RealWorld
s', Addr#
rootAddr #) -> (# State# RealWorld
s', Addr# -> Ptr ()
forall a. Addr# -> Ptr a
Ptr Addr#
rootAddr #) )
[(Ptr (), Word)]
blockList <- Compact# -> IO [(Ptr (), Word)]
forall a. Compact# -> IO [(Ptr a, Word)]
mkBlockList Compact#
buffer
let serialized :: SerializedCompact a
serialized = [(Ptr (), Word)] -> Ptr () -> SerializedCompact a
forall a. [(Ptr (), Word)] -> Ptr () -> SerializedCompact a
SerializedCompact [(Ptr (), Word)]
blockList Ptr ()
rootPtr
(State# RealWorld -> (# State# RealWorld, c #)) -> IO c
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, c #)) -> IO c)
-> (State# RealWorld -> (# State# RealWorld, c #)) -> IO c
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> Compact#
-> State# RealWorld
-> (State# RealWorld -> (# State# RealWorld, c #))
-> (# State# RealWorld, c #)
keepAlive# Compact#
buffer State# RealWorld
s (IO c -> State# RealWorld -> (# State# RealWorld, c #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO c -> State# RealWorld -> (# State# RealWorld, c #))
-> IO c -> State# RealWorld -> (# State# RealWorld, c #)
forall a b. (a -> b) -> a -> b
$ SerializedCompact a -> IO c
func SerializedCompact a
forall {a}. SerializedCompact a
serialized)
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
fixupPointers :: forall a.
Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Maybe (Compact a) #)
fixupPointers Addr#
firstBlock Addr#
rootAddr State# RealWorld
s =
case Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Compact#, Addr# #)
compactFixupPointers# Addr#
firstBlock Addr#
rootAddr State# RealWorld
s of
(# State# RealWorld
s', Compact#
buffer, 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
(# 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
(# State# RealWorld
s'', 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 :: forall a b.
SerializedCompact a
-> (Ptr b -> Word -> IO ()) -> IO (Maybe (Compact a))
importCompact (SerializedCompact [] Ptr ()
_) Ptr b -> Word -> IO ()
_ = 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 [(Ptr (), Word)]
blocks Ptr ()
root) Ptr b -> Word -> IO ()
filler = do
let !((Ptr ()
_, W# Word#
firstSize):[(Ptr (), Word)]
otherBlocks) = [(Ptr (), Word)]
blocks
let !(Ptr Addr#
rootAddr) = Ptr ()
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
$ \State# RealWorld
s0 ->
case Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
compactAllocateBlock# Word#
firstSize Addr#
nullAddr# State# RealWorld
s0 of {
(# State# RealWorld
s1, Addr#
firstBlock #) ->
case Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock Addr#
firstBlock Word#
firstSize State# RealWorld
s1 of { State# RealWorld
s2 ->
case Addr# -> [(Ptr (), Word)] -> State# RealWorld -> State# RealWorld
forall a.
Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go Addr#
firstBlock [(Ptr (), Word)]
otherBlocks State# RealWorld
s2 of { 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 Word#
size 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 State# RealWorld -> (# State# RealWorld, () #)
action -> case State# RealWorld -> (# State# RealWorld, () #)
action State# RealWorld
s of
(# State# RealWorld
s', ()
_ #) -> State# RealWorld
s'
go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go :: forall a.
Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go Addr#
_ [] State# RealWorld
s = State# RealWorld
s
go Addr#
previous ((Ptr a
_, W# Word#
size):[(Ptr a, Word)]
rest) State# RealWorld
s =
case Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
compactAllocateBlock# Word#
size Addr#
previous State# RealWorld
s of
(# State# RealWorld
s', Addr#
block #) -> case Addr# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock Addr#
block Word#
size State# RealWorld
s' of
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 :: forall a. SerializedCompact a -> [ByteString] -> Bool
sanityCheckByteStrings (SerializedCompact [(Ptr (), Word)]
scl Ptr ()
_) [ByteString]
bsl = [(Ptr (), Word)] -> [ByteString] -> Bool
forall {a} {a}. Integral a => [(a, a)] -> [ByteString] -> Bool
go [(Ptr (), Word)]
scl [ByteString]
bsl
where
go :: [(a, a)] -> [ByteString] -> Bool
go [] [] = Bool
True
go ((a, a)
_:[(a, a)]
_) [] = Bool
False
go [] (ByteString
_:[ByteString]
_) = Bool
False
go ((a
_, a
size):[(a, a)]
scs) (ByteString
bs:[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 :: forall a.
SerializedCompact a -> [ByteString] -> IO (Maybe (Compact a))
importCompactByteStrings SerializedCompact a
serialized [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 Ptr Word8
to Word
size = do
(ByteString
next:[ByteString]
rest) <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
state
let (ForeignPtr Word8
fp, Int
off, Int
_) = 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
$ \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