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

-- | Bytecode assembler and linker
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 GHCi.BreakArray

import GHC.Builtin.PrimOps
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.Panic.Plain
import GHC.Utils.Outputable

import GHC.Types.Name
import GHC.Types.Name.Env

import Language.Haskell.Syntax.Module.Name

-- Standard libraries
import Data.Array.Unboxed
import Foreign.Ptr
import GHC.Exts

{-
  Linking interpretables into something we can run
-}

linkBCO
  :: Interp
  -> LinkerEnv
  -> NameEnv Int
  -> RemoteRef BreakArray
  -> UnlinkedBCO
  -> IO ResolvedBCO
linkBCO :: Interp
-> LinkerEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp LinkerEnv
le 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
  -- fromIntegral Word -> Word64 should be a no op if Word is Word64
  -- otherwise it will result in a cast to longlong on 32bit systems.
  [Word64]
lits <- (BCONPtr -> IO Word64) -> [BCONPtr] -> IO [Word64]
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 -> Word64) -> IO Word -> IO Word64
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO Word -> IO Word64)
-> (BCONPtr -> IO Word) -> BCONPtr -> IO Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interp -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp LinkerEnv
le) (SizedSeq BCONPtr -> [BCONPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq BCONPtr
lits0)
  [ResolvedBCOPtr]
ptrs <- (BCOPtr -> IO ResolvedBCOPtr) -> [BCOPtr] -> IO [ResolvedBCOPtr]
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 (Interp
-> LinkerEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp LinkerEnv
le NameEnv Int
bco_ix RemoteRef BreakArray
breakarray) (SizedSeq BCOPtr -> [BCOPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs0)
  ResolvedBCO -> IO ResolvedBCO
forall a. a -> IO a
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
              ((Int, Int) -> [Word64] -> UArray Int Word64
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SizedSeq BCONPtr -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq BCONPtr
lits0)Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [Word64]
lits)
              (SizedSeq ResolvedBCOPtr
-> [ResolvedBCOPtr] -> SizedSeq ResolvedBCOPtr
forall a. SizedSeq a -> [a] -> SizedSeq a
addListToSS SizedSeq ResolvedBCOPtr
forall a. SizedSeq a
emptySS [ResolvedBCOPtr]
ptrs))

lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
lookupLiteral Interp
interp 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 Addr#
a# <- Interp -> FastString -> IO (Ptr ())
lookupStaticPtr Interp
interp FastString
sym
    Word -> IO Word
forall a. a -> IO a
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 (LinkerEnv -> ItblEnv
itbl_env LinkerEnv
le) Name
nm
    Word -> IO Word
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
  BCONPtrAddr Name
nm -> do
    Ptr Addr#
a# <- Interp -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr Interp
interp (LinkerEnv -> AddrEnv
addr_env LinkerEnv
le) Name
nm
    Word -> IO Word
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
  BCONPtrStr ByteString
_ ->
    -- should be eliminated during assembleBCOs
    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
  Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
addr_of_label_string
  case Maybe (Ptr ())
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 -> ItblEnv -> Name -> IO (Ptr ())
lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
lookupIE Interp
interp 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 -- try looking up in the object files.
       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 -> Ptr () -> IO (Ptr ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
          Maybe (Ptr ())
Nothing
             -> do -- perhaps a nullary constructor?
                   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 -> 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)

-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
lookupAddr Interp
interp 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 -- try looking up in the object files.
      let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
addr_nm String
"bytes"
                          -- see Note [Bytes label] in GHC.Cmm.CLabel
      Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find
      case Maybe (Ptr ())
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 -> 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 -> 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
  -> LinkerEnv
  -> NameEnv Int
  -> RemoteRef BreakArray
  -> BCOPtr
  -> IO ResolvedBCOPtr
resolvePtr :: Interp
-> LinkerEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr Interp
interp LinkerEnv
le NameEnv Int
bco_ix RemoteRef BreakArray
breakarray 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) -- ref to another BCO in this group

    | 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"
          Maybe (Ptr ())
m <- Interp -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol Interp
interp FastString
sym_to_find
          case Maybe (Ptr ())
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 -> PrimOp -> IO (RemotePtr ())
lookupPrimOp Interp
interp 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
-> LinkerEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO Interp
interp LinkerEnv
le NameEnv Int
bco_ix RemoteRef BreakArray
breakarray UnlinkedBCO
bco

  BCOPtr
BCOPtrBreakArray
    -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall a. a -> IO a
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
   = 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
        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
        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
        ]


-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
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
    ]