{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
    BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
    TypeApplications, ScopedTypeVariables, UnboxedTuples #-}
module GHCi.ResolvedBCO
  ( ResolvedBCO(..)
  , ResolvedBCOPtr(..)
  , isLittleEndian
  , BCOByteArray(..)
  , mkBCOByteArray
  ) where

import Prelude -- See note [Why do we import Prelude here?]
import GHC.Data.SizedSeq
import GHCi.RemoteTypes
import GHCi.BreakArray

import Data.Binary
import Data.Binary.Put (putBuilder)
import GHC.Generics

import Foreign.Ptr
import Data.Array.Byte
import qualified Data.Binary.Get.Internal as Binary
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Internal as BB
import GHC.Exts
import Data.Array.Base (UArray(..))

import GHC.IO

#include "MachDeps.h"

isLittleEndian :: Bool
#if defined(WORDS_BIGENDIAN)
isLittleEndian = False
#else
isLittleEndian :: Bool
isLittleEndian = Bool
True
#endif

-- -----------------------------------------------------------------------------
-- ResolvedBCO

-- | A 'ResolvedBCO' is one in which all the 'Name' references have been
-- resolved to actual addresses or 'RemoteHValues'.
--
data ResolvedBCO
   = ResolvedBCO {
        ResolvedBCO -> Bool
resolvedBCOIsLE   :: Bool,
        ResolvedBCO -> Int
resolvedBCOArity  :: {-# UNPACK #-} !Int,
        ResolvedBCO -> BCOByteArray Word16
resolvedBCOInstrs :: BCOByteArray Word16,       -- insns
        ResolvedBCO -> BCOByteArray Word
resolvedBCOBitmap :: BCOByteArray Word,         -- bitmap
        ResolvedBCO -> BCOByteArray Word
resolvedBCOLits   :: BCOByteArray Word,         -- non-ptrs
        ResolvedBCO -> SizedSeq ResolvedBCOPtr
resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs
   }
   deriving ((forall x. ResolvedBCO -> Rep ResolvedBCO x)
-> (forall x. Rep ResolvedBCO x -> ResolvedBCO)
-> Generic ResolvedBCO
forall x. Rep ResolvedBCO x -> ResolvedBCO
forall x. ResolvedBCO -> Rep ResolvedBCO x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ResolvedBCO -> Rep ResolvedBCO x
from :: forall x. ResolvedBCO -> Rep ResolvedBCO x
$cto :: forall x. Rep ResolvedBCO x -> ResolvedBCO
to :: forall x. Rep ResolvedBCO x -> ResolvedBCO
Generic, Int -> ResolvedBCO -> ShowS
[ResolvedBCO] -> ShowS
ResolvedBCO -> String
(Int -> ResolvedBCO -> ShowS)
-> (ResolvedBCO -> String)
-> ([ResolvedBCO] -> ShowS)
-> Show ResolvedBCO
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResolvedBCO -> ShowS
showsPrec :: Int -> ResolvedBCO -> ShowS
$cshow :: ResolvedBCO -> String
show :: ResolvedBCO -> String
$cshowList :: [ResolvedBCO] -> ShowS
showList :: [ResolvedBCO] -> ShowS
Show)

-- | Wrapper for a 'ByteArray#'.
-- The phantom type tells what elements are stored in the 'ByteArray#'.
-- Creating a 'ByteArray#' can be achieved using 'UArray''s API,
-- where the underlying 'ByteArray#' can be unpacked.
data BCOByteArray a
  = BCOByteArray {
        forall a. BCOByteArray a -> ByteArray#
getBCOByteArray :: !ByteArray#
  }

mkBCOByteArray :: UArray Int a -> BCOByteArray a
mkBCOByteArray :: forall a. UArray Int a -> BCOByteArray a
mkBCOByteArray (UArray Int
_ Int
_ Int
_ ByteArray#
arr) = ByteArray# -> BCOByteArray a
forall a. ByteArray# -> BCOByteArray a
BCOByteArray ByteArray#
arr

instance Show (BCOByteArray Word16) where
  showsPrec :: Int -> BCOByteArray Word16 -> ShowS
showsPrec Int
_ BCOByteArray Word16
_ = String -> ShowS
showString String
"BCOByteArray Word16"

instance Show (BCOByteArray Word) where
  showsPrec :: Int -> BCOByteArray Word -> ShowS
showsPrec Int
_ BCOByteArray Word
_ = String -> ShowS
showString String
"BCOByteArray Word"

-- | The Binary instance for ResolvedBCOs.
--
-- Note, that we do encode the endianness, however there is no support for mixed
-- endianness setups.  This is primarily to ensure that ghc and iserv share the
-- same endianness.
instance Binary ResolvedBCO where
  put :: ResolvedBCO -> Put
put ResolvedBCO{Bool
Int
SizedSeq ResolvedBCOPtr
BCOByteArray Word
BCOByteArray Word16
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedBCOArity :: ResolvedBCO -> Int
resolvedBCOInstrs :: ResolvedBCO -> BCOByteArray Word16
resolvedBCOBitmap :: ResolvedBCO -> BCOByteArray Word
resolvedBCOLits :: ResolvedBCO -> BCOByteArray Word
resolvedBCOPtrs :: ResolvedBCO -> SizedSeq ResolvedBCOPtr
resolvedBCOIsLE :: Bool
resolvedBCOArity :: Int
resolvedBCOInstrs :: BCOByteArray Word16
resolvedBCOBitmap :: BCOByteArray Word
resolvedBCOLits :: BCOByteArray Word
resolvedBCOPtrs :: SizedSeq ResolvedBCOPtr
..} = do
    Bool -> Put
forall t. Binary t => t -> Put
put Bool
resolvedBCOIsLE
    Int -> Put
forall t. Binary t => t -> Put
put Int
resolvedBCOArity
    BCOByteArray Word16 -> Put
forall t. Binary t => t -> Put
put BCOByteArray Word16
resolvedBCOInstrs
    BCOByteArray Word -> Put
forall t. Binary t => t -> Put
put BCOByteArray Word
resolvedBCOBitmap
    BCOByteArray Word -> Put
forall t. Binary t => t -> Put
put BCOByteArray Word
resolvedBCOLits
    SizedSeq ResolvedBCOPtr -> Put
forall t. Binary t => t -> Put
put SizedSeq ResolvedBCOPtr
resolvedBCOPtrs
  get :: Get ResolvedBCO
get = Bool
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SizedSeq ResolvedBCOPtr
-> ResolvedBCO
ResolvedBCO (Bool
 -> Int
 -> BCOByteArray Word16
 -> BCOByteArray Word
 -> BCOByteArray Word
 -> SizedSeq ResolvedBCOPtr
 -> ResolvedBCO)
-> Get Bool
-> Get
     (Int
      -> BCOByteArray Word16
      -> BCOByteArray Word
      -> BCOByteArray Word
      -> SizedSeq ResolvedBCOPtr
      -> ResolvedBCO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Bool
forall t. Binary t => Get t
get Get
  (Int
   -> BCOByteArray Word16
   -> BCOByteArray Word
   -> BCOByteArray Word
   -> SizedSeq ResolvedBCOPtr
   -> ResolvedBCO)
-> Get Int
-> Get
     (BCOByteArray Word16
      -> BCOByteArray Word
      -> BCOByteArray Word
      -> SizedSeq ResolvedBCOPtr
      -> ResolvedBCO)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall t. Binary t => Get t
get Get
  (BCOByteArray Word16
   -> BCOByteArray Word
   -> BCOByteArray Word
   -> SizedSeq ResolvedBCOPtr
   -> ResolvedBCO)
-> Get (BCOByteArray Word16)
-> Get
     (BCOByteArray Word
      -> BCOByteArray Word -> SizedSeq ResolvedBCOPtr -> ResolvedBCO)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (BCOByteArray Word16)
forall t. Binary t => Get t
get Get
  (BCOByteArray Word
   -> BCOByteArray Word -> SizedSeq ResolvedBCOPtr -> ResolvedBCO)
-> Get (BCOByteArray Word)
-> Get
     (BCOByteArray Word -> SizedSeq ResolvedBCOPtr -> ResolvedBCO)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (BCOByteArray Word)
forall t. Binary t => Get t
get Get (BCOByteArray Word -> SizedSeq ResolvedBCOPtr -> ResolvedBCO)
-> Get (BCOByteArray Word)
-> Get (SizedSeq ResolvedBCOPtr -> ResolvedBCO)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (BCOByteArray Word)
forall t. Binary t => Get t
get Get (SizedSeq ResolvedBCOPtr -> ResolvedBCO)
-> Get (SizedSeq ResolvedBCOPtr) -> Get ResolvedBCO
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (SizedSeq ResolvedBCOPtr)
forall t. Binary t => Get t
get

instance Binary (BCOByteArray a) where
  put :: BCOByteArray a -> Put
put = BCOByteArray a -> Put
forall a. BCOByteArray a -> Put
putBCOByteArray
  get :: Get (BCOByteArray a)
get = Get (BCOByteArray a)
forall a. Get (BCOByteArray a)
decodeBCOByteArray


data ResolvedBCOPtr
  = ResolvedBCORef {-# UNPACK #-} !Int
      -- ^ reference to the Nth BCO in the current set
  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
      -- ^ reference to a previously created BCO
  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
      -- ^ reference to a static ptr
  | ResolvedBCOPtrBCO ResolvedBCO
      -- ^ a nested BCO
  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
      -- ^ Resolves to the MutableArray# inside the BreakArray
  deriving ((forall x. ResolvedBCOPtr -> Rep ResolvedBCOPtr x)
-> (forall x. Rep ResolvedBCOPtr x -> ResolvedBCOPtr)
-> Generic ResolvedBCOPtr
forall x. Rep ResolvedBCOPtr x -> ResolvedBCOPtr
forall x. ResolvedBCOPtr -> Rep ResolvedBCOPtr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ResolvedBCOPtr -> Rep ResolvedBCOPtr x
from :: forall x. ResolvedBCOPtr -> Rep ResolvedBCOPtr x
$cto :: forall x. Rep ResolvedBCOPtr x -> ResolvedBCOPtr
to :: forall x. Rep ResolvedBCOPtr x -> ResolvedBCOPtr
Generic, Int -> ResolvedBCOPtr -> ShowS
[ResolvedBCOPtr] -> ShowS
ResolvedBCOPtr -> String
(Int -> ResolvedBCOPtr -> ShowS)
-> (ResolvedBCOPtr -> String)
-> ([ResolvedBCOPtr] -> ShowS)
-> Show ResolvedBCOPtr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResolvedBCOPtr -> ShowS
showsPrec :: Int -> ResolvedBCOPtr -> ShowS
$cshow :: ResolvedBCOPtr -> String
show :: ResolvedBCOPtr -> String
$cshowList :: [ResolvedBCOPtr] -> ShowS
showList :: [ResolvedBCOPtr] -> ShowS
Show)

instance Binary ResolvedBCOPtr

-- --------------------------------------------------------
-- Serialisers for 'BCOByteArray'
-- --------------------------------------------------------

putBCOByteArray :: BCOByteArray a -> Put
putBCOByteArray :: forall a. BCOByteArray a -> Put
putBCOByteArray (BCOByteArray ByteArray#
bar) = do
  Int -> Put
forall t. Binary t => t -> Put
put (Int# -> Int
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
bar))
  Builder -> Put
putBuilder (Builder -> Put) -> Builder -> Put
forall a b. (a -> b) -> a -> b
$ ByteArray# -> Builder
byteArrayBuilder ByteArray#
bar

decodeBCOByteArray :: Get (BCOByteArray a)
decodeBCOByteArray :: forall a. Get (BCOByteArray a)
decodeBCOByteArray = do
  n <- Get Int
forall t. Binary t => Get t
get
  getByteArray n

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', () #)

getByteArray :: Int -> Get (BCOByteArray a)
getByteArray :: forall a. Int -> Get (BCOByteArray a)
getByteArray nbytes :: Int
nbytes@(I# Int#
nbytes#) = do
    let !(MutableByteArray MutableByteArray# RealWorld
arr#) = IO (MutableByteArray RealWorld) -> MutableByteArray RealWorld
forall a. IO a -> a
unsafeDupablePerformIO (IO (MutableByteArray RealWorld) -> MutableByteArray RealWorld)
-> IO (MutableByteArray RealWorld) -> MutableByteArray RealWorld
forall a b. (a -> b) -> a -> b
$
          (State# RealWorld
 -> (# State# RealWorld, MutableByteArray RealWorld #))
-> IO (MutableByteArray RealWorld)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld
  -> (# State# RealWorld, MutableByteArray RealWorld #))
 -> IO (MutableByteArray RealWorld))
-> (State# RealWorld
    -> (# State# RealWorld, MutableByteArray RealWorld #))
-> IO (MutableByteArray RealWorld)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
nbytes# State# RealWorld
s of
                (# State# RealWorld
s', MutableByteArray# RealWorld
mbar #) -> (# State# RealWorld
s', MutableByteArray# RealWorld -> MutableByteArray RealWorld
forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# RealWorld
mbar #)
    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
nbytes Int
0
    BCOByteArray a -> Get (BCOByteArray a)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BCOByteArray a -> Get (BCOByteArray a))
-> BCOByteArray a -> Get (BCOByteArray a)
forall a b. (a -> b) -> a -> b
$! IO (BCOByteArray a) -> BCOByteArray a
forall a. IO a -> a
unsafeDupablePerformIO (IO (BCOByteArray a) -> BCOByteArray a)
-> IO (BCOByteArray a) -> BCOByteArray a
forall a b. (a -> b) -> a -> b
$
      (State# RealWorld -> (# State# RealWorld, BCOByteArray a #))
-> IO (BCOByteArray a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, BCOByteArray a #))
 -> IO (BCOByteArray a))
-> (State# RealWorld -> (# State# RealWorld, BCOByteArray a #))
-> IO (BCOByteArray a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
arr# State# RealWorld
s of
          (# State# RealWorld
s', ByteArray#
bar #) -> (# State# RealWorld
s', ByteArray# -> BCOByteArray a
forall a. ByteArray# -> BCOByteArray a
BCOByteArray ByteArray#
bar #)
  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', () #)