{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
--  (c) The University of Glasgow 2002-2006
--

-- | Bytecode assembler and linker
module GHC.ByteCode.Linker
  ( linkBCO
  , lookupStaticPtr
  , lookupIE
  , linkFail
  , BCOIx(..)
  )
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.Unit.Types

import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.SmallArray

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

-- Standard libraries
import Control.Concurrent
import Control.Monad
import Data.Array.Base
import Data.Array.IO.Internals
import Data.Functor
import Foreign.Ptr
import GHC.Exts
import qualified GHC.Exts.Heap as Heap

{- |
  Linking interpretables into something we can run
-}
linkBCO
  :: Interp
  -> PkgsLoaded
  -> BytecodeLoaderState
  -> NameEnv BCOIx
  -- ^ A mapping from names to references to other BCOs
  --   or static constructors in this group.
  -> UnlinkedBCO
  -> IO ResolvedBCO
linkBCO :: Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> NameEnv BCOIx
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state NameEnv BCOIx
bco_ix UnlinkedBCO
unl_bco = do
  case UnlinkedBCO
unl_bco of
    UnlinkedBCO Name
_ BreakTickIndex
arity BCOByteArray Word16
insns
           BCOByteArray Word
bitmap FlatBag BCONPtr
lits0 FlatBag BCOPtr
ptrs0 -> do
        lits <- FlatBag BCONPtr -> IO (BCOByteArray Word)
doLits FlatBag BCONPtr
lits0
        ptrs <- doPtrs ptrs0
        return ResolvedBCO
          { resolvedBCOIsLE   = isLittleEndian
          , resolvedBCOArity  = arity
          , resolvedBCOInstrs = insns
          , resolvedBCOBitmap = bitmap
          , resolvedBCOLits   = lits
          , resolvedBCOPtrs   = ptrs
          }

    UnlinkedStaticCon
      { unlinkedStaticConLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedStaticConLits = FlatBag BCONPtr
lits0
      , unlinkedStaticConPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedStaticConPtrs = FlatBag BCOPtr
ptrs0
      , Name
unlinkedStaticConDataConName :: Name
unlinkedStaticConDataConName :: UnlinkedBCO -> Name
unlinkedStaticConDataConName
      , Bool
unlinkedStaticConIsUnlifted :: Bool
unlinkedStaticConIsUnlifted :: UnlinkedBCO -> Bool
unlinkedStaticConIsUnlifted
      } -> do
        itbl_ptr <- Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> Name
-> IO (RemotePtr StgInfoTable)
lookupIE Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state Name
unlinkedStaticConDataConName
        lits <- doLits lits0
        ptrs <- doPtrs ptrs0
        return ResolvedStaticCon
          { resolvedBCOIsLE = isLittleEndian
          , resolvedStaticConInfoPtr = itbl_ptr
          , resolvedStaticConArity = sizeFlatBag lits0 + sizeFlatBag ptrs0
          , resolvedStaticConLits = lits
          , resolvedStaticConPtrs = ptrs
          , resolvedStaticConIsUnlifted = unlinkedStaticConIsUnlifted
          }
  where
    doLits :: FlatBag BCONPtr -> IO (BCOByteArray Word)
doLits FlatBag BCONPtr
lits0 = do
      litsMut <- (BreakTickIndex, BreakTickIndex)
-> IO (IOUArray BreakTickIndex Word)
forall i. Ix i => (i, i) -> IO (IOUArray i Word)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
unsafeNewArray_ (BreakTickIndex
0, Word -> BreakTickIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FlatBag BCONPtr -> Word
forall a. FlatBag a -> Word
sizeFlatBag FlatBag BCONPtr
lits0) BreakTickIndex -> BreakTickIndex -> BreakTickIndex
forall a. Num a => a -> a -> a
- BreakTickIndex
1)
      foldM_ (\(!BreakTickIndex
i) BCONPtr
lit -> (IOUArray BreakTickIndex Word -> BreakTickIndex -> Word -> IO ()
forall i.
Ix i =>
IOUArray i Word -> BreakTickIndex -> Word -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> BreakTickIndex -> e -> m ()
unsafeWrite IOUArray BreakTickIndex Word
litsMut BreakTickIndex
i (Word -> IO ()) -> IO Word -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
lookupLiteral Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state BCONPtr
lit) IO () -> BreakTickIndex -> IO BreakTickIndex
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BreakTickIndex -> BreakTickIndex
forall a. Enum a => a -> a
succ BreakTickIndex
i) 0 lits0
      lits <- unsafeFreezeIOUArray litsMut
      return $ mkBCOByteArray lits
    doPtrs :: FlatBag BCOPtr -> IO (SmallArray ResolvedBCOPtr)
