{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module GHC.ByteCode.Linker
( ClosureEnv
, emptyClosureEnv
, extendClosureEnv
, linkBCO
, lookupStaticPtr
, lookupIE
, nameToCLabel
, linkFail
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Runtime.Interpreter
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray
import GHC.Builtin.PrimOps
import GHC.Unit.Types
import GHC.Unit.Module.Name
import GHC.Data.FastString
import GHC.Data.SizedSeq
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.Name
import GHC.Types.Name.Env
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts
type ClosureEnv = NameEnv (Name, ForeignHValue)
emptyClosureEnv :: ClosureEnv
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = forall a. NameEnv a
emptyNameEnv
extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv :: ClosureEnv -> [(Name, ForeignHValue)] -> ClosureEnv
extendClosureEnv ClosureEnv
cl_env [(Name, ForeignHValue)]
pairs
= forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList ClosureEnv
cl_env [ (Name
n, (Name
n,ForeignHValue
v)) | (Name
n,ForeignHValue
v) <- [(Name, ForeignHValue)]
pairs]
linkBCO
:: Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO :: Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray
(UnlinkedBCO Name
_ Int
arity UArray Int Word16
insns UArray Int Word64
bitmap SizedSeq BCONPtr
lits0 SizedSeq BCOPtr
ptrs0) = do
[Word64]
lits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interp -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp ItblEnv
ie) (forall a. SizedSeq a -> [a]
ssElts SizedSeq BCONPtr
lits0)
[ResolvedBCOPtr]
ptrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray) (forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs0)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
-> Int
-> UArray Int Word16
-> UArray Int Word64
-> UArray Int Word64
-> SizedSeq ResolvedBCOPtr
-> ResolvedBCO
ResolvedBCO Bool
isLittleEndian Int
arity UArray Int Word16
insns UArray Int Word64
bitmap
(forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. SizedSeq a -> Word
sizeSS SizedSeq BCONPtr
lits0)forall a. Num a => a -> a -> a
-Int
1) [Word64]
lits)
(forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS forall a. SizedSeq a
emptySS [ResolvedBCOPtr]
ptrs))
lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp ItblEnv
ie BCONPtr
ptr = case BCONPtr
ptr of
BCONPtrWord Word
lit -> forall (m :: * -> *) a. Monad m => a -> m a
return Word
lit
BCONPtrLbl FastString
sym -> do
Ptr Addr#
a# <- Interp -> FastString -> IO (Ptr ())
lookupStaticPtr Interp
interp FastString
sym
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
BCONPtrItbl Name
nm -> do
Ptr Addr#
a# <- Interp -> ItblEnv -> Name -> IO (Ptr ())
lookupIE Interp
interp ItblEnv
ie Name
nm
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
BCONPtrStr ByteString
_ ->
forall a. String -> a
panic String
"lookupLiteral: BCONPtrStr"
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr Interp
interp FastString
addr_of_label_string = do
Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
addr_of_label_string
case Maybe (Ptr ())
m of
Just Ptr ()
ptr -> forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
ptr
Maybe (Ptr ())
Nothing -> forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker: can't find label"
(FastString -> String
unpackFS FastString
addr_of_label_string)
lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
lookupIE Interp
interp ItblEnv
ie Name
con_nm =
case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ItblEnv
ie Name
con_nm of
Just (Name
_, ItblPtr RemotePtr StgInfoTable
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. RemotePtr a -> Ptr a
fromRemotePtr (forall a b. RemotePtr a -> RemotePtr b
castRemotePtr RemotePtr StgInfoTable
a))
Maybe (Name, ItblPtr)
Nothing -> do
let sym_to_find1 :: FastString
sym_to_find1 = Name -> String -> FastString
nameToCLabel Name
con_nm String
"con_info"
Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find1
case Maybe (Ptr ())
m of
Just Ptr ()
addr -> forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
Maybe (Ptr ())
Nothing
-> do
let sym_to_find2 :: FastString
sym_to_find2 = Name -> String -> FastString
nameToCLabel Name
con_nm String
"static_info"
Maybe (Ptr ())
n <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find2
case Maybe (Ptr ())
n of
Just Ptr ()
addr -> forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
Maybe (Ptr ())
Nothing -> forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupIE"
(FastString -> String
unpackFS FastString
sym_to_find1 forall a. [a] -> [a] -> [a]
++ String
" or " forall a. [a] -> [a] -> [a]
++
FastString -> String
unpackFS FastString
sym_to_find2)
lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
lookupPrimOp Interp
interp PrimOp
primop = do
let sym_to_find :: String
sym_to_find = PrimOp -> String -> String
primopToCLabel PrimOp
primop String
"closure"
Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp (String -> FastString
mkFastString String
sym_to_find)
case Maybe (Ptr ())
m of
Just Ptr ()
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p)
Maybe (Ptr ())
Nothing -> forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupCE(primop)" String
sym_to_find
resolvePtr
:: Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr :: Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray BCOPtr
ptr = case BCOPtr
ptr of
BCOPtrName Name
nm
| Just Int
ix <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Int
bco_ix Name
nm
-> forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ResolvedBCOPtr
ResolvedBCORef Int
ix)
| Just (Name
_, ForeignHValue
rhv) <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ClosureEnv
ce Name
nm
-> forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRef HValue -> ResolvedBCOPtr
ResolvedBCOPtr (forall a. ForeignRef a -> RemoteRef a
unsafeForeignRefToRemoteRef ForeignHValue
rhv))
| Bool
otherwise
-> ASSERT2(isExternalName nm, ppr nm)
do
let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
nm String
"closure"
Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find
case Maybe (Ptr ())
m of
Just Ptr ()
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr (forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))
Maybe (Ptr ())
Nothing -> forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupCE" (FastString -> String
unpackFS FastString
sym_to_find)
BCOPtrPrimOp PrimOp
op
-> RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp -> PrimOp -> IO (RemotePtr ())
lookupPrimOp Interp
interp PrimOp
op
BCOPtrBCO UnlinkedBCO
bco
-> ResolvedBCO -> ResolvedBCOPtr
ResolvedBCOPtrBCO forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray UnlinkedBCO
bco
BCOPtr
BCOPtrBreakArray
-> forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRef BreakArray -> ResolvedBCOPtr
ResolvedBCOPtrBreakArray RemoteRef BreakArray
breakarray)
linkFail :: String -> String -> IO a
linkFail :: forall a. String -> String -> IO a
linkFail String
who String
what
= forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines [ String
"",String
who
, String
"During interactive linking, GHCi couldn't find the following symbol:"
, Char
' ' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: String
what
, String
"This may be due to you not asking GHCi to load extra object files,"
, String
"archives or DLLs needed by your current session. Restart GHCi, specifying"
, String
"the missing library using the -L/path/to/object/dir and -lmissinglibname"
, String
"flags, or simply by naming the relevant files on the GHCi command line."
, String
"Alternatively, this link failure might indicate a bug in GHCi."
, String
"If you suspect the latter, please report this as a GHC bug:"
, String
" https://www.haskell.org/ghc/reportabug"
])
nameToCLabel :: Name -> String -> FastString
nameToCLabel :: Name -> String -> FastString
nameToCLabel Name
n String
suffix = String -> FastString
mkFastString String
label
where
encodeZ :: FastString -> String
encodeZ = FastZString -> String
zString forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FastZString
zEncodeFS
(Module Unit
pkgKey ModuleName
modName) = ASSERT( isExternalName n ) nameModule n
packagePart :: String
packagePart = FastString -> String
encodeZ (forall u. IsUnitId u => u -> FastString
unitFS Unit
pkgKey)
modulePart :: String
modulePart = FastString -> String
encodeZ (ModuleName -> FastString
moduleNameFS ModuleName
modName)
occPart :: String
occPart = FastString -> String
encodeZ (OccName -> FastString
occNameFS (Name -> OccName
nameOccName Name
n))
label :: String
label = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ if Unit
pkgKey forall a. Eq a => a -> a -> Bool
== Unit
mainUnit then String
"" else String
packagePart forall a. [a] -> [a] -> [a]
++ String
"_"
, String
modulePart
, Char
'_'forall a. a -> [a] -> [a]
:String
occPart
, Char
'_'forall a. a -> [a] -> [a]
:String
suffix
]
primopToCLabel :: PrimOp -> String -> String
primopToCLabel :: PrimOp -> String -> String
primopToCLabel PrimOp
primop String
suffix = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"ghczmprim_GHCziPrimopWrappers_"
, FastZString -> String
zString (FastString -> FastZString
zEncodeFS (OccName -> FastString
occNameFS (PrimOp -> OccName
primOpOcc PrimOp
primop)))
, Char
'_'forall a. a -> [a] -> [a]
:String
suffix
]