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

-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeLink (
        ClosureEnv, emptyClosureEnv, extendClosureEnv,
        linkBCO, lookupStaticPtr,
        lookupIE,
        nameToCLabel, linkFail
  ) where

#include "HsVersions.h"

import GhcPrelude

import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray
import SizedSeq

import GHCi
import ByteCodeTypes
import HscTypes
import Name
import NameEnv
import PrimOp
import Module
import FastString
import Panic
import Outputable
import Util

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

{-
  Linking interpretables into something we can run
-}

type ClosureEnv = NameEnv (Name, ForeignHValue)

emptyClosureEnv :: ClosureEnv
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = ClosureEnv
forall a. NameEnv a
emptyNameEnv

extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv :: ClosureEnv -> [(Name, ForeignHValue)] -> ClosureEnv
extendClosureEnv cl_env :: ClosureEnv
cl_env pairs :: [(Name, ForeignHValue)]
pairs
  = ClosureEnv -> [(Name, (Name, ForeignHValue))] -> ClosureEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList ClosureEnv
cl_env [ (Name
n, (Name
n,ForeignHValue
v)) | (n :: Name
n,v :: ForeignHValue
v) <- [(Name, ForeignHValue)]
pairs]

{-
  Linking interpretables into something we can run
-}

linkBCO
  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
  -> UnlinkedBCO
  -> IO ResolvedBCO
linkBCO :: HscEnv
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO hsc_env :: HscEnv
hsc_env ie :: ItblEnv
ie ce :: ClosureEnv
ce bco_ix :: NameEnv Int
bco_ix breakarray :: RemoteRef BreakArray
breakarray
           (UnlinkedBCO _ arity :: Int
arity insns :: UArray Int Word16
insns bitmap :: UArray Int Word64
bitmap lits0 :: SizedSeq BCONPtr
lits0 ptrs0 :: 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)
mapM ((Word -> Word64) -> IO Word -> IO Word64
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
. HscEnv -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral HscEnv
hsc_env ItblEnv
ie) (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)
mapM (HscEnv
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr HscEnv
hsc_env ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray) (SizedSeq BCOPtr -> [BCOPtr]
forall a. SizedSeq a -> [a]
ssElts SizedSeq BCOPtr
ptrs0)
  ResolvedBCO -> IO ResolvedBCO
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 (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
-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 :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral _ _ (BCONPtrWord lit :: Word
lit) = Word -> IO Word
forall (m :: * -> *) a. Monad m => a -> m a
return Word
lit
lookupLiteral hsc_env :: HscEnv
hsc_env _ (BCONPtrLbl  sym :: FastString
sym) = do
  Ptr a# :: Addr#
a# <- HscEnv -> FastString -> IO (Ptr ())
lookupStaticPtr HscEnv
hsc_env FastString
sym
  Word -> IO Word
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
lookupLiteral hsc_env :: HscEnv
hsc_env ie :: ItblEnv
ie (BCONPtrItbl nm :: Name
nm)  = do
  Ptr a# :: Addr#
a# <- HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE HscEnv
hsc_env ItblEnv
ie Name
nm
  Word -> IO Word
forall (m :: * -> *) a. Monad m => a -> m a
return (Word# -> Word
W# (Int# -> Word#
int2Word# (Addr# -> Int#
addr2Int# Addr#
a#)))
lookupLiteral _ _ (BCONPtrStr _) =
  -- should be eliminated during assembleBCOs
  String -> IO Word
forall a. String -> a
panic "lookupLiteral: BCONPtrStr"

lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
lookupStaticPtr hsc_env :: HscEnv
hsc_env addr_of_label_string :: FastString
addr_of_label_string = do
  Maybe (Ptr ())
m <- HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol HscEnv
hsc_env FastString
addr_of_label_string
  case Maybe (Ptr ())
m of
    Just ptr :: Ptr ()
ptr -> Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
ptr
    Nothing  -> String -> String -> IO (Ptr ())
forall a. String -> String -> IO a
linkFail "ByteCodeLink: can't find label"
                  (FastString -> String
unpackFS FastString
addr_of_label_string)

lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE hsc_env :: HscEnv
hsc_env ie :: ItblEnv
ie con_nm :: Name
con_nm =
  case ItblEnv -> Name -> Maybe (Name, ItblPtr)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ItblEnv
ie Name
con_nm of
    Just (_, ItblPtr a :: RemotePtr StgInfoTable
a) -> Ptr () -> IO (Ptr ())
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))
    Nothing -> do -- try looking up in the object files.
       let sym_to_find1 :: FastString
sym_to_find1 = Name -> String -> FastString
nameToCLabel Name
con_nm "con_info"
       Maybe (Ptr ())
m <- HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol HscEnv
hsc_env FastString
sym_to_find1
       case Maybe (Ptr ())
m of
          Just addr :: Ptr ()
addr -> Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
          Nothing
             -> do -- perhaps a nullary constructor?
                   let sym_to_find2 :: FastString
sym_to_find2 = Name -> String -> FastString
nameToCLabel Name
con_nm "static_info"
                   Maybe (Ptr ())
n <- HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol HscEnv
hsc_env FastString
sym_to_find2
                   case Maybe (Ptr ())
n of
                      Just addr :: Ptr ()
addr -> Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
addr
                      Nothing   -> String -> String -> IO (Ptr ())
forall a. String -> String -> IO a
linkFail "ByteCodeLink.lookupIE"
                                      (FastString -> String
unpackFS FastString
sym_to_find1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ " or " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       FastString -> String
unpackFS FastString
sym_to_find2)

lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
lookupPrimOp hsc_env :: HscEnv
hsc_env primop :: PrimOp
primop = do
  let sym_to_find :: String
sym_to_find = PrimOp -> String -> String
primopToCLabel PrimOp
primop "closure"
  Maybe (Ptr ())
m <- HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol HscEnv
hsc_env (String -> FastString
mkFastString String
sym_to_find)
  case Maybe (Ptr ())
m of
    Just p :: Ptr ()
p -> RemotePtr () -> IO (RemotePtr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p)
    Nothing -> String -> String -> IO (RemotePtr ())
forall a. String -> String -> IO a
linkFail "ByteCodeLink.lookupCE(primop)" String
sym_to_find

resolvePtr
  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
  -> BCOPtr
  -> IO ResolvedBCOPtr
resolvePtr :: HscEnv
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr hsc_env :: HscEnv
hsc_env _ie :: ItblEnv
_ie ce :: ClosureEnv
ce bco_ix :: NameEnv Int
bco_ix _ (BCOPtrName nm :: Name
nm)
  | Just ix :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Int -> ResolvedBCOPtr
ResolvedBCORef Int
ix) -- ref to another BCO in this group
  | Just (_, rhv :: ForeignHValue
rhv) <- ClosureEnv -> Name -> Maybe (Name, ForeignHValue)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ClosureEnv
ce Name
nm =
    ResolvedBCOPtr -> IO ResolvedBCOPtr
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 =
    ASSERT2(isExternalName nm, ppr nm)
    do let sym_to_find :: FastString
sym_to_find = Name -> String -> FastString
nameToCLabel Name
nm "closure"
       Maybe (Ptr ())
m <- HscEnv -> FastString -> IO (Maybe (Ptr ()))
lookupSymbol HscEnv
hsc_env FastString
sym_to_find
       case Maybe (Ptr ())
m of
         Just p :: Ptr ()
p -> ResolvedBCOPtr -> IO ResolvedBCOPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr (Ptr () -> RemotePtr ()
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr ()
p))
         Nothing -> String -> String -> IO ResolvedBCOPtr
forall a. String -> String -> IO a
linkFail "ByteCodeLink.lookupCE" (FastString -> String
unpackFS FastString
sym_to_find)
resolvePtr hsc_env :: HscEnv
hsc_env _ _ _ _ (BCOPtrPrimOp op :: PrimOp
op) =
  RemotePtr () -> ResolvedBCOPtr
ResolvedBCOStaticPtr (RemotePtr () -> ResolvedBCOPtr)
-> IO (RemotePtr ()) -> IO ResolvedBCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> PrimOp -> IO (RemotePtr ())
lookupPrimOp HscEnv
hsc_env PrimOp
op
resolvePtr hsc_env :: HscEnv
hsc_env ie :: ItblEnv
ie ce :: ClosureEnv
ce bco_ix :: NameEnv Int
bco_ix breakarray :: RemoteRef BreakArray
breakarray (BCOPtrBCO bco :: UnlinkedBCO
bco) =
  ResolvedBCO -> ResolvedBCOPtr
ResolvedBCOPtrBCO (ResolvedBCO -> ResolvedBCOPtr)
-> IO ResolvedBCO -> IO ResolvedBCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> ItblEnv
-> ClosureEnv
-> NameEnv Int
-> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO HscEnv
hsc_env ItblEnv
ie ClosureEnv
ce NameEnv Int
bco_ix RemoteRef BreakArray
breakarray UnlinkedBCO
bco
resolvePtr _ _ _ _ breakarray :: RemoteRef BreakArray
breakarray BCOPtrBreakArray =
  ResolvedBCOPtr -> IO ResolvedBCOPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteRef BreakArray -> ResolvedBCOPtr
ResolvedBCOPtrBreakArray RemoteRef BreakArray
breakarray)

linkFail :: String -> String -> IO a
linkFail :: String -> String -> IO a
linkFail who :: String
who what :: 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
who
                , "During interactive linking, GHCi couldn't find the following symbol:"
                , ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
what
                , "This may be due to you not asking GHCi to load extra object files,"
                , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
                , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
                , "flags, or simply by naming the relevant files on the GHCi command line."
                , "Alternatively, this link failure might indicate a bug in GHCi."
                , "If you suspect the latter, please send a bug report to:"
                , "  glasgow-haskell-bugs@haskell.org"
                ])


nameToCLabel :: Name -> String -> FastString
nameToCLabel :: Name -> String -> FastString
nameToCLabel n :: Name
n suffix :: 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 pkgKey :: UnitId
pkgKey modName :: ModuleName
modName) = ASSERT( isExternalName n ) nameModule n
    packagePart :: String
packagePart = FastString -> String
encodeZ (UnitId -> FastString
unitIdFS UnitId
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 = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ if UnitId
pkgKey UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
mainUnitId then "" else String
packagePart String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"
        , String
modulePart
        , '_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
occPart
        , '_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
suffix
        ]


primopToCLabel :: PrimOp -> String -> String
primopToCLabel :: PrimOp -> String -> String
primopToCLabel primop :: PrimOp
primop suffix :: String
suffix = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ "ghczmprim_GHCziPrimopWrappers_"
    , FastZString -> String
zString (FastString -> FastZString
zEncodeFS (OccName -> FastString
occNameFS (PrimOp -> OccName
primOpOcc PrimOp
primop)))
    , '_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
suffix
    ]