doPtrs FlatBag BCOPtr
ptrs0 = do
      ptrsMut <- BreakTickIndex
-> ResolvedBCOPtr -> IO (SmallMutableArrayIO ResolvedBCOPtr)
forall a. BreakTickIndex -> a -> IO (SmallMutableArrayIO a)
newSmallArrayIO (Word -> BreakTickIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FlatBag BCOPtr -> Word
forall a. FlatBag a -> Word
sizeFlatBag FlatBag BCOPtr
ptrs0)) ResolvedBCOPtr
forall a. HasCallStack => a
undefined
      foldM_ (\(!BreakTickIndex
i) BCOPtr
ptr -> (SmallMutableArrayIO ResolvedBCOPtr
-> BreakTickIndex -> ResolvedBCOPtr -> IO ()
forall a. SmallMutableArrayIO a -> BreakTickIndex -> a -> IO ()
writeSmallArrayIO SmallMutableArrayIO ResolvedBCOPtr
ptrsMut BreakTickIndex
i (ResolvedBCOPtr -> IO ()) -> IO ResolvedBCOPtr -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> NameEnv BCOIx
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state NameEnv BCOIx
bco_ix BCOPtr
ptr) IO () -> BreakTickIndex -> IO BreakTickIndex
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BreakTickIndex -> BreakTickIndex
forall a. Enum a => a -> a
succ BreakTickIndex
i) 0 ptrs0
      unsafeFreezeSmallArrayIO ptrsMut

-- | An index into a BCO or Static Constructor in this group.
--
-- We distinguish between lifted and unlifted static constructors because
-- lifted ones get resolved by tying a knot, since there may be circular
-- dependencies between them, whereas unlifted ones get constructed in a first
-- pass.
data BCOIx = BCOIx !Int
           | LiftedStaticConIx !Int
           | UnliftedStaticConIx !Int
  deriving (BCOIx -> BCOIx -> Bool
(BCOIx -> BCOIx -> Bool) -> (BCOIx -> BCOIx -> Bool) -> Eq BCOIx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BCOIx -> BCOIx -> Bool
== :: BCOIx -> BCOIx -> Bool
$c/= :: BCOIx -> BCOIx -> Bool
/= :: BCOIx -> BCOIx -> Bool
Eq, Eq BCOIx
Eq BCOIx =>
(BCOIx -> BCOIx -> Ordering)
-> (BCOIx -> BCOIx -> Bool)
-> (BCOIx -> BCOIx -> Bool)
-> (BCOIx -> BCOIx -> Bool)
-> (BCOIx -> BCOIx -> Bool)
-> (BCOIx -> BCOIx -> BCOIx)
-> (BCOIx -> BCOIx -> BCOIx)
-> Ord BCOIx
BCOIx -> BCOIx -> Bool
BCOIx -> BCOIx -> Ordering
BCOIx -> BCOIx -> BCOIx
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BCOIx -> BCOIx -> Ordering
compare :: BCOIx -> BCOIx -> Ordering
$c< :: BCOIx -> BCOIx -> Bool
< :: BCOIx -> BCOIx -> Bool
$c<= :: BCOIx -> BCOIx -> Bool
<= :: BCOIx -> BCOIx -> Bool
$c> :: BCOIx -> BCOIx -> Bool
> :: BCOIx -> BCOIx -> Bool
$c>= :: BCOIx -> BCOIx -> Bool
>= :: BCOIx -> BCOIx -> Bool
$cmax :: BCOIx -> BCOIx -> BCOIx
max :: BCOIx -> BCOIx -> BCOIx
$cmin :: BCOIx -> BCOIx -> BCOIx
min :: BCOIx -> BCOIx -> BCOIx
Ord, BreakTickIndex -> BCOIx -> ShowS
[BCOIx] -> ShowS
BCOIx -> [Char]
(BreakTickIndex -> BCOIx -> ShowS)
-> (BCOIx -> [Char]) -> ([BCOIx] -> ShowS) -> Show BCOIx
forall a.
(BreakTickIndex -> a -> ShowS)
-> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: BreakTickIndex -> BCOIx -> ShowS
showsPrec :: BreakTickIndex -> BCOIx -> ShowS
$cshow :: BCOIx -> [Char]
show :: BCOIx -> [Char]
$cshowList :: [BCOIx] -> ShowS
showList :: [BCOIx] -> ShowS
Show)

lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
lookupLiteral Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state 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# <- RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (RemotePtr () -> Ptr ()) -> IO (RemotePtr ()) -> IO (Ptr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp -> FastString -> IO (RemotePtr ())
lookupStaticPtr Interp
interp FastString
sym
    return (W# (int2Word# (addr2Int# a#)))
  BCONPtrItbl Name
nm -> do
    (Ptr a#) <- RemotePtr StgInfoTable -> Ptr StgInfoTable
forall a. RemotePtr a -> Ptr a
fromRemotePtr (RemotePtr StgInfoTable -> Ptr StgInfoTable)
-> IO (RemotePtr StgInfoTable) -> IO (Ptr StgInfoTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> Name
-> IO (RemotePtr StgInfoTable)
lookupIE Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state Name
nm
    return (W# (int2Word# (addr2Int# a#)))
  BCONPtrAddr Name
nm -> do
    Ptr a# <- RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr (RemotePtr () -> Ptr ()) -> IO (RemotePtr ()) -> IO (Ptr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (RemotePtr ())
lookupAddr Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state Name
nm
    return (W# (int2Word# (addr2Int# a#)))
  BCONPtrStr ByteString
bs -> do
    RemotePtr p <- ([RemotePtr ()] -> RemotePtr ())
-> IO [RemotePtr ()] -> IO (RemotePtr ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RemotePtr ()] -> RemotePtr ()
forall a. HasCallStack => [a] -> a
head (IO [RemotePtr ()] -> IO (RemotePtr ()))
-> IO [RemotePtr ()] -> IO (RemotePtr ())
forall a b. (a -> b) -> a -> b
$ Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Message [RemotePtr ()] -> IO [RemotePtr ()])
-> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString
bs]
    pure $ fromIntegral p
  BCONPtrFS FastString
fs -> MVar (FastStringEnv (RemotePtr ()))
-> (FastStringEnv (RemotePtr ())
    -> IO (FastStringEnv (RemotePtr ()), Word))
-> IO Word
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Interp -> MVar (FastStringEnv (RemotePtr ()))
interpStringCache Interp
interp) ((FastStringEnv (RemotePtr ())
  -> IO (FastStringEnv (RemotePtr ()), Word))
 -> IO Word)
-> (FastStringEnv (RemotePtr ())
    -> IO (FastStringEnv (RemotePtr ()), Word))
-> IO Word
forall a b. (a -> b) -> a -> b
$ \FastStringEnv (RemotePtr ())
fs_env ->
    case FastStringEnv (RemotePtr ()) -> FastString -> Maybe (RemotePtr ())
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv (RemotePtr ())
fs_env FastString
fs of
      Just (RemotePtr Word64
p) -> (FastStringEnv (RemotePtr ()), Word)
-> IO (FastStringEnv (RemotePtr ()), Word)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FastStringEnv (RemotePtr ())
fs_env, Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p)
      Maybe (RemotePtr ())
Nothing -> do
        rp@(RemotePtr p) <- ([RemotePtr ()] -> RemotePtr ())
-> IO [RemotePtr ()] -> IO (RemotePtr ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RemotePtr ()] -> RemotePtr ()
forall a. HasCallStack => [a] -> a
head (IO [RemotePtr ()] -> IO (RemotePtr ()))
-> IO [RemotePtr ()] -> IO (RemotePtr ())
forall a b. (a -> b) -> a -> b
$ Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Message [RemotePtr ()] -> IO [RemotePtr ()])
-> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Message [RemotePtr ()]
MallocStrings [FastString -> ByteString
bytesFS FastString
fs]
        pure (extendFsEnv fs_env fs rp, fromIntegral p)
  BCONPtrFFIInfo (FFIInfo {[FFIType]
FFIType
ffiInfoArgs :: [FFIType]
ffiInfoRet :: FFIType
ffiInfoRet :: FFIInfo -> FFIType
ffiInfoArgs :: FFIInfo -> [FFIType]
..}) -> do
    RemotePtr p <- Interp -> Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif))
-> Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
forall a b. (a -> b) -> a -> b
$ [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
PrepFFI [FFIType]
ffiInfoArgs FFIType
ffiInfoRet
    pure $ fromIntegral p
  BCONPtrCostCentre InternalBreakpointId{BreakTickIndex
Module
ibi_info_mod :: Module
ibi_info_index :: BreakTickIndex
ibi_info_index :: InternalBreakpointId -> BreakTickIndex
ibi_info_mod :: InternalBreakpointId -> Module
..}
    | Interp -> Bool
interpreterProfiled Interp
interp -> do
        case Maybe (Array BreakTickIndex (RemotePtr CostCentre))
-> Array BreakTickIndex (RemotePtr CostCentre)
forall a. HasCallStack => Maybe a -> a
expectJust (BytecodeLoaderState
-> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre))
lookupCCSBytecodeState BytecodeLoaderState
bytecode_state Module
ibi_info_mod) Array BreakTickIndex (RemotePtr CostCentre)
-> BreakTickIndex -> RemotePtr CostCentre
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! BreakTickIndex
ibi_info_index of
          RemotePtr Word64
p -> Word -> IO Word
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> IO Word) -> Word -> IO Word
forall a b. (a -> b) -> a -> b
$ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p
    | Bool
otherwise ->
        case Ptr a_0 -> RemotePtr a_0
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr a_0
forall a. Ptr a
nullPtr of
          RemotePtr Word64
p -> Word -> IO Word
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> IO Word) -> Word -> IO Word
forall a b. (a -> b) -> a -> b
$ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p

lookupStaticPtr :: Interp -> FastString -> IO (RemotePtr ())
lookupStaticPtr :: Interp -> FastString -> IO (RemotePtr ())
lookupStaticPtr Interp
interp FastString
addr_of_label_string = do
  m <- Interp -> InterpSymbol 'Interpreted -> IO (Maybe (RemotePtr ()))
forall (s :: SuffixOrInterpreted).
Interp -> InterpSymbol s -> IO (Maybe (RemotePtr ()))
lookupSymbol Interp
interp (FastString -> InterpSymbol 'Interpreted
IFaststringSymbol FastString
addr_of_label_string)
  case m of
    Just RemotePtr ()
ptr -> RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr ()
ptr
    Maybe (RemotePtr ())
Nothing  -> [Char] -> SDoc -> IO (RemotePtr ())
forall a. [Char] -> SDoc -> IO a
linkFail [Char]
"GHC.ByteCode.Linker: can't find label"
                  (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
addr_of_label_string)

lookupIE :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (RemotePtr Heap.StgInfoTable)
lookupIE :: Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> Name
-> IO (RemotePtr StgInfoTable)
lookupIE Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state Name
con_nm =
  case BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr)
