{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RecordWildCards #-}

--
--  (c) The University of Glasgow 2002-2006
--

-- | Create real byte-code objects from 'ResolvedBCO's.
module GHCi.CreateBCO (createBCOs) where

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

import System.IO (fixIO)
import Control.Monad
import Data.Array.Base
import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Arr          ( Array(..) )
import GHC.Exts
import GHC.IO
import Control.Exception ( ErrorCall(..) )

createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs [ResolvedBCO]
bcos = do
  let n_bcos :: Int
n_bcos = [ResolvedBCO] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResolvedBCO]
bcos
  [HValue]
hvals <- ([HValue] -> IO [HValue]) -> IO [HValue]
forall a. (a -> IO a) -> IO a
fixIO (([HValue] -> IO [HValue]) -> IO [HValue])
-> ([HValue] -> IO [HValue]) -> IO [HValue]
forall a b. (a -> b) -> a -> b
$ \[HValue]
hvs -> do
     let arr :: Array Int HValue
arr = (Int, Int) -> [HValue] -> Array Int HValue
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0, Int
n_bcosInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [HValue]
hvs
     (ResolvedBCO -> IO HValue) -> [ResolvedBCO] -> IO [HValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Array Int HValue -> ResolvedBCO -> IO HValue
createBCO Array Int HValue
arr) [ResolvedBCO]
bcos
  (HValue -> IO HValueRef) -> [HValue] -> IO [HValueRef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef [HValue]
hvals

createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
createBCO Array Int HValue
_   ResolvedBCO{Bool
Int
UArray Int Word16
UArray Int Word64
SizedSeq ResolvedBCOPtr
resolvedBCOPtrs :: ResolvedBCO -> SizedSeq ResolvedBCOPtr
resolvedBCOLits :: ResolvedBCO -> UArray Int Word64
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedBCOInstrs :: ResolvedBCO -> UArray Int Word16
resolvedBCOBitmap :: ResolvedBCO -> UArray Int Word64
resolvedBCOArity :: ResolvedBCO -> Int
resolvedBCOPtrs :: SizedSeq ResolvedBCOPtr
resolvedBCOLits :: UArray Int Word64
resolvedBCOBitmap :: UArray Int Word64
resolvedBCOInstrs :: UArray Int Word16
resolvedBCOArity :: Int
resolvedBCOIsLE :: Bool
..} | Bool
resolvedBCOIsLE Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
isLittleEndian
  = ErrorCall -> IO HValue
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines [ String
"The endianness of the ResolvedBCO does not match"
                , String
"the systems endianness. Using ghc and iserv in a"
                , String
"mixed endianness setup is not supported!"
                ])
createBCO Array Int HValue
arr ResolvedBCO
bco
   = do BCO
