{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
BangPatterns, CPP, MagicHash, FlexibleInstances, FlexibleContexts,
TypeApplications, ScopedTypeVariables, UnboxedTuples, UndecidableInstances #-}
module GHCi.ResolvedBCO
( ResolvedBCO(..)
, ResolvedBCOPtr(..)
, isLittleEndian
, BCOByteArray(..)
, mkBCOByteArray
) where
#include "MachDeps.h"
import Prelude
import GHC.Data.SmallArray
import GHCi.RemoteTypes
import GHCi.BreakArray
#if SIZEOF_HSWORD == 4
import Control.Monad
import Data.Array.Base (foldrArray, listArray)
import Data.ByteString.Builder.Extra
import Foreign.Storable
#endif
import Data.Binary (Binary(..))
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString.Short (ShortByteString(..))
import Data.Word
import GHC.Generics
import GHC.Exts
import Data.Array.Base (UArray(..))
import qualified GHC.Exts.Heap as Heap
#include "MachDeps.h"
isLittleEndian :: Bool
#if defined(WORDS_BIGENDIAN)
isLittleEndian = False
#else
isLittleEndian :: Bool
isLittleEndian = Bool
True
#endif
data ResolvedBCO
= ResolvedBCO {
ResolvedBCO -> Bool
resolvedBCOIsLE :: !Bool,
ResolvedBCO -> Int
resolvedBCOArity :: {-# UNPACK #-} !Int,
ResolvedBCO -> BCOByteArray Word16
resolvedBCOInstrs :: !(BCOByteArray Word16),
ResolvedBCO -> BCOByteArray Word
resolvedBCOBitmap :: !(BCOByteArray Word),
ResolvedBCO -> BCOByteArray Word
resolvedBCOLits :: !(BCOByteArray Word),
ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedBCOPtrs :: !(SmallArray ResolvedBCOPtr)
}
| ResolvedStaticCon {
resolvedBCOIsLE :: !Bool,
ResolvedBCO -> RemotePtr StgInfoTable
resolvedStaticConInfoPtr :: !(RemotePtr Heap.StgInfoTable),
ResolvedBCO -> Word
resolvedStaticConArity :: {-# UNPACK #-} !Word,
ResolvedBCO -> BCOByteArray Word
resolvedStaticConLits :: !(BCOByteArray Word),
ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConPtrs :: !(SmallArray ResolvedBCOPtr),
ResolvedBCO -> Bool
resolvedStaticConIsUnlifted :: !Bool
}
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)
data BCOByteArray a
= BCOByteArray {
forall a. BCOByteArray a -> ByteArray#
getBCOByteArray :: !ByteArray#
}
#if SIZEOF_HSWORD == 4
fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a
fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba#
where
len# = sizeofByteArray# ba#
n = (I# len#) `div` sizeOf (undefined :: a)
#endif
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
unsafePutFixedWidthBCOByteArray :: BCOByteArray a -> Put
unsafePutFixedWidthBCOByteArray :: forall a. BCOByteArray a -> Put
unsafePutFixedWidthBCOByteArray (BCOByteArray ByteArray#
ba#) = ShortByteString -> Put
forall t. Binary t => t -> Put
put (ShortByteString -> Put) -> ShortByteString -> Put
forall a b. (a -> b) -> a -> b
$ ByteArray# -> ShortByteString
SBS ByteArray#
ba#
unsafeGetFixedWidthBCOByteArray :: Get (BCOByteArray a)
unsafeGetFixedWidthBCOByteArray :: forall a. Get (BCOByteArray a)
unsafeGetFixedWidthBCOByteArray = (\(SBS ByteArray#
ba#) -> ByteArray# -> BCOByteArray a
forall a. ByteArray# -> BCOByteArray a
BCOByteArray ByteArray#
ba#) (ShortByteString -> BCOByteArray a)
-> Get ShortByteString -> Get (BCOByteArray a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ShortByteString
forall t. Binary t => Get t
get
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"
instance Binary ResolvedBCO where
put :: ResolvedBCO -> Put
put ResolvedBCO{Bool
Int
SmallArray 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 -> SmallArray ResolvedBCOPtr
resolvedBCOIsLE :: Bool
resolvedBCOArity :: Int
resolvedBCOInstrs :: BCOByteArray Word16
resolvedBCOBitmap :: BCOByteArray Word
resolvedBCOLits :: BCOByteArray Word
resolvedBCOPtrs :: SmallArray ResolvedBCOPtr
..} = do
Word8 -> Put
putWord8 Word8
0
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
SmallArray ResolvedBCOPtr -> Put
forall t. Binary t => t -> Put
put SmallArray ResolvedBCOPtr
resolvedBCOPtrs
put ResolvedStaticCon{Bool
Word
SmallArray ResolvedBCOPtr
RemotePtr StgInfoTable
BCOByteArray Word
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedStaticConInfoPtr :: ResolvedBCO -> RemotePtr StgInfoTable
resolvedStaticConArity :: ResolvedBCO -> Word
resolvedStaticConLits :: ResolvedBCO -> BCOByteArray Word
resolvedStaticConPtrs :: ResolvedBCO -> SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: ResolvedBCO -> Bool
resolvedBCOIsLE :: Bool
resolvedStaticConInfoPtr :: RemotePtr StgInfoTable
resolvedStaticConArity :: Word
resolvedStaticConLits :: BCOByteArray Word
resolvedStaticConPtrs :: SmallArray ResolvedBCOPtr
resolvedStaticConIsUnlifted :: Bool
..} = do
Word8 -> Put
putWord8 Word8
1
Bool -> Put
forall t. Binary t => t -> Put
put Bool
resolvedBCOIsLE
RemotePtr StgInfoTable -> Put
forall t. Binary t => t -> Put
put RemotePtr StgInfoTable
resolvedStaticConInfoPtr
Word -> Put
forall t. Binary t => t -> Put
put Word
resolvedStaticConArity
BCOByteArray Word -> Put
forall t. Binary t => t -> Put
put BCOByteArray Word
resolvedStaticConLits
SmallArray ResolvedBCOPtr -> Put
forall t. Binary t => t -> Put
put SmallArray ResolvedBCOPtr
resolvedStaticConPtrs
Bool -> Put
forall t. Binary t => t -> Put
put Bool
resolvedStaticConIsUnlifted
get :: Get ResolvedBCO
get = do
t <- Get Word8
getWord8
case t of
Word8
0 -> Bool
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> ResolvedBCO
Bool
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> ResolvedBCO
ResolvedBCO (Bool
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> ResolvedBCO)
-> Get Bool
-> Get
(Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SmallArray 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
-> SmallArray ResolvedBCOPtr
-> ResolvedBCO)
-> Get Int
-> Get
(BCOByteArray Word16
-> BCOByteArray Word
-> BCOByteArray Word
-> SmallArray 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
-> SmallArray ResolvedBCOPtr
-> ResolvedBCO)
-> Get (BCOByteArray Word16)
-> Get
(BCOByteArray Word
-> BCOByteArray Word -> SmallArray 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 -> SmallArray ResolvedBCOPtr -> ResolvedBCO)
-> Get (BCOByteArray Word)
-> Get
(BCOByteArray Word -> SmallArray 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 -> SmallArray ResolvedBCOPtr -> ResolvedBCO)
-> Get (BCOByteArray Word)
-> Get (SmallArray 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 (SmallArray ResolvedBCOPtr -> ResolvedBCO)
-> Get (SmallArray 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 (SmallArray ResolvedBCOPtr)
forall t. Binary t => Get t
get
Word8
1 -> Bool
-> RemotePtr StgInfoTable
-> Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO
Bool
-> RemotePtr StgInfoTable
-> Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO
ResolvedStaticCon (Bool
-> RemotePtr StgInfoTable
-> Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO)
-> Get Bool
-> Get
(RemotePtr StgInfoTable
-> Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Bool
forall t. Binary t => Get t
get Get
(RemotePtr StgInfoTable
-> Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO)
-> Get (RemotePtr StgInfoTable)
-> Get
(Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> 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 (RemotePtr StgInfoTable)
forall t. Binary t => Get t
get Get
(Word
-> BCOByteArray Word
-> SmallArray ResolvedBCOPtr
-> Bool
-> ResolvedBCO)
-> Get Word
-> Get
(BCOByteArray Word
-> SmallArray ResolvedBCOPtr -> Bool -> 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 Word
forall t. Binary t => Get t
get Get
(BCOByteArray Word
-> SmallArray ResolvedBCOPtr -> Bool -> ResolvedBCO)
-> Get (BCOByteArray Word)
-> Get (SmallArray ResolvedBCOPtr -> Bool -> 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 (SmallArray ResolvedBCOPtr -> Bool -> ResolvedBCO)
-> Get (SmallArray ResolvedBCOPtr) -> Get (Bool -> 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 (SmallArray ResolvedBCOPtr)
forall t. Binary t => Get t
get Get (Bool -> ResolvedBCO) -> Get Bool -> 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 Bool
forall t. Binary t => Get t
get
Word8
_ -> String -> Get ResolvedBCO
forall a. HasCallStack => String -> a
error String
"Binary ResolvedBCO: invalid byte"
instance Binary (BCOByteArray Word16) where
put :: BCOByteArray Word16 -> Put
put = BCOByteArray Word16 -> Put
forall a. BCOByteArray a -> Put
unsafePutFixedWidthBCOByteArray
get :: Get (BCOByteArray Word16)
get = Get (BCOByteArray Word16)
forall a. Get (BCOByteArray a)
unsafeGetFixedWidthBCOByteArray
instance Binary (BCOByteArray Word) where
#if SIZEOF_HSWORD == 8
put :: BCOByteArray Word -> Put
put = BCOByteArray Word -> Put
forall a. BCOByteArray a -> Put
unsafePutFixedWidthBCOByteArray
get :: Get (BCOByteArray Word)
get = Get (BCOByteArray Word)
forall a. Get (BCOByteArray a)
unsafeGetFixedWidthBCOByteArray
#else
put ba32@(BCOByteArray ba32#) =
put len64 *>
putBuilder
(foldrArray (\w32 acc -> word64Host (fromIntegral w32) <> acc) mempty arr32)
where
len32# = sizeofByteArray# ba32#
len64 = I# len32# * 2
arr32 = fromBCOByteArray ba32
get = do
len64 <- get
let len = len64 `div` 8
w32s <- replicateM len (fromIntegral <$> getWord64host)
pure $ mkBCOByteArray $ listArray (0, len - 1) w32s
#endif
data ResolvedBCOPtr
= ResolvedBCORef {-# UNPACK #-} !Int
| ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
| ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
| ResolvedBCOPtrBCO ResolvedBCO
| ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
| ResolvedStaticConRef {-# UNPACK #-} !Int
| ResolvedUnliftedStaticConRef {-# UNPACK #-} !Int
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