    {-# 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 =
      (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 a b. IO a -> (a -> IO b) -> IO b
    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 a. a -> IO a
    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 a. a -> IO a
    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

    -- | 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 = 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 #)
    forall a b. a -> State# RealWorld -> (State# RealWorld -> b) -> b
    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 #)

    -- | 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 ()
    _ = Maybe (Compact a) -> IO (Maybe (Compact a))
    forall a. a -> IO 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
      -- 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
      (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
        -- 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 (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

    -- | 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 (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 a. a -> IO 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
              -- this pattern match will never fail
              (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