{-# 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
    forall t. Binary t => t -> Put
put i
l
    forall t. Binary t => t -> Put
put i
u
    Builder -> Put
putBuilder 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 a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> Bool
<= Int
outRemaining = do
          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 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
          forall a. ByteArray# -> Int -> Ptr a -> Int -> IO ()
copyByteArrayToAddr ByteArray#
arr# Int
inStart Ptr Word8
outStart Int
outRemaining
          let !inStart' :: Int
inStart' = Int
inStart forall a. Num a => a -> a -> a
+ Int
outRemaining
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
BB.bufferFull Int
1 Ptr Word8
outEnd (forall a. Int -> Int -> BuildStep a -> BuildStep a
go Int
inStart' Int
inEnd BuildStep a
k)
      where
        inRemaining :: Int
inRemaining  = Int
inEnd forall a. Num a => a -> a -> a
- Int
inStart
        outRemaining :: Int
outRemaining = Ptr Word8
outEnd 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#) =
        forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case 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 <- forall t. Binary t => Get t
get
    i
u <- forall t. Binary t => Get t
get
    arr :: IOUArray i a
arr@(A.IOUArray (A.STUArray i
_ i
_ Int
_ MutableByteArray# RealWorld
arr#)) <-
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go !Int
remaining !Int
off = do
            forall a. Int -> (Ptr a -> IO a) -> Get a
Binary.readNWith Int
n forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
              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 forall a. Num a => a -> a -> a
- Int
n) (Int
off forall a. Num a => a -> a -> a
+ Int
n)
          where n :: Int
n = forall a. Ord a => a -> a -> a
min Int
chunkSize Int
remaining
    Int -> Int -> Get ()
go (Int# -> Int
I# (forall d. MutableByteArray# d -> Int#
sizeofMutableByteArray# MutableByteArray# RealWorld
arr#)) Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ forall ix e. IOUArray ix e -> IO (UArray ix e)
unsafeFreezeIOUArray IOUArray i a
arr
  where
    chunkSize :: Int
chunkSize = Int
10forall 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#) =
        forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case 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) = forall a. ST RealWorld a -> IO a
stToIO (forall s i e. STUArray s i e -> ST s (UArray i e)
A.unsafeFreezeSTUArray STUArray RealWorld ix e
marr)