{-# 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
  { 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 =
  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', (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 =
  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', (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 = forall a. Compact# -> IO (Ptr a, Word)
compactGetFirstBlock Compact#
buffer forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go item :: (Ptr a, Word)
item@(Ptr Addr#
block, Word
_) = do
      (Ptr a, Word)
next <- forall a. Compact# -> Addr# -> IO (Ptr a, Word)
compactGetNextBlock Compact#
buffer Addr#
block
      [(Ptr a, Word)]
rest <- forall a. (Ptr a, Word) -> IO [(Ptr a, Word)]
go (Ptr a, Word)
next
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Ptr a, Word)
item forall a. a -> [a] -> [a]
: [(Ptr a, Word)]
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 :: forall a c. Compact a -> (SerializedCompact a -> IO c) -> IO c
withSerializedCompact (Compact Compact#
buffer a
root MVar ()
lock) SerializedCompact a -> IO c
func = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock forall a b. (a -> b) -> a -> b
$ \()
_ -> do
  Ptr ()
rootPtr <- forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case forall a. a -> State# RealWorld -> (# State# RealWorld, Addr# #)
anyToAddr# a
root State# RealWorld
s of
                    (# State# RealWorld
s', Addr#
rootAddr #) -> (# State# RealWorld
s', forall a. Addr# -> Ptr a
Ptr Addr#
rootAddr #) )
  [(Ptr (), Word)]
blockList <- forall a. Compact# -> IO [(Ptr a, Word)]
mkBlockList Compact#
buffer
  let serialized :: SerializedCompact a
serialized = forall a. [(Ptr (), Word)] -> Ptr () -> SerializedCompact a
SerializedCompact [(Ptr (), Word)]
blockList Ptr ()
rootPtr
  forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> keepAlive# :: forall a b. a -> State# RealWorld -> (State# RealWorld -> b) -> b
keepAlive# Compact#
buffer State# RealWorld
s (forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO forall a b. (a -> b) -> a -> b
$ SerializedCompact a -> IO c
func 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', forall a. Maybe a
Nothing #)
      else case forall a. Addr# -> (# a #)
addrToAny# Addr#
adjustedRoot of
        (# a
root #) -> case 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'', forall a. a -> Maybe a
Just Compact a
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 :: forall a b.
SerializedCompact a
-> (Ptr b -> Word -> IO ()) -> IO (Maybe (Compact a))
importCompact (SerializedCompact [] Ptr ()
_) Ptr b -> Word -> IO ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
importCompact (SerializedCompact [(Ptr (), Word)]
blocks Ptr ()
root) Ptr b -> Word -> IO ()
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 !((Ptr ()
_, W# Word#
firstSize):[(Ptr (), Word)]
otherBlocks) = [(Ptr (), Word)]
blocks
  let !(Ptr Addr#
rootAddr) = Ptr ()
root
  forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO 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 forall a.
Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld
go Addr#
firstBlock [(Ptr (), Word)]
otherBlocks State# RealWorld
s2 of { State# RealWorld
s3 ->
    forall a.
Addr#
-> Addr#
-> State# RealWorld
-> (# State# RealWorld, Maybe (Compact a) #)
fixupPointers Addr#
firstBlock Addr#
rootAddr State# RealWorld
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# -> Word# -> State# RealWorld -> State# RealWorld
fillBlock Addr#
addr Word#
size State# RealWorld
s = case Ptr b -> Word -> IO ()
filler (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'' -> 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 = 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) =
      forall a b. (Integral a, Num b) => a -> b
fromIntegral a
size 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

-- | 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 :: forall a.
SerializedCompact a -> [ByteString] -> IO (Maybe (Compact a))
importCompactByteStrings SerializedCompact a
serialized [ByteString]
stringList =
  -- sanity check stringList first - if we throw an exception later we leak
  -- memory!
  if Bool -> Bool
not (forall a. SerializedCompact a -> [ByteString] -> Bool
sanityCheckByteStrings SerializedCompact a
serialized [ByteString]
stringList) then
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  else do
    IORef [ByteString]
state <- 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
          -- this pattern match will never fail
          (ByteString
next:[ByteString]
rest) <- 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
          forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
from -> do
            forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
to (Ptr Word8
from forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size)
          forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
state [ByteString]
rest
    forall a b.
SerializedCompact a
-> (Ptr b -> Word -> IO ()) -> IO (Maybe (Compact a))
importCompact SerializedCompact a
serialized Ptr Word8 -> Word -> IO ()
filler