    {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}
    -- | Efficient serialisation for GHCi Instruction arrays
    --
    -- Author: Ben Gamari
    --
    module GHCi.BinaryArray(putArray, getArray) where

    import Prelude
    import Foreign.Ptr
    import Data.Binary
    import Data.Binary.Put (putBuilder)
    import qualified Data.Binary.Get.Internal as Binary
    import qualified Data.ByteString.Builder as BB
    import qualified Data.ByteString.Builder.Internal as BB
    import qualified Data.Array.Base as A
    import qualified Data.Array.IO.Internals as A
    import qualified Data.Array.Unboxed as A
    import GHC.Exts
    import GHC.IO

    -- | An efficient serialiser of 'A.UArray'.
    putArray :: Binary i => A.UArray i a -> Put
    putArray :: forall i a. Binary i => UArray i a -> Put
    putArray (A.UArray i
    l i
    u Int
    _ ByteArray#
    arr#) = do
        i -> Put
    forall t. Binary t => t -> Put
    put i
    l
        i -> Put
    forall t. Binary t => t -> Put
    put i
    u
        Builder -> Put
    putBuilder (Builder -> Put) -> Builder -> Put
    forall a b. (a -> b) -> a -> b
    $ ByteArray# -> Builder
    byteArrayBuilder ByteArray#
    arr#

    byteArrayBuilder :: ByteArray# -> BB.Builder
    byteArrayBuilder :: ByteArray# -> Builder
    byteArrayBuilder ByteArray#
    arr# = (forall r. BuildStep r -> BuildStep r) -> Builder
    BB.builder ((forall r. BuildStep r -> BuildStep r) -> Builder)
    -> (forall r. BuildStep r -> BuildStep r) -> Builder
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> BuildStep r -> BuildStep r
    forall a. Int -> Int -> BuildStep a -> BuildStep a
    go Int
    0 (Int# -> Int
    I# (ByteArray# -> Int#
    sizeofByteArray# ByteArray#
    arr#))
      where
        go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
        go :: forall a. Int -> Int -> BuildStep a -> BuildStep a
    go !Int
    inStart !Int
    inEnd BuildStep a
    k (BB.BufferRange Ptr Word8
    outStart Ptr Word8
    outEnd)
          -- There is enough room in this output buffer to write all remaining array
          -- contents
          | Int
    inRemaining Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    outRemaining = do
              ByteArray# -> Int -> Ptr Word8 -> Int -> IO ()
    forall a. ByteArray# -> Int -> Ptr a -> Int -> IO ()
    copyByteArrayToAddr ByteArray#
    arr# Int
    inStart Ptr Word8
    outStart Int
    inRemaining
              BuildStep a
    k (Ptr Word8 -> Ptr Word8 -> BufferRange
    BB.BufferRange (Ptr Word8
    outStart Ptr Word8 -> Int -> Ptr Word8
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    inRemaining) Ptr Word8
    outEnd)
          -- There is only enough space for a fraction of the remaining contents
          | Bool
    otherwise = do
              ByteArray# -> Int -> Ptr Word8 -> Int -> IO ()
    forall a. ByteArray# -> Int -> Ptr a -> Int -> IO ()
    copyByteArrayToAddr ByteArray#
    arr# Int
    inStart Ptr Word8
    outStart Int
    outRemaining
              let !inStart' :: Int
    inStart' = Int
    inStart Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    outRemaining
              BuildSignal a -> IO (BuildSignal a)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BuildSignal a -> IO (BuildSignal a))
    -> BuildSignal a -> IO (BuildSignal a)
    forall a b. (a -> b) -> a -> b
    $! Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
    forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
    BB.bufferFull Int
    1 Ptr Word8
    outEnd (Int -> Int -> BuildStep a -> BuildStep a
    forall a. Int -> Int -> BuildStep a -> BuildStep a
    go Int
    inStart' Int
    inEnd BuildStep a
    k)
          where
            inRemaining :: Int
    inRemaining  = Int
    inEnd Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    inStart
            outRemaining :: Int
    outRemaining = Ptr Word8
    outEnd Ptr Word8 -> Ptr Word8 -> Int
    forall a b. Ptr a -> Ptr b -> Int
    `minusPtr` Ptr Word8
    outStart

        copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
        copyByteArrayToAddr :: forall a. ByteArray# -> Int -> Ptr a -> Int -> IO ()
    copyByteArrayToAddr ByteArray#
    src# (I# Int#
    src_off#) (Ptr Addr#
    dst#) (I# Int#
    len#) =
            (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
    -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \State# RealWorld
    s -> case ByteArray#
    -> Int# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld
    forall d.
    ByteArray# -> Int# -> Addr# -> Int# -> State# d -> State# d
    copyByteArrayToAddr# ByteArray#
    src# Int#
    src_off# Addr#
    dst# Int#
    len# State# RealWorld
    s of
                         State# RealWorld
    s' -> (# State# RealWorld
    s', () #)

    -- | An efficient deserialiser of 'A.UArray'.
    getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)
    getArray :: forall i a.
    (Binary i, Ix i, MArray IOUArray a IO) =>
    Get (UArray i a)
    getArray = do
        i
    l <- Get i
    forall t. Binary t => Get t
    get
        i
    u <- Get i
    forall t. Binary t => Get t
    get
        arr :: IOUArray i a
    arr@(A.IOUArray (A.STUArray i
    _ i
    _ Int
    _ MutableByteArray# RealWorld
    arr#)) <-
            IOUArray i a -> Get (IOUArray i a)
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (IOUArray i a -> Get (IOUArray i a))
    -> IOUArray i a -> Get (IOUArray i a)
    forall a b. (a -> b) -> a -> b
    $ IO (IOUArray i a) -> IOUArray i a
    forall a. IO a -> a
    unsafeDupablePerformIO (IO (IOUArray i a) -> IOUArray i a)
    -> IO (IOUArray i a) -> IOUArray i a
    forall a b. (a -> b) -> a -> b
    $ (i, i) -> IO (IOUArray i a)
    forall i. Ix i => (i, i) -> IO (IOUArray i a)
    forall (a :: * -> * -> *) e (m :: * -> *) i.
    (MArray a e m, Ix i) =>
    (i, i) -> m (a i e)
    A.newArray_ (i
    l,i
    u)
        let go :: Int -> Int -> Get ()
    go Int
    0 Int
    _ = () -> Get ()
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            go !Int
    remaining !Int
    off = do
                Int -> (Ptr () -> IO ()) -> Get ()
    forall a. Int -> (Ptr a -> IO a) -> Get a
    Binary.readNWith Int
    n ((Ptr () -> IO ()) -> Get ()) -> (Ptr () -> IO ()) -> Get ()
    forall a b. (a -> b) -> a -> b
    $ \Ptr ()
    ptr ->
                  Ptr () -> MutableByteArray# RealWorld -> Int -> Int -> IO ()
    forall a.
    Ptr a -> MutableByteArray# RealWorld -> Int -> Int -> IO ()
    copyAddrToByteArray Ptr ()
    ptr MutableByteArray# RealWorld
    arr# Int
    off Int
    n
                Int -> Int -> Get ()
    go (Int
    remaining Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    n) (Int
    off Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    n)
              where n :: Int
    n = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    chunkSize Int
    remaining
        Int -> Int -> Get ()
    go (Int# -> Int
    I# (MutableByteArray# RealWorld -> Int#
    forall d. MutableByteArray# d -> Int#
    sizeofMutableByteArray# MutableByteArray# RealWorld
    arr#)) Int
    0
        UArray i a -> Get (UArray i a)
    forall a. a -> Get a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UArray i a -> Get (UArray i a)) -> UArray i a -> Get (UArray i a)
    forall a b. (a -> b) -> a -> b
    $! IO (UArray i a) -> UArray i a
    forall a. IO a -> a
    unsafeDupablePerformIO (IO (UArray i a) -> UArray i a) -> IO (UArray i a) -> UArray i a
    forall a b. (a -> b) -> a -> b
    $ IOUArray i a -> IO (UArray i a)
    forall ix e. IOUArray ix e -> IO (UArray ix e)
    unsafeFreezeIOUArray IOUArray i a
    arr
      where
        chunkSize :: Int
    chunkSize = Int
    10Int -> Int -> Int
    forall a. Num a => a -> a -> a
    *Int
    1024

        copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
                            -> Int -> Int -> IO ()
        copyAddrToByteArray :: forall a.
    Ptr a -> MutableByteArray# RealWorld -> Int -> Int -> IO ()
    copyAddrToByteArray (Ptr Addr#
    src#) MutableByteArray# RealWorld
    dst# (I# Int#
    dst_off#) (I# Int#
    len#) =
            (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
    -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \State# RealWorld
    s -> case Addr#
    -> MutableByteArray# RealWorld
    -> Int#
    -> Int#
    -> State# RealWorld
    -> State# RealWorld
    forall d.
    Addr#
    -> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
    copyAddrToByteArray# Addr#
    src# MutableByteArray# RealWorld
    dst# Int#
    dst_off# Int#
    len# State# RealWorld
    s of
                         State# RealWorld
    s' -> (# State# RealWorld
    s', () #)

    -- this is inexplicably not exported in currently released array versions
    unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)
    unsafeFreezeIOUArray :: forall ix e. IOUArray ix e -> IO (UArray ix e)
    unsafeFreezeIOUArray (A.IOUArray STUArray RealWorld ix e
    marr) = ST RealWorld (UArray ix e) -> IO (UArray ix e)
    forall a. ST RealWorld a -> IO a
    stToIO (STUArray RealWorld ix e -> ST RealWorld (UArray ix e)
    forall s i e. STUArray s i e -> ST s (UArray i e)
    A.unsafeFreezeSTUArray STUArray RealWorld ix e
    marr)