linked_bco <- Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' Array Int HValue
arr ResolvedBCO
bco
        -- Note [Updatable CAF BCOs]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~~
        -- Why do we need mkApUpd0 here?  Otherwise top-level
        -- interpreted CAFs don't get updated after evaluation.  A
        -- top-level BCO will evaluate itself and return its value
        -- when entered, but it won't update itself.  Wrapping the BCO
        -- in an AP_UPD thunk will take care of the update for us.
        --
        -- Furthermore:
        --   (a) An AP thunk *must* point directly to a BCO
        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
        --   (c) An AP is always fully saturated, so we *can't* wrap
        --       non-zero arity BCOs in an AP thunk.
        --
        -- See #17424.
        if (ResolvedBCO -> Int
resolvedBCOArity ResolvedBCO
bco Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
           then HValue -> IO HValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> HValue
HValue (BCO -> Any
forall a b. a -> b
unsafeCoerce BCO
linked_bco))
           else case BCO -> (# Any #)
forall a. BCO -> (# a #)
mkApUpd0# BCO
linked_bco of { (# Any
final_bco #) ->
                  HValue -> IO HValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> HValue
HValue Any
final_bco) }


toWordArray :: UArray Int Word64 -> UArray Int Word
toWordArray :: UArray Int Word64 -> UArray Int Word
toWordArray = (Word64 -> Word) -> UArray Int Word64 -> UArray Int Word
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral

linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' Array Int HValue
arr ResolvedBCO{Bool
Int
UArray Int Word16
UArray Int Word64
SizedSeq ResolvedBCOPtr
resolvedBCOPtrs :: SizedSeq ResolvedBCOPtr
resolvedBCOLits :: UArray Int Word64
resolvedBCOBitmap :: UArray Int Word64
resolvedBCOInstrs :: UArray Int Word16
resolvedBCOArity :: Int
resolvedBCOIsLE :: Bool
resolvedBCOPtrs :: ResolvedBCO -> SizedSeq ResolvedBCOPtr
resolvedBCOLits :: ResolvedBCO -> UArray Int Word64
resolvedBCOIsLE :: ResolvedBCO -> Bool
resolvedBCOInstrs :: ResolvedBCO -> UArray Int Word16
resolvedBCOBitmap :: ResolvedBCO -> UArray Int Word64
resolvedBCOArity :: ResolvedBCO -> Int
..} = do
  let
      ptrs :: [ResolvedBCOPtr]
ptrs   = SizedSeq ResolvedBCOPtr -> [ResolvedBCOPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq ResolvedBCOPtr
resolvedBCOPtrs
      n_ptrs :: Word
n_ptrs = SizedSeq ResolvedBCOPtr -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq ResolvedBCOPtr
resolvedBCOPtrs

      !(I# Int#
arity#)  = Int
resolvedBCOArity

      !(EmptyArr ByteArray#
empty#) = EmptyArr
emptyArr -- See Note [BCO empty array]

      barr :: UArray i e -> ByteArray#
barr UArray i e
a = case UArray i e
a of UArray i
_lo i
_hi Int
n ByteArray#
b -> if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ByteArray#
empty# else ByteArray#
b
      insns_barr :: ByteArray#
insns_barr = UArray Int Word16 -> ByteArray#
forall {i} {e}. UArray i e -> ByteArray#
barr UArray Int Word16
resolvedBCOInstrs
      bitmap_barr :: ByteArray#
bitmap_barr = UArray Int Word -> ByteArray#
forall {i} {e}. UArray i e -> ByteArray#
barr (UArray Int Word64 -> UArray Int Word
toWordArray UArray Int Word64
resolvedBCOBitmap)
      literals_barr :: ByteArray#
literals_barr = UArray Int Word -> ByteArray#
forall {i} {e}. UArray i e -> ByteArray#
barr (UArray Int Word64 -> UArray Int Word
toWordArray UArray Int Word64
resolvedBCOLits)

  PtrsArr MutableArray# RealWorld HValue
marr <- Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
mkPtrsArray Array Int HValue
arr Word
n_ptrs [ResolvedBCOPtr]
ptrs
  (State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO)
-> (State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case MutableArray# RealWorld HValue
-> State# RealWorld -> (# State# RealWorld, Array# HValue #)
forall d a.
MutableArray# d a -> State# d -> (# State# d, Array# a #)
unsafeFreezeArray# MutableArray# RealWorld HValue
marr State# RealWorld
s of { (# State# RealWorld
s, Array# HValue
arr #) ->
    case ByteArray#
-> ByteArray# -> Array# HValue -> Int# -> ByteArray# -> IO BCO
forall a.
ByteArray#
-> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO ByteArray#
insns_barr ByteArray#
literals_barr Array# HValue
arr Int#
arity# ByteArray#
bitmap_barr of { IO State# RealWorld -> (# State# RealWorld, BCO #)
io ->
    State# RealWorld -> (# State# RealWorld, BCO #)
io State# RealWorld
s
    }}


-- we recursively link any sub-BCOs while making the ptrs array
mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
mkPtrsArray Array Int HValue
arr Word
n_ptrs [ResolvedBCOPtr]
ptrs = do
  PtrsArr
marr <- Int -> IO PtrsArr
newPtrsArray (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n_ptrs)
  let
    fill :: ResolvedBCOPtr -> Int -> IO ()
fill (ResolvedBCORef Int
n) Int
i =
      Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i (Array Int HValue
arr Array Int HValue -> Int -> HValue
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
n) PtrsArr
marr  -- must be lazy!
    fill (ResolvedBCOPtr HValueRef
r) Int
i = do
      HValue
hv <- HValueRef -> IO HValue
forall a. RemoteRef a -> IO a
localRef HValueRef
r
      Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue Int
i HValue
hv PtrsArr
marr
    fill (ResolvedBCOStaticPtr RemotePtr ()
r) Int
i = do
      Int -> Ptr () -> PtrsArr -> IO ()
forall a. Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr Int
i (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
r)  PtrsArr
marr
    fill (ResolvedBCOPtrBCO ResolvedBCO
bco) Int
i = do
      BCO
bco <- Array Int HValue -> ResolvedBCO -> IO BCO
linkBCO' Array Int HValue
arr ResolvedBCO
bco
      Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO Int
i BCO
bco PtrsArr
marr
    fill (ResolvedBCOPtrBreakArray RemoteRef BreakArray
r) Int
i = do
      BA MutableByteArray# RealWorld
mba <- RemoteRef BreakArray -> IO BreakArray
forall a. RemoteRef a -> IO a
localRef RemoteRef BreakArray
r
      Int -> MutableByteArray# RealWorld -> PtrsArr -> IO ()
forall s. Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA Int
i MutableByteArray# RealWorld
mba PtrsArr
marr
  (ResolvedBCOPtr -> Int -> IO ())
-> [ResolvedBCOPtr] -> [Int] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ResolvedBCOPtr -> Int -> IO ()
fill [ResolvedBCOPtr]
ptrs [Int
0..]
  PtrsArr -> IO PtrsArr
forall (m :: * -> *) a. Monad m => a -> m a
return PtrsArr
marr

data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)

newPtrsArray :: Int -> IO PtrsArr
newPtrsArray :: Int -> IO PtrsArr
newPtrsArray (I# Int#
i) = (State# RealWorld -> (# State# RealWorld, PtrsArr #)) -> IO PtrsArr
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, PtrsArr #))
 -> IO PtrsArr)
-> (State# RealWorld -> (# State# RealWorld, PtrsArr #))
-> IO PtrsArr
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Int#
-> HValue
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld HValue #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
i HValue
forall a. HasCallStack => a
undefined State# RealWorld
s of (# State# RealWorld
s', MutableArray# RealWorld HValue
arr #) -> (# State# RealWorld
s', MutableArray# RealWorld HValue -> PtrsArr
PtrsArr MutableArray# RealWorld HValue
arr #)

writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
writePtrsArrayHValue (I# Int#
i) HValue
hv (PtrsArr MutableArray# RealWorld HValue
arr) = (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 MutableArray# RealWorld HValue
-> Int# -> HValue -> State# RealWorld -> State# RealWorld
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# RealWorld HValue
arr Int#
i HValue
hv State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr :: forall a. Int -> Ptr a -> PtrsArr -> IO ()
writePtrsArrayPtr (I# Int#
i) (Ptr Addr#
a#) (PtrsArr MutableArray# RealWorld HValue
arr) = (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 MutableArray# RealWorld HValue
-> Int# -> Addr# -> State# RealWorld -> State# RealWorld
forall s a.
MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# MutableArray# RealWorld HValue
arr Int#
i Addr#
a# State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

-- This is rather delicate: convincing GHC to pass an Addr# as an Any but
-- without making a thunk turns out to be surprisingly tricky.
{-# NOINLINE writeArrayAddr# #-}
writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# :: forall s a.
MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
writeArrayAddr# MutableArray# s a
marr Int#
i Addr#
addr State# s
s = (MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any)
-> MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
unsafeCoerce# MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray# MutableArray# s a
marr Int#
i Addr#
addr State# s
s

writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
writePtrsArrayBCO (I# Int#
i) BCO
bco (PtrsArr MutableArray# RealWorld HValue
arr) = (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 ((MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any)
-> MutableArray# RealWorld HValue
-> Int#
-> BCO
-> State# RealWorld
-> State# RealWorld
unsafeCoerce# MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray#) MutableArray# RealWorld HValue
arr Int#
i BCO
bco State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA :: forall s. Int -> MutableByteArray# s -> PtrsArr -> IO ()
writePtrsArrayMBA (I# Int#
i) MutableByteArray# s
mba (PtrsArr MutableArray# RealWorld HValue
arr) = (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 ((MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any)
-> MutableArray# RealWorld HValue
-> Int#
-> MutableByteArray# s
-> State# RealWorld
-> State# RealWorld
unsafeCoerce# MutableArray# Any Any -> Int# -> Any -> State# Any -> State# Any
forall d a. MutableArray# d a -> Int# -> a -> State# d -> State# d
writeArray#) MutableArray# RealWorld HValue
arr Int#
i MutableByteArray# s
mba State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO :: forall a.
ByteArray#
-> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO ByteArray#
instrs ByteArray#
lits Array# a
ptrs Int#
arity ByteArray#
bitmap = (State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO)
-> (State# RealWorld -> (# State# RealWorld, BCO #)) -> IO BCO
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  ByteArray#
-> ByteArray#
-> Array# a
-> Int#
-> ByteArray#
-> State# RealWorld
-> (# State# RealWorld, BCO #)
forall a d.
ByteArray#
-> ByteArray#
-> Array# a
-> Int#
-> ByteArray#
-> State# d
-> (# State# d, BCO #)
newBCO# ByteArray#
instrs ByteArray#
lits Array# a
ptrs Int#
arity ByteArray#
bitmap State# RealWorld
s

{- Note [BCO empty array]
   ~~~~~~~~~~~~~~~~~~~~~~
Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
they are 2-word heap objects.  So let's make a single empty array and
share it between all BCOs.
-}

data EmptyArr = EmptyArr ByteArray#

{-# NOINLINE emptyArr #-}
emptyArr :: EmptyArr
emptyArr :: EmptyArr
emptyArr = IO EmptyArr -> EmptyArr
forall a. IO a -> a
unsafeDupablePerformIO (IO EmptyArr -> EmptyArr) -> IO EmptyArr -> EmptyArr
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, EmptyArr #))
-> IO EmptyArr
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, EmptyArr #))
 -> IO EmptyArr)
-> (State# RealWorld -> (# State# RealWorld, EmptyArr #))
-> IO EmptyArr
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#
0# State# RealWorld
s of { (# State# RealWorld
s, MutableByteArray# RealWorld
arr #) ->
  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#
farr #) ->
  (# State# RealWorld
s, ByteArray# -> EmptyArr
EmptyArr ByteArray#
farr #)
  }}