module GHCi.CreateBCO (createBCOs) where
import GHCi.ResolvedBCO
import GHCi.RemoteTypes
import GHCi.BreakArray
import SizedSeq
import System.IO (fixIO)
import Control.Monad
import Data.Array.Base
import Foreign hiding (newArray)
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO
import Control.Exception (throwIO, ErrorCall(..))
createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs bcos = do
let n_bcos = length bcos
hvals <- fixIO $ \hvs -> do
let arr = listArray (0, n_bcos1) hvs
mapM (createBCO arr) bcos
mapM mkRemoteRef hvals
createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
= throwIO (ErrorCall $
unlines [ "The endianness of the ResolvedBCO does not match"
, "the systems endianness. Using ghc and iserv in a"
, "mixed endianness setup is not supported!"
])
createBCO arr bco
= do BCO bco# <- linkBCO' arr bco
if (resolvedBCOArity bco > 0)
then return (HValue (unsafeCoerce# bco#))
else case mkApUpd0# bco# of { (# final_bco #) ->
return (HValue final_bco) }
toWordArray :: UArray Int Word64 -> UArray Int Word
toWordArray = amap fromIntegral
linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' arr ResolvedBCO{..} = do
let
ptrs = ssElts resolvedBCOPtrs
n_ptrs = sizeSS resolvedBCOPtrs
!(I# arity#) = resolvedBCOArity
!(EmptyArr empty#) = emptyArr
barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
insns_barr = barr resolvedBCOInstrs
bitmap_barr = barr (toWordArray resolvedBCOBitmap)
literals_barr = barr (toWordArray resolvedBCOLits)
PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
IO $ \s ->
case unsafeFreezeArray# marr s of { (# s, arr #) ->
case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
io s
}}
mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
mkPtrsArray arr n_ptrs ptrs = do
marr <- newPtrsArray (fromIntegral n_ptrs)
let
fill (ResolvedBCORef n) i =
writePtrsArrayHValue i (arr ! n) marr
fill (ResolvedBCOPtr r) i = do
hv <- localRef r
writePtrsArrayHValue i hv marr
fill (ResolvedBCOStaticPtr r) i = do
writePtrsArrayPtr i (fromRemotePtr r) marr
fill (ResolvedBCOPtrBCO bco) i = do
BCO bco# <- linkBCO' arr bco
writePtrsArrayBCO i bco# marr
fill (ResolvedBCOPtrBreakArray r) i = do
BA mba <- localRef r
writePtrsArrayMBA i mba marr
zipWithM_ fill ptrs [0..]
return marr
data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
newPtrsArray :: Int -> IO PtrsArr
newPtrsArray (I# i) = IO $ \s ->
case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
case writeArray# arr i hv s of s' -> (# s', () #)
writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
case writeArrayAddr# arr i a# s of s' -> (# s', () #)
writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
data BCO = BCO BCO#
writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs arity bitmap = IO $ \s ->
case newBCO# instrs lits ptrs arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
data EmptyArr = EmptyArr ByteArray#
emptyArr :: EmptyArr
emptyArr = unsafeDupablePerformIO $ IO $ \s ->
case newByteArray# 0# s of { (# s, arr #) ->
case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
(# s, EmptyArr farr #)
}}