{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module GHC.ByteCode.Linker
( linkBCO
, lookupStaticPtr
, lookupIE
, nameToCLabel
, linkFail
)
where
import GHC.Prelude
import GHC.Runtime.Interpreter
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Names
import GHC.Unit.Types
import GHC.Data.FastString
import GHC.Data.SizedSeq
import GHC.Linker.Types
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
import qualified GHC.Types.Id as Id
import GHC.Types.Unique.DFM
import Language.Haskell.Syntax.Module.Name
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts
linkBCO
:: Interp
-> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO :: Interp
-> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp PkgsLoaded
pkgs_loaded LinkerEnv
le NameEnv Int
bco_ix
(UnlinkedBCO Name
_ Int
arity BCOByteArray Word16
insns BCOByteArray Word
bitmap FlatBag BCONPtr
lits0 FlatBag BCOPtr
ptrs0) = do
(lits :: [Word]) <- (BCONPtr -> IO Word) -> [BCONPtr] -> IO [Word]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Word -> Word) -> IO Word -> IO Word
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO Word -> IO Word) -> (BCONPtr -> IO Word) -> BCONPtr -> IO Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp PkgsLoaded
pkgs_loaded LinkerEnv
le) (FlatBag BCONPtr -> [BCONPtr]
forall a. FlatBag a -> [a]
elemsFlatBag FlatBag BCONPtr
lits0)
ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
let lits' = (Int, Int) -> [Word] -> UArray Int Word
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0 :: Int, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FlatBag BCONPtr -> Word
forall a. FlatBag a -> Word
sizeFlatBag FlatBag BCONPtr
lits0)Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Word]
lits
return (ResolvedBCO isLittleEndian arity
insns
bitmap
(mkBCOByteArray lits')
(addListToSS emptySS ptrs))
lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp PkgsLoaded
pkgs_loaded LinkerEnv
le BCONPtr
ptr = case BCONPtr
ptr of
BCONPtrWord Word
lit -> Word -> IO Word
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Word
lit
BCONPtrLbl FastString
sym -> do
Ptr a# <- Interp -> FastString -> IO (Ptr ())
lookupStaticPtr Interp
interp FastString
sym
return (W# (int2Word# (addr2Int# a#)))
BCONPtrItbl Name
nm -> do
Ptr a# <- Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE Interp
interp PkgsLoaded
pkgs_loaded (LinkerEnv -> ItblEnv
itbl_env LinkerEnv
le) Name
nm
return (W# (int2Word# (addr2Int# a#)))
BCONPtrAddr Name
nm -> do
Ptr a# <- Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr Interp
interp PkgsLoaded
pkgs_loaded (LinkerEnv -> AddrEnv
addr_env LinkerEnv
le) Name
nm
return (W# (int2Word# (addr2Int# a#)))
BCONPtrStr ByteString
_ ->
String -> IO Word
forall a. HasCallStack => 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
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
addr_of_label_string
case m of
Just Ptr ()
ptr -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
ptr
Maybe (Ptr ())
Nothing -> String -> String -> IO (Ptr ())
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 -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE Interp
interp PkgsLoaded
pkgs_loaded ItblEnv
ie Name
con_nm =
case ItblEnv -> Name -> Maybe (Name, ItblPtr)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ItblEnv
ie Name
con_nm of
Just (Name
_, ItblPtr RemotePtr StgInfoTable
a) -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (RemotePtr StgInfoTable -> RemotePtr ()
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"
m <- Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded Name
con_nm String
"con_info"
case m of
Just Ptr ()
addr -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
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"
n <- Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded Name
con_nm String
"static_info"
case n of
Just Ptr ()
addr -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
Maybe (Ptr ())
Nothing -> String -> String -> IO (Ptr ())
forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupIE"
(FastString -> String
unpackFS FastString
sym_to_find1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" or " String -> String -> String
forall a. [a] -> [a] -> [a]
++
FastString -> String
unpackFS FastString
sym_to_find2)
lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr Interp
interp PkgsLoaded
pkgs_loaded AddrEnv
ae Name
addr_nm = do
case AddrEnv -> Name -> Maybe (Name, AddrPtr)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv AddrEnv
ae Name
addr_nm of
Just (Name
_, AddrPtr RemotePtr ()
ptr) -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
ptr)
Maybe (Name, AddrPtr)
Nothing -> do
let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
addr_nm String
"bytes"
m <- Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded Name
addr_nm String
"bytes"
case m of
Just Ptr ()
ptr -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
ptr
Maybe (Ptr ())
Nothing -> String -> String -> IO (Ptr ())
forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupAddr"
(FastString -> String
unpackFS FastString
sym_to_find)
lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp Interp
interp PkgsLoaded
pkgs_loaded PrimOp
primop = do
let sym_to_find :: String
sym_to_find = PrimOp -> String -> String
primopToCLabel PrimOp
primop String
"closure"
m <- Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded (Id -> Name
Id.idName (Id -> Name) -> Id -> Name
forall a b. (a -> b) -> a -> b
$ PrimOp -> Id
primOpId PrimOp
primop) String
"closure"
case m of
Just Ptr ()
p -> RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p)
Maybe (Ptr ())
Nothing -> String -> String -> IO (RemotePtr ())
forall a. String -> String -> IO a
linkFail String
"GHC.ByteCode.Linker.lookupCE(primop)" String
sym_to_find
resolvePtr
:: Interp
-> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr :: Interp
-> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp PkgsLoaded
pkgs_loaded LinkerEnv
le NameEnv Int
bco_ix BCOPtr
ptr = case BCOPtr
ptr of
BCOPtrName Name
nm
| Just Int
ix <- NameEnv Int -> Name -> Maybe Int
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Int
bco_ix Name
nm
-> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ResolvedBCOPtr
ResolvedBCORef Int
ix)
| Just (Name
_, ForeignHValue
rhv) <- NameEnv (Name, ForeignHValue)
-> Name -> Maybe (Name, ForeignHValue)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (LinkerEnv -> NameEnv (Name, ForeignHValue)
closure_env LinkerEnv
le) Name
nm
-> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRef HValue -> ResolvedBCOPtr
ResolvedBCOPtr (ForeignHValue -> RemoteRef HValue
forall a. ForeignRef a -> RemoteRef a
unsafeForeignRefToRemoteRef ForeignHValue
rhv))
| Bool
otherwise
-> Bool -> SDoc -> IO ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
nm) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm) (IO ResolvedBCOPtr -> IO ResolvedBCOPtr)
-> IO ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a b. (a -> b) -> a -> b
$
do
let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
nm String
"closure"
m <- Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded Name
nm String
"closure"
case m of
Just Ptr ()
p -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))
Maybe (Ptr ())
Nothing -> String -> String -> IO ResolvedBCOPtr
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 (RemotePtr () -> ResolvedBCOPtr)
-> IO (RemotePtr ()) -> IO ResolvedBCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp Interp
interp PkgsLoaded
pkgs_loaded PrimOp
op
BCOPtrBCO UnlinkedBCO
bco
-> ResolvedBCO -> ResolvedBCOPtr
ResolvedBCOPtrBCO (ResolvedBCO -> ResolvedBCOPtr)
-> IO ResolvedBCO -> IO ResolvedBCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> PkgsLoaded
-> LinkerEnv
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp PkgsLoaded
pkgs_loaded LinkerEnv
le NameEnv Int
bco_ix UnlinkedBCO
bco
BCOPtrBreakArray ForeignRef BreakArray
breakarray
-> ForeignRef BreakArray
-> (RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignRef BreakArray
breakarray ((RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr)
-> (RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr
forall a b. (a -> b) -> a -> b
$ \RemoteRef BreakArray
ba -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRef BreakArray -> ResolvedBCOPtr
ResolvedBCOPtrBreakArray RemoteRef BreakArray
ba)
lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded Name
nm String
sym_suffix = do
Bool -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Name -> Bool
isExternalName Name
nm) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm)
let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
nm String
sym_suffix
pkg_id :: UnitId
pkg_id = Module -> UnitId
moduleUnitId (Module -> UnitId) -> Module -> UnitId
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
nm
loaded_dlls :: [RemotePtr LoadedDLL]
loaded_dlls = [RemotePtr LoadedDLL]
-> (LoadedPkgInfo -> [RemotePtr LoadedDLL])
-> Maybe LoadedPkgInfo
-> [RemotePtr LoadedDLL]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] LoadedPkgInfo -> [RemotePtr LoadedDLL]
loaded_pkg_hs_dlls (Maybe LoadedPkgInfo -> [RemotePtr LoadedDLL])
-> Maybe LoadedPkgInfo -> [RemotePtr LoadedDLL]
forall a b. (a -> b) -> a -> b
$ PkgsLoaded -> UnitId -> Maybe LoadedPkgInfo
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM PkgsLoaded
pkgs_loaded UnitId
pkg_id
go :: [RemotePtr LoadedDLL] -> IO (Maybe (Ptr ()))
go (RemotePtr LoadedDLL
dll:[RemotePtr LoadedDLL]
dlls) = do
mb_ptr <- Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
lookupSymbolInDLL Interp
interp RemotePtr LoadedDLL
dll FastString
sym_to_find
case mb_ptr of
Just Ptr ()
ptr -> Maybe (Ptr ()) -> IO (Maybe (Ptr ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr () -> Maybe (Ptr ())
forall a. a -> Maybe a
Just Ptr ()
ptr)
Maybe (Ptr ())
Nothing -> [RemotePtr LoadedDLL] -> IO (Maybe (Ptr ()))
go [RemotePtr LoadedDLL]
dlls
go [] =
Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find
[RemotePtr LoadedDLL] -> IO (Maybe (Ptr ()))
go [RemotePtr LoadedDLL]
loaded_dlls
linkFail :: String -> String -> IO a
linkFail :: forall a. String -> String -> IO a
linkFail String
who String
what
= GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (String -> GhcException) -> String -> GhcException
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
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
' ' Char -> String -> String
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 (FastZString -> String)
-> (FastString -> FastZString) -> FastString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FastZString
zEncodeFS
(Module Unit
pkgKey ModuleName
modName) = Bool -> Module -> Module
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isExternalName Name
n) (Module -> Module) -> Module -> Module
forall a b. (a -> b) -> a -> b
$ case HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n of
Module
mod | Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM -> Module
gHC_PRIMOPWRAPPERS
Module
mod -> Module
mod
packagePart :: String
packagePart = FastString -> String
encodeZ (Unit -> FastString
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 (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameMangledFS (Name -> OccName
nameOccName Name
n)
label :: String
label = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ if Unit
pkgKey Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit then String
"" else String
packagePart String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
, String
modulePart
, Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
occPart
, Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
suffix
]
primopToCLabel :: PrimOp -> String -> String
primopToCLabel :: PrimOp -> String -> String
primopToCLabel PrimOp
primop String
suffix = [String] -> String
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
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
suffix
]