summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeAsm.hs93
-rw-r--r--compiler/ghci/ByteCodeGen.hs175
-rw-r--r--compiler/ghci/ByteCodeInstr.hs55
-rw-r--r--compiler/ghci/ByteCodeItbls.hs437
-rw-r--r--compiler/ghci/ByteCodeLink.hs284
-rw-r--r--compiler/ghci/ByteCodeTypes.hs90
-rw-r--r--compiler/ghci/Debugger.hs8
-rw-r--r--compiler/ghci/DebuggerUtils.hs2
-rw-r--r--compiler/ghci/GHCi.hs499
-rw-r--r--compiler/ghci/Linker.hs544
-rw-r--r--compiler/ghci/ObjLink.hs142
-rw-r--r--compiler/ghci/RtClosureInspect.hs14
12 files changed, 1168 insertions, 1175 deletions
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index c69cede7f3..875de879cb 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -8,8 +8,7 @@
module ByteCodeAsm (
assembleBCOs, assembleBCO,
- CompiledByteCode(..),
- UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
+ bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH
) where
@@ -18,12 +17,13 @@ module ByteCodeAsm (
import ByteCodeInstr
import ByteCodeItbls
+import ByteCodeTypes
+import HscTypes
import Name
import NameSet
import Literal
import TyCon
-import PrimOp
import FastString
import StgCmmLayout ( ArgRep(..) )
import SMRep
@@ -32,6 +32,9 @@ import Outputable
import Platform
import Util
+-- From iserv
+import SizedSeq
+
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
@@ -47,6 +50,7 @@ import Data.Array.Base ( UArray(..) )
import Data.Array.Unsafe( castSTUArray )
+import qualified Data.ByteString as B
import Foreign
import Data.Char ( ord )
import Data.List
@@ -54,44 +58,12 @@ import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
-import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
-
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
-- CompiledByteCode represents the result of byte-code
-- compiling a bunch of functions and data types
-data CompiledByteCode
- = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
- ItblEnv -- A mapping from DataCons to their itbls
-
-instance Outputable CompiledByteCode where
- ppr (ByteCode bcos _) = ppr bcos
-
-
-data UnlinkedBCO
- = UnlinkedBCO {
- unlinkedBCOName :: Name,
- unlinkedBCOArity :: Int,
- unlinkedBCOInstrs :: ByteArray#, -- insns
- unlinkedBCOBitmap :: ByteArray#, -- bitmap
- unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
- unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
- }
-
-data BCOPtr
- = BCOPtrName Name
- | BCOPtrPrimOp PrimOp
- | BCOPtrBCO UnlinkedBCO
- | BCOPtrBreakInfo BreakInfo
- | BCOPtrArray (MutableByteArray# RealWorld)
-
-data BCONPtr
- = BCONPtrWord Word
- | BCONPtrLbl FastString
- | BCONPtrItbl Name
-
-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames :: UnlinkedBCO -> NameSet
@@ -105,12 +77,6 @@ bcoFreeNames bco
map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
)
-instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
- = sep [text "BCO", ppr nm, text "with",
- ppr (sizeSS lits), text "lits",
- ppr (sizeSS ptrs), text "ptrs" ]
-
-- -----------------------------------------------------------------------------
-- The bytecode assembler
@@ -122,11 +88,11 @@ instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
-assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs dflags proto_bcos tycons
- = do itblenv <- mkITbls dflags tycons
- bcos <- mapM (assembleBCO dflags) proto_bcos
- return (ByteCode bcos itblenv)
+assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs hsc_env proto_bcos tycons = do
+ itblenv <- mkITbls hsc_env tycons
+ bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
+ return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
@@ -161,15 +127,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
ASSERT(n_insns == sizeSS final_insns) return ()
let asm_insns = ssElts final_insns
- barr a = case a of UArray _lo _hi _n b -> b
-
- insns_arr = Array.listArray (0, n_insns - 1) asm_insns
- !insns_barr = barr insns_arr
-
+ insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
bitmap_arr = mkBitmapArray bsize bitmap
- !bitmap_barr = barr bitmap_arr
-
- ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
+ ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
@@ -191,23 +151,6 @@ type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
-data SizedSeq a = SizedSeq !Word [a]
-emptySS :: SizedSeq a
-emptySS = SizedSeq 0 []
-
-addToSS :: SizedSeq a -> a -> SizedSeq a
-addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
-
-addListToSS :: SizedSeq a -> [a] -> SizedSeq a
-addListToSS (SizedSeq n r_xs) xs
- = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
-
-ssElts :: SizedSeq a -> [a]
-ssElts (SizedSeq _ r_xs) = reverse r_xs
-
-sizeSS :: SizedSeq a -> Word
-sizeSS (SizedSeq n _) = n
-
data Operand
= Op Word
| SmallOp Word16
@@ -365,9 +308,7 @@ assembleI dflags i = case i of
-> do let ul_bco = assembleBCO dflags proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
- PUSH_UBX (Left lit) nws -> do np <- literal lit
- emit bci_PUSH_UBX [Op np, SmallOp nws]
- PUSH_UBX (Right aa) nws -> do np <- addr aa
+ PUSH_UBX lit nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_APPLY_N -> emit bci_PUSH_APPLY_N []
@@ -437,7 +378,9 @@ assembleI dflags i = case i of
literal (MachChar c) = int (ord c)
literal (MachInt64 ii) = int64 (fromIntegral ii)
literal (MachWord64 ii) = int64 (fromIntegral ii)
- literal other = pprPanic "ByteCodeAsm.literal" (ppr other)
+ literal (MachStr bs) = lit [BCONPtrStr (bs `B.snoc` 0)]
+ -- MachStr requires a zero-terminator when emitted
+ literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
litlabel fs = lit [BCONPtrLbl fs]
addr = words . mkLitPtr
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index f331214892..f74b4c439a 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -9,11 +9,13 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import ByteCodeInstr
-import ByteCodeItbls
import ByteCodeAsm
-import ByteCodeLink
-import LibFFI
+import ByteCodeTypes
+import GHCi
+import GHCi.FFI
+import GHCi.RemoteTypes
+import BasicTypes
import DynFlags
import Outputable
import Platform
@@ -45,7 +47,6 @@ import OrdList
import Data.List
import Foreign
-import Foreign.C
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
@@ -59,8 +60,6 @@ import Data.Maybe
import Module
import Control.Arrow ( second )
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Unsafe as BS
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
@@ -69,42 +68,43 @@ import Data.Ord
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
-byteCodeGen :: DynFlags
+byteCodeGen :: HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags this_mod binds tycs modBreaks
- = do showPass dflags "ByteCodeGen"
+byteCodeGen hsc_env this_mod binds tycs modBreaks
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags "ByteCodeGen"
let flatBinds = [ (bndr, simpleFreeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
us <- mkSplitUniqSupply 'y'
- (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
- <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
+ (BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos)
+ <- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds)
- when (notNull mallocd)
+ when (notNull ffis)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- assembleBCOs dflags proto_bcos tycs
- where
+ assembleBCOs hsc_env proto_bcos tycs
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
-coreExprToBCOs :: DynFlags
+coreExprToBCOs :: HscEnv
-> Module
-> CoreExpr
-> IO UnlinkedBCO
-coreExprToBCOs dflags this_mod expr
- = do showPass dflags "ByteCodeGen"
+coreExprToBCOs hsc_env this_mod expr
+ = do let dflags = hsc_dflags hsc_env
+ showPass dflags "ByteCodeGen"
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
@@ -115,7 +115,7 @@ coreExprToBCOs dflags this_mod expr
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
- <- runBc dflags us this_mod emptyModBreaks $
+ <- runBc hsc_env us this_mod emptyModBreaks $
schemeTopBind (invented_id, simpleFreeVars expr)
when (notNull mallocd)
@@ -184,9 +184,9 @@ mkProtoBCO
-> Word16
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
- -> [BcPtr]
+ -> [FFIInfo]
-> ProtoBCO name
-mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
@@ -194,7 +194,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo
protoBCOBitmapSize = bitmap_size,
protoBCOArity = arity,
protoBCOExpr = origin,
- protoBCOPtrs = mallocd_blocks
+ protoBCOFFIs = ffis
}
where
-- Overestimate the stack usage (in words) of this BCO,
@@ -1042,27 +1042,23 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
- get_target_info = do
+ maybe_static_target =
case target of
- DynamicTarget
- -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
-
+ DynamicTarget -> Nothing
StaticTarget _ _ _ False ->
- panic "generateCCall: unexpected FFI value import"
- StaticTarget _ target _ True
- -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
- return (True, res)
+ panic "generateCCall: unexpected FFI value import"
+ StaticTarget _ target _ True ->
+ Just (MachLabel target mb_size IsFunction)
where
- stdcall_adj_target
+ mb_size
| OSMinGW32 <- platformOS (targetPlatform dflags)
, StdCallConv <- cconv
- = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
- mkFastString (unpackFS target ++ '@':show size)
+ = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
| otherwise
- = target
+ = Nothing
- (is_static, static_target_addr) <- get_target_info
let
+ is_static = isJust maybe_static_target
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
@@ -1073,8 +1069,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- push the Addr#
(push_Addr, d_after_Addr)
- | is_static
- = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
+ | Just machlabel <- maybe_static_target
+ = (toOL [PUSH_UBX machlabel addr_sizeW],
d_after_args + fromIntegral addr_sizeW)
| otherwise -- is already on the stack
= (nilOL, d_after_args)
@@ -1086,7 +1082,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
then nilOL
- else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
+ else unitOL (PUSH_UBX r_lit r_sizeW))
-- generate the marshalling code we're going to call
@@ -1096,16 +1092,26 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- is. See comment in Interpreter.c with the CCALL instruction.
stk_offset = trunc16 $ d_after_r - s
+ conv = case cconv of
+ CCallConv -> FFICCall
+ StdCallConv -> FFIStdCall
+ _ -> panic "ByteCodeGen: unexpected calling convention"
+
-- the only difference in libffi mode is that we prepare a cif
-- describing the call type by calling libffi, and we attach the
-- address of this to the CCALL instruction.
- token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
- let addr_of_marshaller = castPtrToFunPtr token
- recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
+
+ let ffires = primRepToFFIType dflags r_rep
+ ffiargs = map (primRepToFFIType dflags) a_reps
+ hsc_env <- getHscEnv
+ rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+ let token = fromRemotePtr rp
+ recordFFIBc token
+
let
-- do the call
- do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
+ do_call = unitOL (CCALL stk_offset token
(fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
@@ -1116,6 +1122,24 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
+primRepToFFIType :: DynFlags -> PrimRep -> FFIType
+primRepToFFIType dflags r
+ = case r of
+ VoidRep -> FFIVoid
+ IntRep -> signed_word
+ WordRep -> unsigned_word
+ Int64Rep -> FFISInt64
+ Word64Rep -> FFIUInt64
+ AddrRep -> FFIPointer
+ FloatRep -> FFIFloat
+ DoubleRep -> FFIDouble
+ _ -> panic "primRepToFFIType"
+ where
+ (signed_word, unsigned_word)
+ | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32)
+ | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64)
+ | otherwise = panic "primTyDescChar"
+
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: PrimRep -> Literal
@@ -1240,7 +1264,7 @@ implement_tagToId d s p arg names
steps = map (mkStep label_exit) infos
return (push_arg
- `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1)
+ `appOL` unitOL (PUSH_UBX MachNullAddr 1)
-- Push bogus word (see Note [Implementing tagToEnum#])
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
@@ -1319,7 +1343,7 @@ pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags
let code rep
= let size_host_words = fromIntegral (argRepSizeW dflags rep)
- in return (unitOL (PUSH_UBX (Left lit) size_host_words),
+ in return (unitOL (PUSH_UBX lit size_host_words),
size_host_words)
case lit of
@@ -1332,42 +1356,16 @@ pushAtom _ _ (AnnLit lit) = do
MachDouble _ -> code D
MachChar _ -> code N
MachNullAddr -> code N
- MachStr s -> pushStr s
+ MachStr _ -> code N
-- No LitInteger's should be left by the time this is called.
-- CorePrep should have converted them all to a real core
-- representation.
LitInteger {} -> panic "pushAtom: LitInteger"
- where
- pushStr s
- = let getMallocvilleAddr
- =
- -- we could grab the Ptr from the ForeignPtr,
- -- but then we have no way to control its lifetime.
- -- In reality it'll probably stay alive long enoungh
- -- by virtue of the global FastString table, but
- -- to be on the safe side we copy the string into
- -- a malloc'd area of memory.
- do let n = BS.length s
- ptr <- ioToBc (mallocBytes (n+1))
- recordMallocBc ptr
- ioToBc (
- BS.unsafeUseAsCString s $ \p -> do
- memcpy ptr p (fromIntegral n)
- pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
- return ptr
- )
- in do
- addr <- getMallocvilleAddr
- -- Get the addr on the stack, untaggedly
- return (unitOL (PUSH_UBX (Right addr) 1), 1)
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
-foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
-
-- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work
@@ -1627,15 +1625,13 @@ typeArgRep = toArgRep . typePrimRep
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
-type BcPtr = Either ItblPtr (Ptr ())
-
data BcM_State
= BcM_State
- { bcm_dflags :: DynFlags
- , uniqSupply :: UniqSupply -- for generating fresh variable names
- , thisModule :: Module -- current module (for breakpoints)
- , nextlabel :: Word16 -- for generating local labels
- , malloced :: [BcPtr] -- thunks malloced for current BCO
+ { bcm_hsc_env :: HscEnv
+ , uniqSupply :: UniqSupply -- for generating fresh variable names
+ , thisModule :: Module -- current module (for breakpoints)
+ , nextlabel :: Word16 -- for generating local labels
+ , ffis :: [FFIInfo] -- ffi info blocks, to free later
-- Should be free()d when it is GCd
, breakArray :: BreakArray -- array of breakpoint flags
}
@@ -1647,10 +1643,10 @@ ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
-runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
-> IO (BcM_State, r)
-runBc dflags us this_mod modBreaks (BcM m)
- = m (BcM_State dflags us this_mod 0 [] breakArray)
+runBc hsc_env us this_mod modBreaks (BcM m)
+ = m (BcM_State hsc_env us this_mod 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
@@ -1684,19 +1680,18 @@ instance Monad BcM where
return = pure
instance HasDynFlags BcM where
- getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+ getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
-emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
-emitBc bco
- = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
-recordMallocBc :: Ptr a -> BcM ()
-recordMallocBc a
- = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+ = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
-recordItblMallocBc :: ItblPtr -> BcM ()
-recordItblMallocBc a
- = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
+recordFFIBc :: Ptr () -> BcM ()
+recordFFIBc a
+ = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
getLabelBc :: BcM Word16
getLabelBc
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index 2de4941aa6..4f2b82ba27 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -6,17 +6,15 @@
-- | ByteCodeInstrs: Bytecode instruction definitions
module ByteCodeInstr (
- BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
+ BCInstr(..), ProtoBCO(..), bciStackUse,
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
-import ByteCodeItbls ( ItblPtr )
-
+import ByteCodeTypes
import StgCmmLayout ( ArgRep(..) )
import PprCore
-import Type
import Outputable
import FastString
import Name
@@ -28,7 +26,6 @@ import VarSet
import PrimOp
import SMRep
-import Module (Module)
import GHC.Exts
import Data.Word
@@ -46,7 +43,7 @@ data ProtoBCO a
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
-- malloc'd pointers
- protoBCOPtrs :: [Either ItblPtr (Ptr ())]
+ protoBCOFFIs :: [FFIInfo]
}
type LocalLabel = Word16
@@ -70,7 +67,7 @@ data BCInstr
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
-- Pushing literals
- | PUSH_UBX (Either Literal (Ptr ())) Word16
+ | PUSH_UBX Literal Word16
-- push this int/float/double/addr, on the stack. Word16
-- is # of words to copy from literal pool. Eitherness reflects
-- the difficulty of dealing with MachAddr here, mostly due to
@@ -144,28 +141,13 @@ data BCInstr
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
-data BreakInfo
- = BreakInfo
- { breakInfo_module :: Module
- , breakInfo_number :: {-# UNPACK #-} !Int
- , breakInfo_vars :: [(Id,Word16)]
- , breakInfo_resty :: Type
- }
-
-instance Outputable BreakInfo where
- ppr info = text "BreakInfo" <+>
- parens (ppr (breakInfo_module info) <+>
- ppr (breakInfo_number info) <+>
- ppr (breakInfo_vars info) <+>
- ppr (breakInfo_resty info))
-
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
instance Outputable a => Outputable (ProtoBCO a) where
- ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
+ ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
- <+> text (show malloced) <> colon)
+ <+> text (show ffis) <> colon)
$$ nest 3 (case origin of
Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
(map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
@@ -210,19 +192,18 @@ instance Outputable BCInstr where
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
- ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
- ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
- ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
- ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
- ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
- ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
- ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
- ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
- ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
- ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
- ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
- ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
- ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
+ ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+ ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
+ ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
+ ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
+ ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
+ ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
+ ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
+ ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
+ ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
+ ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
+ ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
+ ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 01420f5e34..5a3e6d3e1a 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -5,416 +5,69 @@
--
-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
-module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl
- , StgInfoTable(..)
- ) where
+module ByteCodeItbls ( mkITbls ) where
#include "HsVersions.h"
+import ByteCodeTypes
+import GHCi
+import GHCi.RemoteTypes
import DynFlags
-import Panic
-import Platform
+import HscTypes
import Name ( Name, getName )
import NameEnv
import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Type ( flattenRepType, repType, typePrimRep )
import StgCmmLayout ( mkVirtHeapOffsets )
-import CmmInfo ( conInfoTableSizeB, profInfoTableSizeW )
import Util
-
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State.Strict
-import Data.Maybe
-import Foreign
-import Foreign.C
-
-import GHC.Exts ( Int(I#), addr2Int# )
-import GHC.Ptr ( FunPtr(..) )
+import Panic
{-
Manufacturing of info tables for DataCons
-}
-newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
-
-itblCode :: DynFlags -> ItblPtr -> Ptr ()
-itblCode dflags (ItblPtr ptr)
- | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags
- | otherwise = castPtr ptr
-
-type ItblEnv = NameEnv (Name, ItblPtr)
- -- We need the Name in the range so we know which
- -- elements to filter out when unloading a module
+-- Make info tables for the data decls in this module
+mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
+mkITbls hsc_env tcs =
+ foldr plusNameEnv emptyNameEnv <$>
+ mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+ where
+ mkITbl :: HscEnv -> TyCon -> IO ItblEnv
+ mkITbl hsc_env tc
+ | dcs `lengthIs` n -- paranoia; this is an assertion.
+ = make_constr_itbls hsc_env dcs
+ where
+ dcs = tyConDataCons tc
+ n = tyConFamilySize tc
+ mkITbl _ _ = panic "mkITbl"
mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
-
--- Make info tables for the data decls in this module
-mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv
-mkITbls _ [] = return emptyNameEnv
-mkITbls dflags (tc:tcs) = do itbls <- mkITbl dflags tc
- itbls2 <- mkITbls dflags tcs
- return (itbls `plusNameEnv` itbls2)
-
-mkITbl :: DynFlags -> TyCon -> IO ItblEnv
-mkITbl dflags tc
- | not (isDataTyCon tc)
- = return emptyNameEnv
- | dcs `lengthIs` n -- paranoia; this is an assertion.
- = make_constr_itbls dflags dcs
- where
- dcs = tyConDataCons tc
- n = tyConFamilySize tc
-
-mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!"
-
-#include "../includes/rts/storage/ClosureTypes.h"
-cONSTR :: Int -- Defined in ClosureTypes.h
-cONSTR = CONSTR
-
-- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv
-make_constr_itbls dflags cons
- = do is <- mapM mk_dirret_itbl (zip cons [0..])
- return (mkItblEnv is)
- where
- mk_dirret_itbl (dcon, conNo)
- = mk_itbl dcon conNo stg_interp_constr_entry
-
- mk_itbl :: DataCon -> Int -> EntryFunPtr -> IO (Name,ItblPtr)
- mk_itbl dcon conNo entry_addr = do
- let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
- (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
-
- ptrs' = ptr_wds
- nptrs' = tot_wds - ptr_wds
- nptrs_really
- | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
- | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
- code' = mkJumpToAddr dflags entry_addr
- itbl = StgInfoTable {
- entry = if ghciTablesNextToCode
- then Nothing
- else Just entry_addr,
- ptrs = fromIntegral ptrs',
- nptrs = fromIntegral nptrs_really,
- tipe = fromIntegral cONSTR,
- srtlen = fromIntegral conNo,
- code = if ghciTablesNextToCode
- then Just code'
- else Nothing
- }
-
- -- Make a piece of code to jump to "entry_label".
- -- This is the only arch-dependent bit.
- addrCon <- newExecConItbl dflags itbl (dataConIdentity dcon)
- --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
- --putStrLn ("# ptrs of itbl is " ++ show ptrs)
- --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
- return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
-
-
--- Make code which causes a jump to the given address. This is the
--- only arch-dependent bit of the itbl story.
-
--- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
-#include "nativeGen/NCG.h"
-
-type ItblCodes = Either [Word8] [Word32]
-
-funPtrToInt :: FunPtr a -> Int
-funPtrToInt (FunPtr a#) = I# (addr2Int# a#)
-
-mkJumpToAddr :: DynFlags -> EntryFunPtr -> ItblCodes
-mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
- ArchSPARC ->
- -- After some consideration, we'll try this, where
- -- 0x55555555 stands in for the address to jump to.
- -- According to includes/rts/MachRegs.h, %g3 is very
- -- likely indeed to be baggable.
- --
- -- 0000 07155555 sethi %hi(0x55555555), %g3
- -- 0004 8610E155 or %g3, %lo(0x55555555), %g3
- -- 0008 81C0C000 jmp %g3
- -- 000c 01000000 nop
-
- let w32 = fromIntegral (funPtrToInt a)
-
- hi22, lo10 :: Word32 -> Word32
- lo10 x = x .&. 0x3FF
- hi22 x = (x `shiftR` 10) .&. 0x3FFFF
-
- in Right [ 0x07000000 .|. (hi22 w32),
- 0x8610E000 .|. (lo10 w32),
- 0x81C0C000,
- 0x01000000 ]
-
- ArchPPC ->
- -- We'll use r12, for no particular reason.
- -- 0xDEADBEEF stands for the address:
- -- 3D80DEAD lis r12,0xDEAD
- -- 618CBEEF ori r12,r12,0xBEEF
- -- 7D8903A6 mtctr r12
- -- 4E800420 bctr
-
- let w32 = fromIntegral (funPtrToInt a)
- hi16 x = (x `shiftR` 16) .&. 0xFFFF
- lo16 x = x .&. 0xFFFF
- in Right [ 0x3D800000 .|. hi16 w32,
- 0x618C0000 .|. lo16 w32,
- 0x7D8903A6, 0x4E800420 ]
-
- ArchX86 ->
- -- Let the address to jump to be 0xWWXXYYZZ.
- -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
- -- which is
- -- B8 ZZ YY XX WW FF E0
-
- let w32 = fromIntegral (funPtrToInt a) :: Word32
- insnBytes :: [Word8]
- insnBytes
- = [0xB8, byte0 w32, byte1 w32,
- byte2 w32, byte3 w32,
- 0xFF, 0xE0]
- in
- Left insnBytes
-
- ArchX86_64 ->
- -- Generates:
- -- jmpq *.L1(%rip)
- -- .align 8
- -- .L1:
- -- .quad <addr>
- --
- -- which looks like:
- -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 <f+0x10>
- -- with addr at 10.
- --
- -- We need a full 64-bit pointer (we can't assume the info table is
- -- allocated in low memory). Assuming the info pointer is aligned to
- -- an 8-byte boundary, the addr will also be aligned.
-
- let w64 = fromIntegral (funPtrToInt a) :: Word64
- insnBytes :: [Word8]
- insnBytes
- = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
- byte0 w64, byte1 w64, byte2 w64, byte3 w64,
- byte4 w64, byte5 w64, byte6 w64, byte7 w64]
- in
- Left insnBytes
-
- ArchAlpha ->
- let w64 = fromIntegral (funPtrToInt a) :: Word64
- in Right [ 0xc3800000 -- br at, .+4
- , 0xa79c000c -- ldq at, 12(at)
- , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well
- , 0x47ff041f -- nop
- , fromIntegral (w64 .&. 0x0000FFFF)
- , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
-
- ArchARM { } ->
- -- Generates Arm sequence,
- -- ldr r1, [pc, #0]
- -- bx r1
- --
- -- which looks like:
- -- 00000000 <.addr-0x8>:
- -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr>
- -- 4: 11ff2fe1 bx r1
- let w32 = fromIntegral (funPtrToInt a) :: Word32
- in Left [ 0x00, 0x10, 0x9f, 0xe5
- , 0x11, 0xff, 0x2f, 0xe1
- , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
-
- arch ->
- panic ("mkJumpToAddr not defined for " ++ show arch)
-
-byte0 :: (Integral w) => w -> Word8
-byte0 w = fromIntegral w
-
-byte1, byte2, byte3, byte4, byte5, byte6, byte7
- :: (Integral w, Bits w) => w -> Word8
-byte1 w = fromIntegral (w `shiftR` 8)
-byte2 w = fromIntegral (w `shiftR` 16)
-byte3 w = fromIntegral (w `shiftR` 24)
-byte4 w = fromIntegral (w `shiftR` 32)
-byte5 w = fromIntegral (w `shiftR` 40)
-byte6 w = fromIntegral (w `shiftR` 48)
-byte7 w = fromIntegral (w `shiftR` 56)
-
--- entry point for direct returns for created constr itbls
-foreign import ccall "&stg_interp_constr_entry"
- stg_interp_constr_entry :: EntryFunPtr
-
-
-
-
--- Ultra-minimalist version specially for constructors
-#if SIZEOF_VOID_P == 8
-type HalfWord = Word32
-type FullWord = Word64
-#else
-type HalfWord = Word16
-type FullWord = Word32
-#endif
-
-data StgConInfoTable = StgConInfoTable {
- conDesc :: Ptr Word8,
- infoTable :: StgInfoTable
-}
-
-sizeOfConItbl :: DynFlags -> StgConInfoTable -> Int
-sizeOfConItbl dflags conInfoTable
- = sum [ fieldSz conDesc conInfoTable
- , sizeOfItbl dflags (infoTable conInfoTable) ]
-
-pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable
- -> StgConInfoTable
- -> IO ()
-pokeConItbl dflags wr_ptr ex_ptr itbl
- = flip evalStateT (castPtr wr_ptr) $ do
- when ghciTablesNextToCode $ do
- let con_desc = conDesc itbl `minusPtr`
- (ex_ptr `plusPtr` conInfoTableSizeB dflags)
- store (fromIntegral con_desc :: Word32)
- when (wORD_SIZE dflags == 8) $
- store (fromIntegral con_desc :: Word32)
- store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl)
- unless ghciTablesNextToCode $ store (conDesc itbl)
-
-type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
-
-data StgInfoTable = StgInfoTable {
- entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
- ptrs :: HalfWord,
- nptrs :: HalfWord,
- tipe :: HalfWord,
- srtlen :: HalfWord,
- code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
- }
-
-sizeOfItbl :: DynFlags -> StgInfoTable -> Int
-sizeOfItbl dflags itbl
- = sum
- [
- if ghciTablesNextToCode then 0 else fieldSz (fromJust . entry) itbl,
- fieldSz ptrs itbl,
- fieldSz nptrs itbl,
- fieldSz tipe itbl,
- fieldSz srtlen itbl,
- if ghciTablesNextToCode then case mkJumpToAddr dflags undefined of
- Left xs -> sizeOf (head xs) * length xs
- Right xs -> sizeOf (head xs) * length xs
- else 0
- ]
- + if rtsIsProfiled then profInfoTableSizeW * wORD_SIZE dflags
- else 0
-
-pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO ()
-pokeItbl _ a0 itbl
- = flip evalStateT (castPtr a0)
- $ do
- case entry itbl of
- Nothing -> return ()
- Just e -> store e
- when rtsIsProfiled $ do
- store (0 :: FullWord)
- store (0 :: FullWord)
- store (ptrs itbl)
- store (nptrs itbl)
- store (tipe itbl)
- store (srtlen itbl)
- case code itbl of
- Nothing -> return ()
- Just (Left xs) -> mapM_ store xs
- Just (Right xs) -> mapM_ store xs
-
-peekItbl :: DynFlags -> Ptr StgInfoTable -> IO StgInfoTable
-peekItbl dflags a0
- = flip evalStateT (castPtr a0)
- $ do
- entry' <- if ghciTablesNextToCode
- then return Nothing
- else liftM Just load
- when rtsIsProfiled $ do
- (_ :: Ptr FullWord) <- advance
- (_ :: Ptr FullWord) <- advance
- return ()
- ptrs' <- load
- nptrs' <- load
- tipe' <- load
- srtlen' <- load
- code' <- if ghciTablesNextToCode
- then liftM Just $ case mkJumpToAddr dflags undefined of
- Left xs ->
- liftM Left $ sequence (replicate (length xs) load)
- Right xs ->
- liftM Right $ sequence (replicate (length xs) load)
- else return Nothing
- return
- StgInfoTable {
- entry = entry',
- ptrs = ptrs',
- nptrs = nptrs',
- tipe = tipe',
- srtlen = srtlen'
- ,code = code'
- }
-
-fieldSz :: Storable b => (a -> b) -> a -> Int
-fieldSz sel x = sizeOf (sel x)
-
-type PtrIO = StateT (Ptr Word8) IO
-
-advance :: Storable a => PtrIO (Ptr a)
-advance = advance' sizeOf
-
-advance' :: (a -> Int) -> PtrIO (Ptr a)
-advance' fSizeOf = state adv
- where adv addr = case castPtr addr of
- addrCast ->
- (addrCast,
- addr `plusPtr` sizeOfPointee fSizeOf addrCast)
-
-sizeOfPointee :: (a -> Int) -> Ptr a -> Int
-sizeOfPointee fSizeOf addr = fSizeOf (typeHack addr)
- where typeHack = undefined :: Ptr a -> a
-
-store :: Storable a => a -> PtrIO ()
-store = store' sizeOf poke
-
-store' :: (a -> Int) -> (Ptr a -> a -> IO ()) -> a -> PtrIO ()
-store' fSizeOf fPoke x = do addr <- advance' fSizeOf
- lift (fPoke addr x)
-
-load :: Storable a => PtrIO a
-load = do addr <- advance
- lift (peek addr)
-
-newExecConItbl :: DynFlags -> StgInfoTable -> [Word8] -> IO (FunPtr ())
-newExecConItbl dflags obj con_desc
- = alloca $ \pcode -> do
- let lcon_desc = length con_desc + 1{- null terminator -}
- dummy_cinfo = StgConInfoTable { conDesc = nullPtr, infoTable = obj }
- sz = fromIntegral (sizeOfConItbl dflags dummy_cinfo)
- -- Note: we need to allocate the conDesc string next to the info
- -- table, because on a 64-bit platform we reference this string
- -- with a 32-bit offset relative to the info table, so if we
- -- allocated the string separately it might be out of range.
- wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
- ex_ptr <- peek pcode
- let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
- , infoTable = obj }
- pokeConItbl dflags wr_ptr ex_ptr cinfo
- pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
- _flushExec sz ex_ptr -- Cache flush (if needed)
- return (castPtrToFunPtr ex_ptr)
-
-foreign import ccall unsafe "allocateExec"
- _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
-
-foreign import ccall unsafe "flushExec"
- _flushExec :: CUInt -> Ptr a -> IO ()
+make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
+make_constr_itbls hsc_env cons =
+ mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
+ where
+ dflags = hsc_dflags hsc_env
+
+ mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
+ mk_itbl dcon conNo = do
+ let rep_args = [ (typePrimRep rep_arg,rep_arg)
+ | arg <- dataConRepArgTys dcon
+ , rep_arg <- flattenRepType (repType arg) ]
+
+ (tot_wds, ptr_wds, _) =
+ mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
+
+ ptrs' = ptr_wds
+ nptrs' = tot_wds - ptr_wds
+ nptrs_really
+ | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
+ | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
+
+ descr = dataConIdentity dcon
+
+ r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really conNo descr)
+ return (getName dcon, ItblPtr (fromRemotePtr r))
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index b977f370d3..aa92ecc610 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -12,18 +12,21 @@
-- | ByteCodeLink: Bytecode assembler and linker
module ByteCodeLink (
ClosureEnv, emptyClosureEnv, extendClosureEnv,
- linkBCO, lookupStaticPtr, lookupName
- ,lookupIE
+ linkBCO, lookupStaticPtr,
+ lookupIE,
+ nameToCLabel, linkFail
) where
#include "HsVersions.h"
-import ByteCodeItbls
-import ByteCodeAsm
-import ObjLink
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.InfoTable
+import SizedSeq
-import DynFlags
-import BasicTypes
+import GHCi
+import ByteCodeTypes
+import HscTypes
import Name
import NameEnv
import PrimOp
@@ -34,27 +37,21 @@ import Outputable
import Util
-- Standard libraries
-
-import Data.Array.Base
-
-import Control.Monad
-import Control.Monad.ST ( stToIO )
-
-import GHC.Arr ( Array(..), STArray(..) )
+import Data.Array.Unboxed
+import Foreign.Ptr
import GHC.IO ( IO(..) )
import GHC.Exts
-import GHC.Ptr ( castPtr )
{-
Linking interpretables into something we can run
-}
-type ClosureEnv = NameEnv (Name, HValue)
+type ClosureEnv = NameEnv (Name, ForeignHValue)
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = emptyNameEnv
-extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
+extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
= extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
@@ -62,173 +59,86 @@ extendClosureEnv cl_env pairs
Linking interpretables into something we can run
-}
-{-
-data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
- ByteArray# -- literals :: Array Word32#
- PtrArray# -- ptrs :: Array HValue
- ByteArray# -- itbls :: Array Addr#
--}
-
-linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
-linkBCO dflags ie ce ul_bco
- = do BCO bco# <- linkBCO' dflags ie ce ul_bco
- -- SDM: Why do we need mkApUpd0 here? I *think* it's because
- -- otherwise top-level interpreted CAFs don't get updated
- -- after evaluation. A top-level BCO will evaluate itself and
- -- return its value when entered, but it won't update itself.
- -- Wrapping the BCO in an AP_UPD thunk will take care of the
- -- update for us.
- --
- -- Update: the above is true, but now we also have extra invariants:
- -- (a) An AP thunk *must* point directly to a BCO
- -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
- -- (c) An AP is always fully saturated, so we *can't* wrap
- -- non-zero arity BCOs in an AP thunk.
- --
- if (unlinkedBCOArity ul_bco > 0)
- then return (HValue (unsafeCoerce# bco#))
- else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) }
-
-
-linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
- -- Raises an IO exception on failure
- = do let literals = ssElts literalsSS
- ptrs = ssElts ptrsSS
-
- linked_literals <- mapM (lookupLiteral dflags ie) literals
-
- let n_literals = sizeSS literalsSS
- n_ptrs = sizeSS ptrsSS
-
- ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs
-
- let
- !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
-
- litRange
- | n_literals > 0 = (0, fromIntegral n_literals - 1)
- | otherwise = (1, 0)
- literals_arr :: UArray Word Word
- literals_arr = listArray litRange linked_literals
- !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
-
- !(I# arity#) = arity
-
- newBCO insns_barr literals_barr ptrs_parr arity# bitmap
-
-
--- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue)
-mkPtrsArray dflags ie ce n_ptrs ptrs = do
- let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
- marr <- newArray_ ptrRange
- let
- fill (BCOPtrName n) i = do
- ptr <- lookupName ce n
- unsafeWrite marr i ptr
- fill (BCOPtrPrimOp op) i = do
- ptr <- lookupPrimOp op
- unsafeWrite marr i ptr
- fill (BCOPtrBCO ul_bco) i = do
- BCO bco# <- linkBCO' dflags ie ce ul_bco
- writeArrayBCO marr i bco#
- fill (BCOPtrBreakInfo brkInfo) i =
- unsafeWrite marr i (HValue (unsafeCoerce# brkInfo))
- fill (BCOPtrArray brkArray) i =
- unsafeWrite marr i (HValue (unsafeCoerce# brkArray))
- zipWithM_ fill ptrs [0..]
- unsafeFreeze marr
-
-newtype IOArray i e = IOArray (STArray RealWorld i e)
-
-instance MArray IOArray e IO where
- getBounds (IOArray marr) = stToIO $ getBounds marr
- getNumElements (IOArray marr) = stToIO $ getNumElements marr
- newArray lu init = stToIO $ do
- marr <- newArray lu init; return (IOArray marr)
- newArray_ lu = stToIO $ do
- marr <- newArray_ lu; return (IOArray marr)
- unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
- unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-
--- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
-writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO ()
-writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
- case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
- (# s#, () #) }
-
-{-
-writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
-writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
- case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
- (# s#, () #) }
--}
-
-data BCO = BCO BCO#
-
-newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
-newBCO instrs lits ptrs arity bitmap
- = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
- (# s1, bco #) -> (# s1, BCO bco #)
-
-
-lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word
-lookupLiteral _ _ (BCONPtrWord lit) = return lit
-lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
- return (W# (int2Word# (addr2Int# a#)))
-lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm
- return (W# (int2Word# (addr2Int# a#)))
-
-lookupStaticPtr :: FastString -> IO (Ptr ())
-lookupStaticPtr addr_of_label_string
- = do let label_to_find = unpackFS addr_of_label_string
- m <- lookupSymbol label_to_find
- case m of
- Just ptr -> return ptr
- Nothing -> linkFail "ByteCodeLink: can't find label"
- label_to_find
-
-lookupPrimOp :: PrimOp -> IO HValue
-lookupPrimOp primop
- = do let sym_to_find = primopToCLabel primop "closure"
- m <- lookupSymbol sym_to_find
- case m of
- Just (Ptr addr) -> case addrToAny# addr of
- (# a #) -> return (HValue a)
- Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
-
-lookupName :: ClosureEnv -> Name -> IO HValue
-lookupName ce nm
- = case lookupNameEnv ce nm of
- Just (_,aa) -> return aa
- Nothing
- -> ASSERT2(isExternalName nm, ppr nm)
- do let sym_to_find = nameToCLabel nm "closure"
- m <- lookupSymbol sym_to_find
- case m of
- Just (Ptr addr) -> case addrToAny# addr of
- (# a #) -> return (HValue a)
- Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
-
-lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a)
-lookupIE dflags ie con_nm
- = case lookupNameEnv ie con_nm of
- Just (_, a) -> return (castPtr (itblCode dflags a))
- Nothing
- -> do -- try looking up in the object files.
- let sym_to_find1 = nameToCLabel con_nm "con_info"
- m <- lookupSymbol sym_to_find1
- case m of
- Just addr -> return addr
- Nothing
- -> do -- perhaps a nullary constructor?
- let sym_to_find2 = nameToCLabel con_nm "static_info"
- n <- lookupSymbol sym_to_find2
- case n of
- Just addr -> return addr
- Nothing -> linkFail "ByteCodeLink.lookupIE"
- (sym_to_find1 ++ " or " ++ sym_to_find2)
+linkBCO
+ :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO
+ -> IO ResolvedBCO
+linkBCO hsc_env ie ce bco_ix
+ (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
+ lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)
+ ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0)
+ return (ResolvedBCO arity insns bitmap
+ (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+ (addListToSS emptySS ptrs))
+
+lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral _ _ (BCONPtrWord lit) = return lit
+lookupLiteral hsc_env _ (BCONPtrLbl sym) = do
+ Ptr a# <- lookupStaticPtr hsc_env sym
+ return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral hsc_env ie (BCONPtrItbl nm) = do
+ Ptr a# <- lookupIE hsc_env ie nm
+ return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral hsc_env _ (BCONPtrStr bs) = do
+ fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs
+
+lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
+lookupStaticPtr hsc_env addr_of_label_string = do
+ m <- lookupSymbol hsc_env addr_of_label_string
+ case m of
+ Just ptr -> return ptr
+ Nothing -> linkFail "ByteCodeLink: can't find label"
+ (unpackFS addr_of_label_string)
+
+lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a)
+lookupIE hsc_env ie con_nm =
+ case lookupNameEnv ie con_nm of
+ Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a))
+ Nothing -> do -- try looking up in the object files.
+ let sym_to_find1 = nameToCLabel con_nm "con_info"
+ m <- lookupSymbol hsc_env sym_to_find1
+ case m of
+ Just addr -> return (castPtr addr)
+ Nothing
+ -> do -- perhaps a nullary constructor?
+ let sym_to_find2 = nameToCLabel con_nm "static_info"
+ n <- lookupSymbol hsc_env sym_to_find2
+ case n of
+ Just addr -> return (castPtr addr)
+ Nothing -> linkFail "ByteCodeLink.lookupIE"
+ (unpackFS sym_to_find1 ++ " or " ++
+ unpackFS sym_to_find2)
+
+lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr
+lookupPrimOp hsc_env primop = do
+ let sym_to_find = primopToCLabel primop "closure"
+ m <- lookupSymbol hsc_env (mkFastString sym_to_find)
+ case m of
+ Just p -> return (toRemotePtr p)
+ Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
+resolvePtr
+ :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr
+ -> IO ResolvedBCOPtr
+resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
+ | Just ix <- lookupNameEnv bco_ix nm =
+ return (ResolvedBCORef ix) -- ref to another BCO in this group
+ | Just (_, rhv) <- lookupNameEnv ce nm =
+ return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv))
+ | otherwise =
+ ASSERT2(isExternalName nm, ppr nm)
+ do let sym_to_find = nameToCLabel nm "closure"
+ m <- lookupSymbol hsc_env sym_to_find
+ case m of
+ Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+ Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
+resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
+ ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
+resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) =
+ ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco
+resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) =
+ return (ResolvedBCOPtrLocal (unsafeCoerce# break_info))
+resolvePtr _ _ _ _ (BCOPtrArray break_array) =
+ return (ResolvedBCOPtrLocal (unsafeCoerce# break_array))
linkFail :: String -> String -> IO a
linkFail who what
@@ -246,8 +156,9 @@ linkFail who what
])
-nameToCLabel :: Name -> String -> String
-nameToCLabel n suffix = label where
+nameToCLabel :: Name -> String -> FastString
+nameToCLabel n suffix = mkFastString label
+ where
encodeZ = zString . zEncodeFS
(Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
packagePart = encodeZ (unitIdFS pkgKey)
@@ -268,4 +179,3 @@ primopToCLabel primop suffix = concat
, zString (zEncodeFS (occNameFS (primOpOcc primop)))
, '_':suffix
]
-
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
new file mode 100644
index 0000000000..0a8dd304b6
--- /dev/null
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE MagicHash #-}
+--
+-- (c) The University of Glasgow 2002-2006
+--
+
+-- | Bytecode assembler types
+module ByteCodeTypes
+ ( CompiledByteCode(..), FFIInfo(..)
+ , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
+ , ItblEnv, ItblPtr(..)
+ , BreakInfo(..)
+ ) where
+
+import FastString
+import Id
+import Module
+import Name
+import NameEnv
+import Outputable
+import PrimOp
+import SizedSeq
+import Type
+
+import Foreign
+import Data.Array.Base ( UArray(..) )
+import Data.ByteString (ByteString)
+import GHC.Exts
+
+
+data CompiledByteCode
+ = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
+ ItblEnv -- A mapping from DataCons to their itbls
+ [FFIInfo] -- ffi blocks we allocated
+ -- ToDo: we're not tracking strings that we malloc'd
+
+newtype FFIInfo = FFIInfo (Ptr ())
+ deriving Show
+
+instance Outputable CompiledByteCode where
+ ppr (ByteCode bcos _ _) = ppr bcos
+
+type ItblEnv = NameEnv (Name, ItblPtr)
+ -- We need the Name in the range so we know which
+ -- elements to filter out when unloading a module
+
+newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
+
+data UnlinkedBCO
+ = UnlinkedBCO {
+ unlinkedBCOName :: Name,
+ unlinkedBCOArity :: Int,
+ unlinkedBCOInstrs :: UArray Int Word16, -- insns
+ unlinkedBCOBitmap :: UArray Int Word, -- bitmap
+ unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
+ unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
+ }
+
+data BCOPtr
+ = BCOPtrName Name
+ | BCOPtrPrimOp PrimOp
+ | BCOPtrBCO UnlinkedBCO
+ | BCOPtrBreakInfo BreakInfo
+ | BCOPtrArray (MutableByteArray# RealWorld)
+
+data BCONPtr
+ = BCONPtrWord Word
+ | BCONPtrLbl FastString
+ | BCONPtrItbl Name
+ | BCONPtrStr ByteString
+
+data BreakInfo
+ = BreakInfo
+ { breakInfo_module :: Module
+ , breakInfo_number :: {-# UNPACK #-} !Int
+ , breakInfo_vars :: [(Id,Word16)]
+ , breakInfo_resty :: Type
+ }
+
+instance Outputable UnlinkedBCO where
+ ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
+ = sep [text "BCO", ppr nm, text "with",
+ ppr (sizeSS lits), text "lits",
+ ppr (sizeSS ptrs), text "ptrs" ]
+
+instance Outputable BreakInfo where
+ ppr info = text "BreakInfo" <+>
+ parens (ppr (breakInfo_module info) <+>
+ ppr (breakInfo_number info) <+>
+ ppr (breakInfo_vars info) <+>
+ ppr (breakInfo_resty info))
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 2b9e732c4b..5c6a02d3ff 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -17,6 +17,8 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import Linker
import RtClosureInspect
+import GHCi
+import GHCi.RemoteTypes
import GhcMonad
import HscTypes
import Id
@@ -117,7 +119,8 @@ bindSuspensions t = do
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
- liftIO $ extendLinkEnv (zip names hvals)
+ fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) hvals
+ liftIO $ extendLinkEnv (zip names fhvs)
modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
return t'
where
@@ -170,7 +173,8 @@ showTerm term = do
let noop_log _ _ _ _ _ = return ()
expr = "show " ++ showPpr dflags bname
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
- txt_ <- withExtendedLinkEnv [(bname, val)]
+ fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkHValueRef val
+ txt_ <- withExtendedLinkEnv [(bname, fhv)]
(GHC.compileExpr expr)
let myprec = 10 -- application precedence. TODO Infix constructors
let txt = unsafeCoerce# txt_ :: [a]
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index d1ff9134ec..096b809c26 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -4,8 +4,8 @@ module DebuggerUtils (
dataConInfoPtrToName,
) where
+import GHCi.InfoTable
import CmmInfo ( stdInfoTableSizeB )
-import ByteCodeItbls
import DynFlags
import FastString
import TcRnTypes
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
new file mode 100644
index 0000000000..d9c26c1d47
--- /dev/null
+++ b/compiler/ghci/GHCi.hs
@@ -0,0 +1,499 @@
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
+
+--
+-- | Interacting with the interpreter, whether it is running on an
+-- external process or in the current process.
+--
+module GHCi
+ ( -- * High-level interface to the interpreter
+ evalStmt, EvalStatus(..), EvalResult(..), EvalExpr(..)
+ , resumeStmt
+ , abandonStmt
+ , evalIO
+ , evalString
+ , evalStringToIOString
+ , mallocData
+
+ -- * The object-code linker
+ , initObjLinker
+ , lookupSymbol
+ , lookupClosure
+ , loadDLL
+ , loadArchive
+ , loadObj
+ , unloadObj
+ , addLibrarySearchPath
+ , removeLibrarySearchPath
+ , resolveObjs
+ , findSystemLibrary
+
+ -- * Lower-level API using messages
+ , iservCmd, Message(..), withIServ, stopIServ
+ , iservCall, readIServ, writeIServ
+ , purgeLookupSymbolCache
+ , freeHValueRefs
+ , mkFinalizedHValue
+ , wormhole, wormholeRef
+ , mkEvalOpts
+ , fromEvalResult
+ ) where
+
+import GHCi.Message
+import GHCi.Run
+import GHCi.RemoteTypes
+import HscTypes
+import UniqFM
+import Panic
+import DynFlags
+#ifndef mingw32_HOST_OS
+import ErrUtils
+import Outputable
+#endif
+import Exception
+import BasicTypes
+import FastString
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Binary
+import Data.ByteString (ByteString)
+import Data.IORef
+import Foreign
+import System.Exit
+#ifndef mingw32_HOST_OS
+import Data.Maybe
+import System.Posix as Posix
+#endif
+import System.Process
+
+{- Note [Remote GHCi]
+
+When the flag -fexternal-interpreter is given to GHC, interpreted code
+is run in a separate process called iserv, and we communicate with the
+external process over a pipe using Binary-encoded messages.
+
+Motivation
+~~~~~~~~~~
+
+When the interpreted code is running in a separate process, it can
+use a different "way", e.g. profiled or dynamic. This means
+
+- compiling Template Haskell code with -prof does not require
+ building the code without -prof first
+
+- when GHC itself is profiled, it can interpret unprofiled code,
+ and the same applies to dynamic linking.
+
+- An unprofiled GHCi can load and run profiled code, which means it
+ can use the stack-trace functionality provided by profiling without
+ taking the performance hit on the compiler that profiling would
+ entail.
+
+For other reasons see RemoteGHCi on the wiki.
+
+Implementation Overview
+~~~~~~~~~~~~~~~~~~~~~~~
+
+The main pieces are:
+
+- libraries/ghci, containing:
+ - types for talking about remote values (GHCi.RemoteTypes)
+ - the message protocol (GHCi.Message),
+ - implementation of the messages (GHCi.Run)
+ - implementation of Template Haskell (GHCi.TH)
+ - a few other things needed to run interpreted code
+
+- top-level iserv directory, containing the codefor the external
+ server. This is a fairly simple wrapper, most of the functionality
+ is provided by modules in libraries/ghci.
+
+- This module (GHCi) which provides the interface to the server used
+ by the rest of GHC.
+
+GHC works with and without -fexternal-interpreter. With the flag, all
+interpreted code is run by the iserv binary. Without the flag,
+interpreted code is run in the same process as GHC.
+
+Things that do not work with -fexternal-interpreter
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+dynCompileExpr cannot work, because we have no way to run code of an
+unknown type in the remote process. This API fails with an error
+message if it is used with -fexternal-interpreter.
+-}
+
+-- | Run a command in the interpreter's context. With
+-- @-fexternal-interpreter@, the command is serialized and sent to an
+-- external iserv process, and the response is deserialized (hence the
+-- @Binary@ constraint). With @-fno-external-interpreter@ we execute
+-- the command directly here.
+iservCmd :: Binary a => HscEnv -> Message a -> IO a
+iservCmd hsc_env@HscEnv{..} msg
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+ withIServ hsc_env $ \iserv ->
+ uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
+ iservCall iserv msg
+ | otherwise = -- Just run it directly
+ run msg
+
+
+-- Note [uninterruptibleMask_ and iservCmd]
+--
+-- If we receive an async exception, such as ^C, while communicating
+-- with the iserv process then we will be out-of-sync and not be able
+-- to recoever. Thus we use uninterruptibleMask_ during
+-- communication. A ^C will be delivered to the iserv process (because
+-- signals get sent to the whole process group) which will interrupt
+-- the running computation and return an EvalException result.
+
+-- | Grab a lock on the 'IServ' and do something with it.
+-- Overloaded because this is used from TcM as well as IO.
+withIServ
+ :: (MonadIO m, ExceptionMonad m)
+ => HscEnv -> (IServ -> m a) -> m a
+withIServ HscEnv{..} action =
+ gmask $ \restore -> do
+ m <- liftIO $ takeMVar hsc_iserv
+ -- start the iserv process if we haven't done so yet
+ iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
+ `gonException` (liftIO $ putMVar hsc_iserv Nothing)
+ -- free any ForeignHValues that have been garbage collected.
+ let iserv' = iserv{ iservPendingFrees = [] }
+ a <- (do
+ liftIO $ when (not (null (iservPendingFrees iserv))) $
+ iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
+ -- run the inner action
+ restore $ action iserv)
+ `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
+ liftIO $ putMVar hsc_iserv (Just iserv')
+ return a
+
+
+-- -----------------------------------------------------------------------------
+-- Wrappers around messages
+
+-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
+-- each of the results.
+evalStmt
+ :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus [ForeignHValue])
+evalStmt hsc_env step foreign_expr = do
+ let dflags = hsc_dflags hsc_env
+ status <- withExpr foreign_expr $ \expr ->
+ iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
+ handleEvalStatus hsc_env status
+ where
+ withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
+ withExpr (EvalThis fhv) cont =
+ withForeignHValue fhv $ \hvref -> cont (EvalThis hvref)
+ withExpr (EvalApp fl fr) cont =
+ withExpr fl $ \fl' ->
+ withExpr fr $ \fr' ->
+ cont (EvalApp fl' fr')
+
+resumeStmt :: HscEnv -> Bool -> ForeignHValue -> IO (EvalStatus [ForeignHValue])
+resumeStmt hsc_env step resume_ctxt = do
+ let dflags = hsc_dflags hsc_env
+ status <- withForeignHValue resume_ctxt $ \rhv ->
+ iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
+ handleEvalStatus hsc_env status
+
+abandonStmt :: HscEnv -> ForeignHValue -> IO ()
+abandonStmt hsc_env resume_ctxt = do
+ withForeignHValue resume_ctxt $ \rhv ->
+ iservCmd hsc_env (AbandonStmt rhv)
+
+handleEvalStatus
+ :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue])
+handleEvalStatus hsc_env status =
+ case status of
+ EvalBreak a b c d -> return (EvalBreak a b c d)
+ EvalComplete alloc res ->
+ EvalComplete alloc <$> addFinalizer res
+ where
+ addFinalizer (EvalException e) = return (EvalException e)
+ addFinalizer (EvalSuccess rs) = do
+ EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
+
+-- | Execute an action of type @IO ()@
+evalIO :: HscEnv -> ForeignHValue -> IO ()
+evalIO hsc_env fhv = do
+ liftIO $ withForeignHValue fhv $ \fhv ->
+ iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
+
+-- | Execute an action of type @IO String@
+evalString :: HscEnv -> ForeignHValue -> IO String
+evalString hsc_env fhv = do
+ liftIO $ withForeignHValue fhv $ \fhv ->
+ iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
+
+-- | Execute an action of type @String -> IO String@
+evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
+evalStringToIOString hsc_env fhv str = do
+ liftIO $ withForeignHValue fhv $ \fhv ->
+ iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
+
+
+-- | Allocate and store the given bytes in memory, returning a pointer
+-- to the memory in the remote process.
+mallocData :: HscEnv -> ByteString -> IO (Ptr ())
+mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs)
+
+
+-- -----------------------------------------------------------------------------
+-- Interface to the object-code linker
+
+initObjLinker :: HscEnv -> IO ()
+initObjLinker hsc_env = iservCmd hsc_env InitLinker
+
+lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol hsc_env@HscEnv{..} str
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+ -- Profiling of GHCi showed a lot of time and allocation spent
+ -- making cross-process LookupSymbol calls, so I added a GHC-side
+ -- cache which sped things up quite a lot. We have to be careful
+ -- to purge this cache when unloading code though.
+ withIServ hsc_env $ \iserv@IServ{..} -> do
+ cache <- readIORef iservLookupSymbolCache
+ case lookupUFM cache str of
+ Just p -> return (Just p)
+ Nothing -> do
+ m <- uninterruptibleMask_ $
+ iservCall iserv (LookupSymbol (unpackFS str))
+ case m of
+ Nothing -> return Nothing
+ Just r -> do
+ let p = fromRemotePtr r
+ writeIORef iservLookupSymbolCache $! addToUFM cache str p
+ return (Just p)
+ | otherwise =
+ fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+
+lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
+lookupClosure hsc_env str =
+ iservCmd hsc_env (LookupClosure str)
+
+purgeLookupSymbolCache :: HscEnv -> IO ()
+purgeLookupSymbolCache hsc_env@HscEnv{..} =
+ when (gopt Opt_ExternalInterpreter hsc_dflags) $
+ withIServ hsc_env $ \IServ{..} ->
+ writeIORef iservLookupSymbolCache emptyUFM
+
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+-- Returns:
+--
+-- Nothing => success
+-- Just err_msg => failure
+loadDLL :: HscEnv -> String -> IO (Maybe String)
+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+
+loadArchive :: HscEnv -> String -> IO ()
+loadArchive hsc_env str = iservCmd hsc_env (LoadArchive str)
+
+loadObj :: HscEnv -> String -> IO ()
+loadObj hsc_env str = iservCmd hsc_env (LoadObj str)
+
+unloadObj :: HscEnv -> String -> IO ()
+unloadObj hsc_env str = iservCmd hsc_env (UnloadObj str)
+
+addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
+addLibrarySearchPath hsc_env str =
+ fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+
+removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
+removeLibrarySearchPath hsc_env p =
+ iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+
+resolveObjs :: HscEnv -> IO SuccessFlag
+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+
+findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+
+
+-- -----------------------------------------------------------------------------
+-- Raw calls and messages
+
+-- | Send a 'Message' and receive the response from the iserv process
+iservCall :: Binary a => IServ -> Message a -> IO a
+iservCall iserv@IServ{..} msg =
+ remoteCall iservPipe msg
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Read a value from the iserv process
+readIServ :: IServ -> Get a -> IO a
+readIServ iserv@IServ{..} get =
+ readPipe iservPipe get
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Send a value to the iserv process
+writeIServ :: IServ -> Put -> IO ()
+writeIServ iserv@IServ{..} put =
+ writePipe iservPipe put
+ `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+handleIServFailure :: IServ -> SomeException -> IO a
+handleIServFailure IServ{..} e = do
+ ex <- getProcessExitCode iservProcess
+ case ex of
+ Just (ExitFailure n) ->
+ throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
+ _ -> do
+ terminateProcess iservProcess
+ _ <- waitForProcess iservProcess
+ throw e
+
+-- -----------------------------------------------------------------------------
+-- Starting and stopping the iserv process
+
+startIServ :: DynFlags -> IO IServ
+#ifdef mingw32_HOST_OS
+startIServ _ = panic "startIServ"
+ -- should not be called, because we disable -fexternal-interpreter on Windows.
+ -- (see DynFlags.makeDynFlagsConsistent)
+#else
+startIServ dflags = do
+ let flavour
+ | WayProf `elem` ways dflags = "-prof"
+ | WayDyn `elem` ways dflags = "-dyn"
+ | otherwise = ""
+ prog = pgm_i dflags ++ flavour
+ opts = getOpts dflags opt_i
+ debugTraceMsg dflags 3 $ text "Starting " <> text prog
+ (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+ (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+ setFdOption rfd1 CloseOnExec True
+ setFdOption wfd2 CloseOnExec True
+ let args = show wfd1 : show rfd2 : opts
+ (_, _, _, ph) <- createProcess (proc prog args)
+ closeFd wfd1
+ closeFd rfd2
+ rh <- fdToHandle rfd1
+ wh <- fdToHandle wfd2
+ lo_ref <- newIORef Nothing
+ cache_ref <- newIORef emptyUFM
+ return $ IServ
+ { iservPipe = Pipe { pipeRead = rh
+ , pipeWrite = wh
+ , pipeLeftovers = lo_ref }
+ , iservProcess = ph
+ , iservLookupSymbolCache = cache_ref
+ , iservPendingFrees = []
+ }
+#endif
+
+stopIServ :: HscEnv -> IO ()
+#ifdef mingw32_HOST_OS
+stopIServ _ = return ()
+#else
+stopIServ HscEnv{..} =
+ gmask $ \_restore -> do
+ m <- takeMVar hsc_iserv
+ maybe (return ()) stop m
+ putMVar hsc_iserv Nothing
+ where
+ stop iserv = do
+ ex <- getProcessExitCode (iservProcess iserv)
+ if isJust ex
+ then return ()
+ else iservCall iserv Shutdown
+#endif
+
+-- -----------------------------------------------------------------------------
+{- Note [External GHCi pointers]
+
+We have the following ways to reference things in GHCi:
+
+HValue
+------
+
+HValue is a direct reference to an value in the local heap. Obviously
+we cannot use this to refer to things in the external process.
+
+
+HValueRef
+---------
+
+HValueRef is a StablePtr to a heap-resident value. When
+-fexternal-interpreter is used, this value resides in the external
+process's heap. HValueRefs are mostly used to send pointers in
+messages between GHC and iserv.
+
+An HValueRef must be explicitly freed when no longer required, using
+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
+
+To get from an HValueRef to an HValue you can use 'wormholeRef', which
+fails with an error message if -fexternal-interpreter is in use.
+
+ForeignHValue
+-------------
+
+A ForeignHValue is an HValueRef with a finalizer that will free the
+'HValueRef' when it is gargabe collected. We mostly use ForeignHValue
+on the GHC side.
+
+The finalizer adds the HValueRef to the iservPendingFrees list in the
+IServ record. The next call to iservCmd will free any HValueRefs in
+the list. It was done this way rather than calling iservCmd directly,
+because I didn't want to have arbitrary threads calling iservCmd. In
+principle it would probably be ok, but it seems less hairy this way.
+-}
+
+-- | Creates a 'ForeignHValue' that will automatically release the
+-- 'HValueRef' when it is no longer referenced.
+mkFinalizedHValue :: HscEnv -> HValueRef -> IO ForeignHValue
+mkFinalizedHValue HscEnv{..} hvref = mkForeignHValue hvref free
+ where
+ !external = gopt Opt_ExternalInterpreter hsc_dflags
+
+ free :: IO ()
+ free
+ | not external = freeHValueRef hvref
+ | otherwise =
+ modifyMVar_ hsc_iserv $ \mb_iserv ->
+ case mb_iserv of
+ Nothing -> return Nothing -- already shut down
+ Just iserv@IServ{..} ->
+ return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
+
+freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs _ [] = return ()
+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+
+-- | Convert a 'ForeignHValue' to an 'HValue' directly. This only works
+-- when the interpreter is running in the same process as the compiler,
+-- so it fails when @-fexternal-interpreter@ is on.
+wormhole :: DynFlags -> ForeignHValue -> IO HValue
+wormhole dflags r = wormholeRef dflags (unsafeForeignHValueToHValueRef r)
+
+-- | Convert an 'HValueRef' to an 'HValue' directly. This only works
+-- when the interpreter is running in the same process as the compiler,
+-- so it fails when @-fexternal-interpreter@ is on.
+wormholeRef :: DynFlags -> HValueRef -> IO HValue
+wormholeRef dflags r
+ | gopt Opt_ExternalInterpreter dflags
+ = throwIO (InstallationError
+ "this operation requires -fno-external-interpreter")
+ | otherwise
+ = localHValueRef r
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
+
+mkEvalOpts :: DynFlags -> Bool -> EvalOpts
+mkEvalOpts dflags step =
+ EvalOpts
+ { useSandboxThread = gopt Opt_GhciSandbox dflags
+ , singleStep = step
+ , breakOnException = gopt Opt_BreakOnException dflags
+ , breakOnError = gopt Opt_BreakOnError dflags }
+
+fromEvalResult :: EvalResult a -> IO a
+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
+fromEvalResult (EvalSuccess a) = return a
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 7c10fae331..11936c7c75 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
{-# OPTIONS_GHC -fno-cse #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -24,11 +24,12 @@ module Linker ( getHValue, showLinkerState,
#include "HsVersions.h"
+import GHCi
+import GHCi.RemoteTypes
import LoadIface
-import ObjLink
import ByteCodeLink
-import ByteCodeItbls
import ByteCodeAsm
+import ByteCodeTypes
import TcRnMonad
import Packages
import DriverPhases
@@ -63,7 +64,6 @@ import Data.Maybe
import Control.Concurrent.MVar
import System.FilePath
-import System.IO
import System.Directory
import Exception
@@ -147,35 +147,46 @@ extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
-extendLinkEnv :: [(Name,HValue)] -> IO ()
--- Automatically discards shadowed bindings
+extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
extendLinkEnv new_bindings =
- modifyPLS_ $ \pls ->
- let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
- in return pls{ closure_env = new_closure_env }
+ modifyPLS_ $ \pls -> do
+ let ce = closure_env pls
+ let new_ce = extendClosureEnv ce new_bindings
+ return pls{ closure_env = new_ce }
deleteFromLinkEnv :: [Name] -> IO ()
deleteFromLinkEnv to_remove =
- modifyPLS_ $ \pls ->
- let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
- in return pls{ closure_env = new_closure_env }
+ modifyPLS_ $ \pls -> do
+ let ce = closure_env pls
+ let new_ce = delListFromNameEnv ce to_remove
+ return pls{ closure_env = new_ce }
-- | Get the 'HValue' associated with the given name.
--
-- May cause loading the module that contains the name.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-getHValue :: HscEnv -> Name -> IO HValue
+getHValue :: HscEnv -> Name -> IO ForeignHValue
getHValue hsc_env name = do
- initDynLinker (hsc_dflags hsc_env)
+ initDynLinker hsc_env
pls <- modifyPLS $ \pls -> do
if (isExternalName name) then do
- (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
+ (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
+ [nameModule name]
if (failed ok) then throwGhcExceptionIO (ProgramError "")
else return (pls', pls')
else
return (pls, pls)
- lookupName (closure_env pls) name
+ case lookupNameEnv (closure_env pls) name of
+ Just (_,aa) -> return aa
+ Nothing
+ -> ASSERT2(isExternalName name, ppr name)
+ do let sym_to_find = nameToCLabel name "closure"
+ m <- lookupClosure hsc_env (unpackFS sym_to_find)
+ case m of
+ Just hvref -> mkFinalizedHValue hsc_env hvref
+ Nothing -> linkFail "ByteCodeLink.lookupCE"
+ (unpackFS sym_to_find)
linkDependencies :: HscEnv -> PersistentLinkerState
-> SrcSpan -> [Module]
@@ -195,14 +206,14 @@ linkDependencies hsc_env pls span needed_mods = do
maybe_normal_osuf span needed_mods
-- Link the packages and modules required
- pls1 <- linkPackages' dflags pkgs pls
- linkModules dflags pls1 lnks
+ pls1 <- linkPackages' hsc_env pkgs pls
+ linkModules hsc_env pls1 lnks
-- | Temporarily extend the linker state.
withExtendedLinkEnv :: (ExceptionMonad m) =>
- [(Name,HValue)] -> m a -> m a
+ [(Name,ForeignHValue)] -> m a -> m a
withExtendedLinkEnv new_env action
= gbracket (liftIO $ extendLinkEnv new_env)
(\_ -> reset_old_env)
@@ -219,19 +230,6 @@ withExtendedLinkEnv new_env action
new = delListFromNameEnv cur (map fst new_env)
in return pls{ closure_env = new }
--- filterNameMap removes from the environment all entries except
--- those for a given set of modules;
--- Note that this removes all *local* (i.e. non-isExternal) names too
--- (these are the temporary bindings from the command line).
--- Used to filter both the ClosureEnv and ItblEnv
-
-filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
-filterNameMap mods env
- = filterNameEnv keep_elt env
- where
- keep_elt (n,_) = isExternalName n
- && (nameModule n `elem` mods)
-
-- | Display the persistent linker state.
showLinkerState :: DynFlags -> IO ()
@@ -268,41 +266,45 @@ showLinkerState dflags
-- nothing. This is useful in Template Haskell, where we call it before
-- trying to link.
--
-initDynLinker :: DynFlags -> IO ()
-initDynLinker dflags =
+initDynLinker :: HscEnv -> IO ()
+initDynLinker hsc_env =
modifyPLS_ $ \pls0 -> do
done <- readIORef v_InitLinkerDone
if done then return pls0
else do writeIORef v_InitLinkerDone True
- reallyInitDynLinker dflags
+ reallyInitDynLinker hsc_env
-reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
-reallyInitDynLinker dflags =
- do { -- Initialise the linker state
- let pls0 = emptyPLS dflags
+reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
+reallyInitDynLinker hsc_env = do
+ -- Initialise the linker state
+ let dflags = hsc_dflags hsc_env
+ pls0 = emptyPLS dflags
- -- (a) initialise the C dynamic linker
- ; initObjLinker
+ -- (a) initialise the C dynamic linker
+ initObjLinker hsc_env
- -- (b) Load packages from the command-line (Note [preload packages])
- ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
+ -- (b) Load packages from the command-line (Note [preload packages])
+ pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
- -- steps (c), (d) and (e)
- ; linkCmdLineLibs' dflags pls
- }
+ -- steps (c), (d) and (e)
+ linkCmdLineLibs' hsc_env pls
-linkCmdLineLibs :: DynFlags -> IO ()
-linkCmdLineLibs dflags = do
- initDynLinker dflags
+
+linkCmdLineLibs :: HscEnv -> IO ()
+linkCmdLineLibs hsc_env = do
+ initDynLinker hsc_env
modifyPLS_ $ \pls -> do
- linkCmdLineLibs' dflags pls
+ linkCmdLineLibs' hsc_env pls
+
+linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
+linkCmdLineLibs' hsc_env pls =
+ do
+ let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
+ , libraryPaths = lib_paths}) = hsc_dflags hsc_env
-linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState
-linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs
- , libraryPaths = lib_paths}) pls =
- do -- (c) Link libraries from the command-line
+ -- (c) Link libraries from the command-line
let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
- libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
+ libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
-- (d) Link .o files from the command-line
classified_ld_inputs <- mapM (classifyLdInput dflags)
@@ -327,15 +329,15 @@ linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs
++ lib_paths
++ [ takeDirectory dll | DLLPath dll <- libspecs ]
in nub $ map normalise paths
- pathCache <- mapM addLibrarySearchPath all_paths
+ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
- pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls
+ pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
cmdline_lib_specs
maybePutStr dflags "final link ... "
- ok <- resolveObjs
+ ok <- resolveObjs hsc_env
-- DLLs are loaded, reset the search paths
- mapM_ removeLibrarySearchPath $ reverse pathCache
+ mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
if succeeded ok then maybePutStrLn dflags "done"
else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
@@ -377,56 +379,58 @@ classifyLdInput dflags f
return Nothing
where platform = targetPlatform dflags
-preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState
- -> LibrarySpec -> IO PersistentLinkerState
-preloadLib dflags lib_paths framework_paths pls lib_spec
- = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
- case lib_spec of
- Object static_ish
- -> do (b, pls1) <- preload_static lib_paths static_ish
- maybePutStrLn dflags (if b then "done"
- else "not found")
- return pls1
-
- Archive static_ish
- -> do b <- preload_static_archive lib_paths static_ish
- maybePutStrLn dflags (if b then "done"
- else "not found")
- return pls
-
- DLL dll_unadorned
- -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
- case maybe_errstr of
- Nothing -> maybePutStrLn dflags "done"
- Just mm | platformOS platform /= OSDarwin ->
- preloadFailed mm lib_paths lib_spec
- Just mm | otherwise -> do
- -- As a backup, on Darwin, try to also load a .so file
- -- since (apparently) some things install that way - see
- -- ticket #8770.
- err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so"
- case err2 of
- Nothing -> maybePutStrLn dflags "done"
- Just _ -> preloadFailed mm lib_paths lib_spec
- return pls
-
- DLLPath dll_path
- -> do maybe_errstr <- loadDLL dll_path
- case maybe_errstr of
- Nothing -> maybePutStrLn dflags "done"
- Just mm -> preloadFailed mm lib_paths lib_spec
- return pls
-
- Framework framework ->
- if platformUsesFrameworks (targetPlatform dflags)
- then do maybe_errstr <- loadFramework framework_paths framework
- case maybe_errstr of
- Nothing -> maybePutStrLn dflags "done"
- Just mm -> preloadFailed mm framework_paths lib_spec
- return pls
- else panic "preloadLib Framework"
+preloadLib
+ :: HscEnv -> [String] -> [String] -> PersistentLinkerState
+ -> LibrarySpec -> IO PersistentLinkerState
+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
+ maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+ case lib_spec of
+ Object static_ish -> do
+ (b, pls1) <- preload_static lib_paths static_ish
+ maybePutStrLn dflags (if b then "done" else "not found")
+ return pls1
+
+ Archive static_ish -> do
+ b <- preload_static_archive lib_paths static_ish
+ maybePutStrLn dflags (if b then "done" else "not found")
+ return pls
+
+ DLL dll_unadorned -> do
+ maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm | platformOS platform /= OSDarwin ->
+ preloadFailed mm lib_paths lib_spec
+ Just mm | otherwise -> do
+ -- As a backup, on Darwin, try to also load a .so file
+ -- since (apparently) some things install that way - see
+ -- ticket #8770.
+ let libfile = ("lib" ++ dll_unadorned) <.> "so"
+ err2 <- loadDLL hsc_env libfile
+ case err2 of
+ Nothing -> maybePutStrLn dflags "done"
+ Just _ -> preloadFailed mm lib_paths lib_spec
+ return pls
+
+ DLLPath dll_path -> do
+ do maybe_errstr <- loadDLL hsc_env dll_path
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm -> preloadFailed mm lib_paths lib_spec
+ return pls
+
+ Framework framework ->
+ if platformUsesFrameworks (targetPlatform dflags)
+ then do maybe_errstr <- loadFramework hsc_env framework_paths framework
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm -> preloadFailed mm framework_paths lib_spec
+ return pls
+ else panic "preloadLib Framework"
where
+ dflags = hsc_dflags hsc_env
+
platform = targetPlatform dflags
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
@@ -445,9 +449,9 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
= do b <- doesFileExist name
if not b then return (False, pls)
else if dynamicGhc
- then do pls1 <- dynLoadObjs dflags pls [name]
+ then do pls1 <- dynLoadObjs hsc_env pls [name]
return (True, pls1)
- else do loadObj name
+ else do loadObj hsc_env name
return (True, pls)
preload_static_archive _paths name
@@ -455,7 +459,7 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
if not b then return False
else do if dynamicGhc
then panic "Loading archives not supported"
- else loadArchive name
+ else loadArchive hsc_env name
return True
@@ -471,12 +475,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
-- Raises an IO exception ('ProgramError') if it can't find a compiled
-- version of the dependents to link.
--
-linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
linkExpr hsc_env span root_ul_bco
= do {
-- Initialise the linker (if it's not been done already)
- let dflags = hsc_dflags hsc_env
- ; initDynLinker dflags
+ ; initDynLinker hsc_env
-- Take lock for the actual work.
; modifyPLS $ \pls0 -> do {
@@ -492,8 +495,10 @@ linkExpr hsc_env span root_ul_bco
ce = closure_env pls
-- Link the necessary packages and linkables
- ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
- ; return (pls, root_hval)
+
+ ; [(_,root_hvref)] <- linkSomeBCOs hsc_env ie ce [root_ul_bco]
+ ; fhv <- mkFinalizedHValue hsc_env root_hvref
+ ; return (pls, fhv)
}}}
where
free_names = nameSetElems (bcoFreeNames root_ul_bco)
@@ -514,6 +519,11 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay dflags srcspan
+ | gopt Opt_ExternalInterpreter dflags = return Nothing
+ -- with -fexternal-interpreter we load the .o files, whatever way
+ -- they were built. If they were built for a non-std way, then
+ -- we will use the appropriate variant of the iserv binary to load them.
+
| interpWays == haskellWays = return Nothing
-- Only if we are compiling with the same ways as GHC is built
-- with, can we dynamically load those object files. (see #3604)
@@ -533,11 +543,19 @@ normalObjectSuffix = phaseInputExt StopLn
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
failNonStd dflags srcspan = dieWith dflags srcspan $
- ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
- ptext (sLit "You need to build the program twice: once") <+>
- ghciWay <> ptext (sLit ", and then") $$
- ptext (sLit "in the desired way using -osuf to set the object file suffix.")
- where ghciWay
+ ptext (sLit "Cannot load") <+> compWay <+>
+ ptext (sLit "objects when GHC is built") <+> ghciWay $$
+ ptext (sLit "To fix this, either:") $$
+ ptext (sLit " (1) Use -fexternal-interprter, or") $$
+ ptext (sLit " (2) Build the program twice: once") <+>
+ ghciWay <> ptext (sLit ", and then") $$
+ ptext (sLit " with") <+> compWay <+>
+ ptext (sLit "using -osuf to set a different object file suffix.")
+ where compWay
+ | WayDyn `elem` ways dflags = ptext (sLit "-dynamic")
+ | WayProf `elem` ways dflags = ptext (sLit "-prof")
+ | otherwise = ptext (sLit "normal")
+ ghciWay
| dynamicGhc = ptext (sLit "with -dynamic")
| rtsIsProfiled = ptext (sLit "with -prof")
| otherwise = ptext (sLit "the normal way")
@@ -684,11 +702,10 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
********************************************************************* -}
-linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
-linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
+linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
+linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do
-- Initialise the linker (if it's not been done already)
- let dflags = hsc_dflags hsc_env
- initDynLinker dflags
+ initDynLinker hsc_env
-- Take lock for the actual work.
modifyPLS $ \pls0 -> do
@@ -704,10 +721,11 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
ce = closure_env pls
-- Link the necessary packages and linkables
- (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
- let pls2 = pls { closure_env = final_gce,
- itbl_env = ie }
- return (pls2, ()) --hvals)
+ new_bindings <- linkSomeBCOs hsc_env ie ce unlinkedBCOs
+ nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
+ let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
+ , itbl_env = ie }
+ return (pls2, ())
where
free_names = concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs
@@ -721,8 +739,6 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-
-
{- **********************************************************************
Loading a single module
@@ -731,7 +747,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
- initDynLinker (hsc_dflags hsc_env)
+ initDynLinker hsc_env
modifyPLS_ $ \pls -> do
(pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
@@ -745,21 +761,21 @@ linkModule hsc_env mod = do
********************************************************************* -}
-linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
+linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
-linkModules dflags pls linkables
+linkModules hsc_env pls linkables
= mask_ $ do -- don't want to be interrupted by ^C in here
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
-- Load objects first; they can't depend on BCOs
- (pls1, ok_flag) <- dynLinkObjs dflags pls objs
+ (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs dflags pls1 bcos
+ pls2 <- dynLinkBCOs hsc_env pls1 bcos
return (pls2, Succeeded)
@@ -795,36 +811,37 @@ linkableInSet l objs_loaded =
********************************************************************* -}
-dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
+dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag)
-dynLinkObjs dflags pls objs = do
+dynLinkObjs hsc_env pls objs = do
-- Load the object files and link them
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
wanted_objs = map nameOfObject unlinkeds
- if dynamicGhc
- then do pls2 <- dynLoadObjs dflags pls1 wanted_objs
+ if loadingDynamicHSLibs (hsc_dflags hsc_env)
+ then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
return (pls2, Succeeded)
- else do mapM_ loadObj wanted_objs
+ else do mapM_ (loadObj hsc_env) wanted_objs
-- Link them all together
- ok <- resolveObjs
+ ok <- resolveObjs hsc_env
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then do
return (pls1, Succeeded)
else do
- pls2 <- unload_wkr dflags [] pls1
+ pls2 <- unload_wkr hsc_env [] pls1
return (pls2, Failed)
-dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath]
+dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
-> IO PersistentLinkerState
-dynLoadObjs _ pls [] = return pls
-dynLoadObjs dflags pls objs = do
+dynLoadObjs _ pls [] = return pls
+dynLoadObjs hsc_env pls objs = do
+ let dflags = hsc_dflags hsc_env
let platform = targetPlatform dflags
(soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
let
@@ -860,7 +877,7 @@ dynLoadObjs dflags pls objs = do
-- symbols in this link we must link all loaded packages again.
linkDynLib dflags2 objs (pkgs_loaded pls)
consIORef (filesToNotIntermediateClean dflags) soFile
- m <- loadDLL soFile
+ m <- loadDLL hsc_env soFile
case m of
Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
Just err -> panic ("Loading temp shared object failed: " ++ err)
@@ -884,9 +901,9 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
+dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
-> IO PersistentLinkerState
-dynLinkBCOs dflags pls bcos = do
+dynLinkBCOs hsc_env pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -897,46 +914,49 @@ dynLinkBCOs dflags pls bcos = do
cbcs = map byteCodeOfObject unlinkeds
- ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
- ies = [ie | ByteCode _ ie <- cbcs]
+ ul_bcos = [b | ByteCode bs _ _ <- cbcs, b <- bs]
+ ies = [ie | ByteCode _ ie _ <- cbcs]
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
- -- XXX What happens to these linked_bcos?
+ names_and_refs <- linkSomeBCOs hsc_env final_ie gce ul_bcos
- let pls2 = pls1 { closure_env = final_gce,
+ -- We only want to add the external ones to the ClosureEnv
+ let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
+
+ -- Immediately release any HValueRefs we're not going to add
+ freeHValueRefs hsc_env (map snd to_drop)
+ -- Wrap finalizers on the ones we want to keep
+ new_binds <- makeForeignNamedHValueRefs hsc_env to_add
+
+ let pls2 = pls1 { closure_env = extendClosureEnv gce new_binds,
itbl_env = final_ie }
return pls2
--- Link a bunch of BCOs and return them + updated closure env.
-linkSomeBCOs :: DynFlags
- -> Bool -- False <=> add _all_ BCOs to returned closure env
- -- True <=> add only toplevel BCOs to closure env
+-- Link a bunch of BCOs and return references to their values
+linkSomeBCOs :: HscEnv
-> ItblEnv
-> ClosureEnv
-> [UnlinkedBCO]
- -> IO (ClosureEnv, [HValue])
- -- The returned HValues are associated 1-1 with
+ -> IO [(Name,HValueRef)]
+ -- The returned HValueRefs are associated 1-1 with
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
- = do let nms = map unlinkedBCOName ul_bcos
- hvals <- fixIO
- ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
- in mapM (linkBCO dflags ie ce_out) ul_bcos )
- let ce_all_additions = zip nms hvals
- ce_top_additions = filter (isExternalName.fst) ce_all_additions
- ce_additions = if toplevs_only then ce_top_additions
- else ce_all_additions
- ce_out = -- make sure we're not inserting duplicate names into the
- -- closure environment, which leads to trouble.
- ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
- extendClosureEnv ce_in ce_additions
- return (ce_out, hvals)
+linkSomeBCOs _ _ _ [] = return []
+linkSomeBCOs hsc_env ie ce ul_bcos = do
+ let names = map unlinkedBCOName ul_bcos
+ bco_ix = mkNameEnv (zip names [0..])
+ resolved <- mapM (linkBCO hsc_env ie ce bco_ix) ul_bcos
+ hvrefs <- iservCmd hsc_env (CreateBCOs resolved)
+ return (zip names hvrefs)
+-- | Useful to apply to the result of 'linkSomeBCOs'
+makeForeignNamedHValueRefs
+ :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
+makeForeignNamedHValueRefs hsc_env bindings =
+ mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings
{- **********************************************************************
@@ -958,62 +978,85 @@ linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
--
-- * we also implicitly unload all temporary bindings at this point.
--
-unload :: DynFlags
+unload :: HscEnv
-> [Linkable] -- ^ The linkables to *keep*.
-> IO ()
-unload dflags linkables
+unload hsc_env linkables
= mask_ $ do -- mask, so we're safe from Ctrl-C in here
-- Initialise the linker (if it's not been done already)
- initDynLinker dflags
+ initDynLinker hsc_env
new_pls
<- modifyPLS $ \pls -> do
- pls1 <- unload_wkr dflags linkables pls
+ pls1 <- unload_wkr hsc_env linkables pls
return (pls1, pls1)
- debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
- debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
+ let dflags = hsc_dflags hsc_env
+ debugTraceMsg dflags 3 $
+ text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
+ debugTraceMsg dflags 3 $
+ text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
return ()
-unload_wkr :: DynFlags
+unload_wkr :: HscEnv
-> [Linkable] -- stable linkables
-> PersistentLinkerState
-> IO PersistentLinkerState
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
-unload_wkr _ linkables pls
- = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
+unload_wkr hsc_env keep_linkables pls = do
+ let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
+
+ discard keep l = not (linkableInSet l keep)
+
+ (objs_to_unload, remaining_objs_loaded) =
+ partition (discard objs_to_keep) (objs_loaded pls)
+ (bcos_to_unload, remaining_bcos_loaded) =
+ partition (discard bcos_to_keep) (bcos_loaded pls)
+
+ mapM_ unloadObjs objs_to_unload
+ mapM_ unloadObjs bcos_to_unload
+
+ -- If we unloaded any object files at all, we need to purge the cache
+ -- of lookupSymbol results.
+ when (not (null (objs_to_unload ++
+ filter (not . null . linkableObjs) bcos_to_unload))) $
+ purgeLookupSymbolCache hsc_env
+
+ let bcos_retained = map linkableModule remaining_bcos_loaded
+
+ -- Note that we want to remove all *local*
+ -- (i.e. non-isExternal) names too (these are the
+ -- temporary bindings from the command line).
+ keep_name (n,_) = isExternalName n &&
+ nameModule n `elem` bcos_retained
- objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
- bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
+ itbl_env' = filterNameEnv keep_name (itbl_env pls)
+ closure_env' = filterNameEnv keep_name (closure_env pls)
- let bcos_retained = map linkableModule bcos_loaded'
- itbl_env' = filterNameMap bcos_retained (itbl_env pls)
- closure_env' = filterNameMap bcos_retained (closure_env pls)
- new_pls = pls { itbl_env = itbl_env',
- closure_env = closure_env',
- bcos_loaded = bcos_loaded',
- objs_loaded = objs_loaded' }
+ new_pls = pls { itbl_env = itbl_env',
+ closure_env = closure_env',
+ bcos_loaded = remaining_bcos_loaded,
+ objs_loaded = remaining_objs_loaded }
- return new_pls
+ return new_pls
where
- maybeUnload :: [Linkable] -> Linkable -> IO Bool
- maybeUnload keep_linkables lnk
- | linkableInSet lnk keep_linkables = return True
- -- We don't do any cleanup when linking objects with the dynamic linker.
- -- Doing so introduces extra complexity for not much benefit.
- | dynamicGhc = return False
+ unloadObjs :: Linkable -> IO ()
+ unloadObjs lnk
+ | dynamicGhc = return ()
+ -- We don't do any cleanup when linking objects with the
+ -- dynamic linker. Doing so introduces extra complexity for
+ -- not much benefit.
| otherwise
- = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
+ = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
-- The components of a BCO linkable may contain
-- dot-o files. Which is very confusing.
--
-- But the BCO parts can be unlinked just by
-- letting go of them (plus of course depopulating
-- the symbol table which is done in the main body)
- return False
{- **********************************************************************
@@ -1067,7 +1110,7 @@ showLS (Framework nm) = "(framework) " ++ nm
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-linkPackages :: DynFlags -> [UnitId] -> IO ()
+linkPackages :: HscEnv -> [UnitId] -> IO ()
-- NOTE: in fact, since each module tracks all the packages it depends on,
-- we don't really need to use the package-config dependencies.
--
@@ -1076,19 +1119,21 @@ linkPackages :: DynFlags -> [UnitId] -> IO ()
-- perhaps makes the error message a bit more localised if we get a link
-- failure. So the dependency walking code is still here.
-linkPackages dflags new_pkgs = do
+linkPackages hsc_env new_pkgs = do
-- It's probably not safe to try to load packages concurrently, so we take
-- a lock.
- initDynLinker dflags
+ initDynLinker hsc_env
modifyPLS_ $ \pls -> do
- linkPackages' dflags new_pkgs pls
+ linkPackages' hsc_env new_pkgs pls
-linkPackages' :: DynFlags -> [UnitId] -> PersistentLinkerState
+linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState
-> IO PersistentLinkerState
-linkPackages' dflags new_pks pls = do
+linkPackages' hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
+ dflags = hsc_dflags hsc_env
+
link :: [UnitId] -> [UnitId] -> IO [UnitId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
@@ -1101,18 +1146,19 @@ linkPackages' dflags new_pks pls = do
= do { -- Link dependents first
pkgs' <- link pkgs (depends pkg_cfg)
-- Now link the package itself
- ; linkPackage dflags pkg_cfg
+ ; linkPackage hsc_env pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg))
-linkPackage :: DynFlags -> PackageConfig -> IO ()
-linkPackage dflags pkg
+linkPackage :: HscEnv -> PackageConfig -> IO ()
+linkPackage hsc_env pkg
= do
- let platform = targetPlatform dflags
- dirs = Packages.libraryDirs pkg
+ let dflags = hsc_dflags hsc_env
+ platform = targetPlatform dflags
+ dirs = Packages.libraryDirs pkg
let hs_libs = Packages.hsLibraries pkg
-- The FFI GHCi import lib isn't needed as
@@ -1135,8 +1181,8 @@ linkPackage dflags pkg
else Packages.extraGHCiLibraries pkg)
++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
- hs_classifieds <- mapM (locateLib dflags True dirs) hs_libs'
- extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs
+ hs_classifieds <- mapM (locateLib hsc_env True dirs) hs_libs'
+ extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs
let classifieds = hs_classifieds ++ extra_classifieds
-- Complication: all the .so's must be loaded before any of the .o's.
@@ -1148,27 +1194,28 @@ linkPackage dflags pkg
-- Add directories to library search paths
let dll_paths = map takeDirectory known_dlls
all_paths = nub $ map normalise $ dll_paths ++ dirs
- pathCache <- mapM addLibrarySearchPath all_paths
+ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
maybePutStr dflags
("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
-- See comments with partOfGHCi
when (packageName pkg `notElem` partOfGHCi) $ do
- loadFrameworks platform pkg
- mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls)
+ loadFrameworks hsc_env platform pkg
+ mapM_ (load_dyn hsc_env)
+ (known_dlls ++ map (mkSOName platform) dlls)
-- DLLs are loaded, reset the search paths
- mapM_ removeLibrarySearchPath $ reverse pathCache
+ mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
-- After loading all the DLLs, we can load the static objects.
-- Ordering isn't important here, because we do one final link
-- step to resolve everything.
- mapM_ loadObj objs
- mapM_ loadArchive archs
+ mapM_ (loadObj hsc_env) objs
+ mapM_ (loadArchive hsc_env) archs
maybePutStr dflags "linking ... "
- ok <- resolveObjs
+ ok <- resolveObjs hsc_env
if succeeded ok
then maybePutStrLn dflags "done."
else let errmsg = "unable to load package `"
@@ -1180,33 +1227,44 @@ linkPackage dflags pkg
-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case,
-- loadDLL is going to search the system paths to find the library.
--
-load_dyn :: FilePath -> IO ()
-load_dyn dll = do r <- loadDLL dll
- case r of
- Nothing -> return ()
- Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
- ++ dll ++ " (" ++ err ++ ")" ))
-
-loadFrameworks :: Platform -> PackageConfig -> IO ()
-loadFrameworks platform pkg
+load_dyn :: HscEnv -> FilePath -> IO ()
+load_dyn hsc_env dll = do
+ r <- loadDLL hsc_env dll
+ case r of
+ Nothing -> return ()
+ Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
+ ++ dll ++ " (" ++ err ++ ")" ))
+
+loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
+loadFrameworks hsc_env platform pkg
= when (platformUsesFrameworks platform) $ mapM_ load frameworks
where
fw_dirs = Packages.frameworkDirs pkg
frameworks = Packages.frameworks pkg
- load fw = do r <- loadFramework fw_dirs fw
+ load fw = do r <- loadFramework hsc_env fw_dirs fw
case r of
Nothing -> return ()
Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
+loadingDynamicHSLibs :: DynFlags -> Bool
+loadingDynamicHSLibs dflags
+ | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
+ | otherwise = dynamicGhc
+
+loadingProfiledHSLibs :: DynFlags -> Bool
+loadingProfiledHSLibs dflags
+ | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+ | otherwise = rtsIsProfiled
+
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume that addDLL in the RTS can find it,
-- which generally means that it should be a dynamic library in the
-- standard system search path.
-locateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec
-locateLib dflags is_hs dirs lib
+locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec
+locateLib hsc_env is_hs dirs lib
| not is_hs
-- For non-Haskell libraries (e.g. gmp, iconv):
-- first look in library-dirs for a dynamic library (libfoo.so)
@@ -1224,15 +1282,12 @@ locateLib dflags is_hs dirs lib
findArchive `orElse`
assumeDll
- | dynamicGhc
- -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
- -- we search for .so libraries first.
+ | loading_dynamic_hs_libs -- search for .so libraries first.
= findHSDll `orElse`
findDynObject `orElse`
assumeDll
- | rtsIsProfiled
- -- When the GHC package is profiled, only a libHSfoo_p.a archive will do.
+ | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do.
= findArchive `orElse`
assumeDll
@@ -1244,10 +1299,15 @@ locateLib dflags is_hs dirs lib
assumeDll
where
+ dflags = hsc_dflags hsc_env
+
obj_file = lib <.> "o"
dyn_obj_file = lib <.> "dyn_o"
arch_file = "lib" ++ lib ++ lib_tag <.> "a"
- lib_tag = if is_hs && rtsIsProfiled then "_p" else ""
+ lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
+
+ loading_profiled_hs_libs = loadingProfiledHSLibs dflags
+ loading_dynamic_hs_libs = loadingDynamicHSLibs dflags
hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
@@ -1265,7 +1325,7 @@ locateLib dflags is_hs dirs lib
in liftM2 (<|>) local linked
findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
- findSysDll = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary so_name
+ findSysDll = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary hsc_env so_name
tryGcc = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
full = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
in liftM2 (<|>) short full
@@ -1297,8 +1357,8 @@ searchForLibUsingGcc dflags so dirs = do
-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
-- name. They are searched for in different paths than normal libraries.
-loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
-loadFramework extraPaths rootname
+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework hsc_env extraPaths rootname
= do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
@@ -1306,7 +1366,7 @@ loadFramework extraPaths rootname
ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
; mb_fwk <- findFile ps fwk_file
; case mb_fwk of
- Just fwk_path -> loadDLL fwk_path
+ Just fwk_path -> loadDLL hsc_env fwk_path
Nothing -> return (Just "not found") }
-- Tried all our known library paths, but dlopen()
-- has no built-in paths for frameworks: give up
diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs
deleted file mode 100644
index b1cfe61da9..0000000000
--- a/compiler/ghci/ObjLink.hs
+++ /dev/null
@@ -1,142 +0,0 @@
---
--- (c) The University of Glasgow 2002-2006
---
-
--- ---------------------------------------------------------------------------
--- The dynamic linker for object code (.o .so .dll files)
--- ---------------------------------------------------------------------------
-
--- | Primarily, this module consists of an interface to the C-land
--- dynamic linker.
-module ObjLink (
- initObjLinker, -- :: IO ()
- loadDLL, -- :: String -> IO (Maybe String)
- loadArchive, -- :: String -> IO ()
- loadObj, -- :: String -> IO ()
- unloadObj, -- :: String -> IO ()
- insertSymbol, -- :: String -> String -> Ptr a -> IO ()
- lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
- resolveObjs, -- :: IO SuccessFlag
- addLibrarySearchPath, -- :: FilePath -> IO (Ptr ())
- removeLibrarySearchPath, -- :: Ptr () -> IO Bool
- findSystemLibrary -- :: FilePath -> IO (Maybe FilePath)
- ) where
-
-import Panic
-import BasicTypes ( SuccessFlag, successIf )
-import Config ( cLeadingUnderscore )
-import Util
-
-import Control.Monad ( when )
-import Foreign.C
-import Foreign.Marshal.Alloc ( free )
-import Foreign ( nullPtr )
-import GHC.Exts ( Ptr(..) )
-import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
-import System.FilePath ( dropExtension, normalise )
-
-
--- ---------------------------------------------------------------------------
--- RTS Linker Interface
--- ---------------------------------------------------------------------------
-
-insertSymbol :: String -> String -> Ptr a -> IO ()
-insertSymbol obj_name key symbol
- = let str = prefixUnderscore key
- in withFilePath obj_name $ \c_obj_name ->
- withCAString str $ \c_str ->
- c_insertSymbol c_obj_name c_str symbol
-
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol str_in = do
- let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
- addr <- c_lookupSymbol c_str
- if addr == nullPtr
- then return Nothing
- else return (Just addr)
-
-prefixUnderscore :: String -> String
-prefixUnderscore
- | cLeadingUnderscore == "YES" = ('_':)
- | otherwise = id
-
--- | loadDLL loads a dynamic library using the OS's native linker
--- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
--- an absolute pathname to the file, or a relative filename
--- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
--- searches the standard locations for the appropriate library.
---
-loadDLL :: String -> IO (Maybe String)
--- Nothing => success
--- Just err_msg => failure
-loadDLL str0 = do
- let
- -- On Windows, addDLL takes a filename without an extension, because
- -- it tries adding both .dll and .drv. To keep things uniform in the
- -- layers above, loadDLL always takes a filename with an extension, and
- -- we drop it here on Windows only.
- str | isWindowsHost = dropExtension str0
- | otherwise = str0
- --
- maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll
- if maybe_errmsg == nullPtr
- then return Nothing
- else do str <- peekCString maybe_errmsg
- free maybe_errmsg
- return (Just str)
-
-loadArchive :: String -> IO ()
-loadArchive str = do
- withFilePath str $ \c_str -> do
- r <- c_loadArchive c_str
- when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
-
-loadObj :: String -> IO ()
-loadObj str = do
- withFilePath str $ \c_str -> do
- r <- c_loadObj c_str
- when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
-
-unloadObj :: String -> IO ()
-unloadObj str =
- withFilePath str $ \c_str -> do
- r <- c_unloadObj c_str
- when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
-
-addLibrarySearchPath :: String -> IO (Ptr ())
-addLibrarySearchPath str =
- withFilePath str c_addLibrarySearchPath
-
-removeLibrarySearchPath :: Ptr () -> IO Bool
-removeLibrarySearchPath = c_removeLibrarySearchPath
-
-findSystemLibrary :: String -> IO (Maybe String)
-findSystemLibrary str = do
- result <- withFilePath str c_findSystemLibrary
- case result == nullPtr of
- True -> return Nothing
- False -> do path <- peekFilePath result
- free result
- return $ Just path
-
-resolveObjs :: IO SuccessFlag
-resolveObjs = do
- r <- c_resolveObjs
- return (successIf (r /= 0))
-
--- ---------------------------------------------------------------------------
--- Foreign declarations to RTS entry points which does the real work;
--- ---------------------------------------------------------------------------
-
-foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString
-foreign import ccall unsafe "initLinker" initObjLinker :: IO ()
-foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO ()
-foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
-foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int
-foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int
-foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int
-foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
-foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ())
-foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr () -> IO Bool
-foreign import ccall unsafe "findSystemLibrary" c_findSystemLibrary :: CFilePath -> IO CFilePath
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 015126fae9..f71c904454 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -27,9 +27,9 @@ module RtClosureInspect(
#include "HsVersions.h"
import DebuggerUtils
-import ByteCodeItbls ( StgInfoTable, peekItbl )
-import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
-import BasicTypes ( HValue )
+import GHCi.RemoteTypes ( HValue )
+import qualified GHCi.InfoTable as InfoTable
+import GHCi.InfoTable (StgInfoTable, peekItbl)
import HscTypes
import DataCon
@@ -185,12 +185,12 @@ getClosureData dflags a =
-- into account the extra entry pointer when
-- !ghciTablesNextToCode, so we must adjust here:
iptr0 `plusPtr` negate (wORD_SIZE dflags)
- itbl <- peekItbl dflags iptr1
- let tipe = readCType (BCI.tipe itbl)
- elems = fromIntegral (BCI.ptrs itbl)
+ itbl <- peekItbl iptr1
+ let tipe = readCType (InfoTable.tipe itbl)
+ elems = fromIntegral (InfoTable.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
nptrs_data = [W# (indexWordArray# nptrs i)
- | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
+ | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
ASSERT(elems >= 0) return ()
ptrsList `seq`
return (Closure tipe iptr0 itbl ptrsList nptrs_data)
View Lorry Controller Status