{-# 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 :: UArray i a -> Put
putArray (A.UArray l :: i
l u :: i
u _ arr# :: 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 arr# :: 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 0 (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
arr#))
  where
    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
    go :: Int -> Int -> BuildStep a -> BuildStep a
go !Int
inStart !Int
inEnd k :: BuildStep a
k (BB.BufferRange outStart :: Ptr Word8
outStart outEnd :: 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 (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 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 :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
copyByteArrayToAddr src# :: ByteArray#
src# (I# src_off# :: Int#
src_off#) (Ptr dst# :: Addr#
dst#) (I# len# :: 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
$ \s :: 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
                     s' :: 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 :: 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 _ _ _ arr# :: MutableByteArray# RealWorld
arr#)) <-
        IOUArray i a -> Get (IOUArray i 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 (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 0 _ = () -> Get ()
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 ->
              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#)) 0
    UArray i a -> Get (UArray i 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 = 10Int -> Int -> Int
forall a. Num a => a -> a -> a
*1024

    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
                        -> Int -> Int -> IO ()
    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld -> Int -> Int -> IO ()
copyAddrToByteArray (Ptr src# :: Addr#
src#) dst# :: MutableByteArray# RealWorld
dst# (I# dst_off# :: Int#
dst_off#) (I# len# :: 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
$ \s :: 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
                     s' :: 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 :: IOUArray ix e -> IO (UArray ix e)
unsafeFreezeIOUArray (A.IOUArray marr :: 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)