lookupInfoTableBytecodeState BytecodeLoaderState
bytecode_state Name
con_nm of
    Just (Name
_, ItblPtr RemotePtr StgInfoTable
a) -> RemotePtr StgInfoTable -> IO (RemotePtr StgInfoTable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr StgInfoTable
a
    Maybe (Name, ItblPtr)
Nothing -> do -- try looking up in the object files.
       let sym_to_find1 :: InterpSymbol ('Suffix "con_info")
sym_to_find1 = Name -> InterpSymbol ('Suffix "con_info")
IConInfoSymbol Name
con_nm
       m <- Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix "con_info")
-> IO (Maybe (RemotePtr ()))
forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded InterpSymbol ('Suffix "con_info")
sym_to_find1
       case m of
          Just RemotePtr ()
addr -> RemotePtr StgInfoTable -> IO (RemotePtr StgInfoTable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> RemotePtr StgInfoTable
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr RemotePtr ()
addr)
          Maybe (RemotePtr ())
Nothing
             -> do -- perhaps a nullary constructor?
                   let sym_to_find2 :: InterpSymbol ('Suffix "static_info")
sym_to_find2 = Name -> InterpSymbol ('Suffix "static_info")
IStaticInfoSymbol Name
con_nm
                   n <- Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix "static_info")
-> IO (Maybe (RemotePtr ()))
forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded InterpSymbol ('Suffix "static_info")
sym_to_find2
                   case n of
                      Just RemotePtr ()
addr -> RemotePtr StgInfoTable -> IO (RemotePtr StgInfoTable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> RemotePtr StgInfoTable
forall a b. RemotePtr a -> RemotePtr b
castRemotePtr RemotePtr ()
addr)
                      Maybe (RemotePtr ())
Nothing   -> [Char] -> SDoc -> IO (RemotePtr StgInfoTable)
forall a. [Char] -> SDoc -> IO a
linkFail [Char]
"GHC.ByteCode.Linker.lookupIE"
                                      (InterpSymbol ('Suffix "con_info") -> SDoc
forall a. Outputable a => a -> SDoc
ppr InterpSymbol ('Suffix "con_info")
sym_to_find1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
" or " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                                       InterpSymbol ('Suffix "static_info") -> SDoc
forall a. Outputable a => a -> SDoc
ppr InterpSymbol ('Suffix "static_info")
sym_to_find2)

-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
lookupAddr :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (RemotePtr ())
lookupAddr :: Interp
-> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (RemotePtr ())
lookupAddr Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bytecode_state Name
addr_nm = do
  case BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr)
lookupAddressBytecodeState BytecodeLoaderState
bytecode_state Name
addr_nm of
    Just (Name
_, AddrPtr RemotePtr ()
ptr) -> RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr ()
ptr
    Maybe (Name, AddrPtr)
Nothing -> do -- try looking up in the object files.
      let sym_to_find :: InterpSymbol ('Suffix "bytes")
sym_to_find = Name -> InterpSymbol ('Suffix "bytes")
IBytesSymbol Name
addr_nm
                          -- see Note [Bytes label] in GHC.Cmm.CLabel
      m <- Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix "bytes")
-> IO (Maybe (RemotePtr ()))
forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded InterpSymbol ('Suffix "bytes")
sym_to_find
      case m of
        Just RemotePtr ()
ptr -> RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr ()
ptr
        Maybe (RemotePtr ())
Nothing -> [Char] -> SDoc -> IO (RemotePtr ())
forall a. [Char] -> SDoc -> IO a
linkFail [Char]
"GHC.ByteCode.Linker.lookupAddr"
                     (InterpSymbol ('Suffix "bytes") -> SDoc
forall a. Outputable a => a -> SDoc
ppr InterpSymbol ('Suffix "bytes")
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 :: [Char]
sym_to_find = PrimOp -> ShowS
primopToCLabel PrimOp
primop [Char]
"closure"
  m <- Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix "closure")
-> IO (Maybe (RemotePtr ()))
forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded (Name -> InterpSymbol ('Suffix "closure")
IClosureSymbol (Id -> Name
Id.idName (Id -> Name) -> Id -> Name
forall a b. (a -> b) -> a -> b
$ PrimOp -> Id
primOpId PrimOp
primop))
  case m of
    Just RemotePtr ()
p -> RemotePtr () -> IO (RemotePtr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr ()
p
    Maybe (RemotePtr ())
Nothing -> [Char] -> SDoc -> IO (RemotePtr ())
forall a. [Char] -> SDoc -> IO a
linkFail [Char]
"GHC.ByteCode.Linker.lookupCE(primop)" ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
sym_to_find)

resolvePtr
  :: Interp
  -> PkgsLoaded
  -> BytecodeLoaderState
  -> NameEnv BCOIx
  -> BCOPtr
  -> IO ResolvedBCOPtr
resolvePtr :: Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> NameEnv BCOIx
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bco_loader_state NameEnv BCOIx
bco_ix BCOPtr
ptr = case BCOPtr
ptr of
  BCOPtrName Name
nm
    | Just BCOIx
bix <- NameEnv BCOIx -> Name -> Maybe BCOIx
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv BCOIx
bco_ix Name
nm
    -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedBCOPtr -> IO ResolvedBCOPtr)
-> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a b. (a -> b) -> a -> b
$ case BCOIx
bix of
        BCOIx BreakTickIndex
ix               -> BreakTickIndex -> ResolvedBCOPtr
ResolvedBCORef BreakTickIndex
ix
        LiftedStaticConIx BreakTickIndex
ix   -> BreakTickIndex -> ResolvedBCOPtr
ResolvedStaticConRef BreakTickIndex
ix
        UnliftedStaticConIx BreakTickIndex
ix -> BreakTickIndex -> ResolvedBCOPtr
ResolvedUnliftedStaticConRef BreakTickIndex
ix

    | Just (Name
_, ForeignHValue
rhv) <- BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue)
lookupNameBytecodeState BytecodeLoaderState
bco_loader_state 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 :: InterpSymbol ('Suffix "closure")
sym_to_find = Name -> InterpSymbol ('Suffix "closure")
IClosureSymbol Name
nm
          m <- Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix "closure")
-> IO (Maybe (RemotePtr ()))
forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded InterpSymbol ('Suffix "closure")
sym_to_find
          case m of
            Just RemotePtr ()
p -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr RemotePtr ()
p)
            Maybe (RemotePtr ())
Nothing -> [Char] -> SDoc -> IO ResolvedBCOPtr
forall a. [Char] -> SDoc -> IO a
linkFail [Char]
"GHC.ByteCode.Linker.lookupCE" (InterpSymbol ('Suffix "closure") -> SDoc
forall a. Outputable a => a -> SDoc
ppr InterpSymbol ('Suffix "closure")
sym_to_find)

  BCOPtrPrimOp PrimOp
op
    -> RemotePtr () -> ResolvedBCOPtr
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
ResolvedBCO -> ResolvedBCOPtr
ResolvedBCOPtrBCO (ResolvedBCO -> ResolvedBCOPtr)
-> IO ResolvedBCO -> IO ResolvedBCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interp
-> PkgsLoaded
-> BytecodeLoaderState
-> NameEnv BCOIx
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp PkgsLoaded
pkgs_loaded BytecodeLoaderState
bco_loader_state NameEnv BCOIx
bco_ix UnlinkedBCO
bco

  BCOPtrBreakArray Module
tick_mod ->
    ForeignRef BreakArray
-> (RemoteRef BreakArray -> IO ResolvedBCOPtr) -> IO ResolvedBCOPtr
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef (Maybe (ForeignRef BreakArray) -> ForeignRef BreakArray
forall a. HasCallStack => Maybe a -> a
expectJust (BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray)
lookupBreakArrayBytecodeState BytecodeLoaderState
bco_loader_state Module
tick_mod)) ((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 (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedBCOPtr -> IO ResolvedBCOPtr)
-> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a b. (a -> b) -> a -> b
$ RemoteRef BreakArray -> ResolvedBCOPtr
ResolvedBCOPtrBreakArray RemoteRef BreakArray
ba

-- | Look up the address of a Haskell symbol in the currently
-- loaded units.
--
-- See Note [Looking up symbols in the relevant objects].
lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (RemotePtr ()))
lookupHsSymbol :: forall (s :: Symbol).
Interp
-> PkgsLoaded
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
lookupHsSymbol Interp
interp PkgsLoaded
pkgs_loaded InterpSymbol ('Suffix s)
sym_to_find = do
  Bool -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Name -> Bool
isExternalName (InterpSymbol ('Suffix s) -> Name
forall (s :: Symbol). InterpSymbol ('Suffix s) -> Name
interpSymbolName InterpSymbol ('Suffix s)
sym_to_find)) (InterpSymbol ('Suffix s) -> SDoc
forall a. Outputable a => a -> SDoc
ppr InterpSymbol ('Suffix s)
sym_to_find)
  let 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 (InterpSymbol ('Suffix s) -> Name
forall (s :: Symbol). InterpSymbol ('Suffix s) -> Name
interpSymbolName InterpSymbol ('Suffix s)
sym_to_find)
      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 (RemotePtr ()))
go (RemotePtr LoadedDLL
dll:[RemotePtr LoadedDLL]
dlls) = do
        mb_ptr <- Interp
-> RemotePtr LoadedDLL
-> InterpSymbol ('Suffix s)
-> IO (Maybe (RemotePtr ()))
forall (s :: SuffixOrInterpreted).
Interp
-> RemotePtr LoadedDLL
-> InterpSymbol s
-> IO (Maybe (RemotePtr ()))
lookupSymbolInDLL Interp
interp RemotePtr LoadedDLL
dll InterpSymbol ('Suffix s)
sym_to_find
        case mb_ptr of
          Just RemotePtr ()
ptr -> Maybe (RemotePtr ()) -> IO (Maybe (RemotePtr ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemotePtr () -> Maybe (RemotePtr ())
forall a. a -> Maybe a
Just RemotePtr ()
ptr)
          Maybe (RemotePtr ())
Nothing -> [RemotePtr LoadedDLL] -> IO (Maybe (RemotePtr ()))
go [RemotePtr LoadedDLL]
dlls
      go [] =
        -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types
        Interp -> InterpSymbol ('Suffix s) -> IO (Maybe (RemotePtr ()))
forall (s :: SuffixOrInterpreted).
Interp -> InterpSymbol s -> IO (Maybe (RemotePtr ()))
lookupSymbol Interp
interp InterpSymbol ('Suffix s)
sym_to_find

  [RemotePtr LoadedDLL] -> IO (Maybe (RemotePtr ()))
go [RemotePtr LoadedDLL]
loaded_dlls

linkFail :: String -> SDoc -> IO a
linkFail :: forall a. [Char] -> SDoc -> IO a
linkFail [Char]
who SDoc
what
   = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO ([Char] -> GhcException
[Char] -> GhcException
ProgramError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
unlines [ [Char]
"",[Char]
who
                , [Char]
"During interactive linking, GHCi couldn't find the following symbol:"
                , Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: SDoc -> [Char]
showSDocUnsafe SDoc
what
                , [Char]
"This may be due to you not asking GHCi to load extra object files,"
                , [Char]
"archives or DLLs needed by your current session.  Restart GHCi, specifying"
                , [Char]
"the missing library using the -L/path/to/object/dir and -lmissinglibname"
                , [Char]
"flags, or simply by naming the relevant files on the GHCi command line."
                , [Char]
"Alternatively, this link failure might indicate a bug in GHCi."
                , [Char]
"If you suspect the latter, please report this as a GHC bug:"
                , [Char]
"  https://www.haskell.org/ghc/reportabug"
                ])






-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
primopToCLabel :: PrimOp -> String -> String
primopToCLabel :: PrimOp -> ShowS
primopToCLabel PrimOp
primop [Char]
suffix = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"ghczminternal_GHCziInternalziPrimopWrappers_"
    , FastZString -> [Char]
zString (FastString -> FastZString
zEncodeFS (OccName -> FastString
occNameFS (PrimOp -> OccName
primOpOcc PrimOp
primop)))
    , Char
'_'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
suffix
    ]