summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs13
-rw-r--r--compiler/GHC/ByteCode/Asm.hs36
-rw-r--r--compiler/GHC/ByteCode/InfoTable.hs25
-rw-r--r--compiler/GHC/ByteCode/Linker.hs125
-rw-r--r--compiler/GHC/Driver/Env/Types.hs4
-rw-r--r--compiler/GHC/Driver/Main.hs17
-rw-r--r--compiler/GHC/Driver/Make.hs13
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs7
-rw-r--r--compiler/GHC/Linker/Loader.hs454
-rw-r--r--compiler/GHC/Linker/MacOS.hs9
-rw-r--r--compiler/GHC/Runtime/Debugger.hs10
-rw-r--r--compiler/GHC/Runtime/Eval.hs73
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs14
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs301
-rw-r--r--compiler/GHC/Runtime/Interpreter/Types.hs15
-rw-r--r--compiler/GHC/Runtime/Loader.hs26
-rw-r--r--compiler/GHC/StgToByteCode.hs22
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs21
-rw-r--r--ghc/GHCi/UI.hs28
-rw-r--r--ghc/GHCi/UI/Monad.hs12
-rw-r--r--testsuite/tests/rts/linker/LinkerUnload.hs3
21 files changed, 649 insertions, 579 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 9d2d6fb65f..7a237b2146 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -319,11 +319,11 @@ import GHC.Driver.Monad
import GHC.Driver.Ppr
import GHC.ByteCode.Types
+import qualified GHC.Linker.Loader as Loader
import GHC.Runtime.Loader
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Context
import GHCi.RemoteTypes
@@ -535,7 +535,7 @@ withCleanupSession ghc = ghc `MC.finally` cleanup
liftIO $ do
cleanTempFiles logger tmpfs dflags
cleanTempDirs logger tmpfs dflags
- stopInterp hsc_env -- shut down the IServ
+ traverse_ stopInterp (hsc_interp hsc_env)
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
@@ -642,7 +642,7 @@ setSessionDynFlags dflags0 = do
(dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env)
-- Interpreter
- interp <- if gopt Opt_ExternalInterpreter dflags
+ interp <- if gopt Opt_ExternalInterpreter dflags
then do
let
prog = pgm_i dflags ++ flavour
@@ -666,10 +666,13 @@ setSessionDynFlags dflags0 = do
, iservConfTrace = tr
}
s <- liftIO $ newMVar IServPending
- return (Just (ExternalInterp conf (IServ s)))
+ loader <- liftIO Loader.uninitializedLoader
+ return (Just (Interp (ExternalInterp conf (IServ s)) loader))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
- return (Just InternalInterp)
+ do
+ loader <- liftIO Loader.uninitializedLoader
+ return (Just (Interp InternalInterp loader))
#else
return Nothing
#endif
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index c58328f57c..30f2c2b633 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -19,9 +19,6 @@ module GHC.ByteCode.Asm (
import GHC.Prelude
-import GHC.Driver.Env
-import GHC.Driver.Session
-
import GHC.ByteCode.Instr
import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
@@ -45,6 +42,7 @@ import GHC.Data.SizedSeq
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Platform
+import GHC.Platform.Profile
import Control.Monad
import Control.Monad.ST ( runST )
@@ -96,13 +94,19 @@ bcoFreeNames bco
-- Top level assembler fn.
assembleBCOs
- :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
+ :: Interp
+ -> Profile
+ -> [ProtoBCO Name]
+ -> [TyCon]
+ -> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
-assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
- itblenv <- mkITbls hsc_env tycons
- bcos <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos
- (bcos',ptrs) <- mallocStrings hsc_env bcos
+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
+ -- TODO: the profile should be bundled with the interpreter: the rts ways are
+ -- fixed for an interpreter
+ itblenv <- mkITbls interp profile tycons
+ bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
+ (bcos',ptrs) <- mallocStrings interp bcos
return CompiledByteCode
{ bc_bcos = bcos'
, bc_itbls = itblenv
@@ -118,10 +122,10 @@ assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
-- b) For -fexternal-interpreter It's more efficient to malloc the strings
-- as a single batch message, especially when compiling in parallel.
--
-mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
-mallocStrings hsc_env ulbcos = do
+mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
+mallocStrings interp ulbcos = do
let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
- ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
+ ptrs <- interpCmd interp (MallocStrings bytestrings)
return (evalState (mapM splice ulbcos) ptrs, ptrs)
where
splice bco@UnlinkedBCO{..} = do
@@ -154,10 +158,12 @@ mallocStrings hsc_env ulbcos = do
collectPtr _ = return ()
-assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
-assembleOneBCO hsc_env pbco = do
- ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco
- ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
+assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
+assembleOneBCO interp profile pbco = do
+ -- TODO: the profile should be bundled with the interpreter: the rts ways are
+ -- fixed for an interpreter
+ ubco <- assembleBCO (profilePlatform profile) pbco
+ ([ubco'], _ptrs) <- mallocStrings interp [ubco]
return ubco'
assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs
index 594a68c12b..dbd816d7d0 100644
--- a/compiler/GHC/ByteCode/InfoTable.hs
+++ b/compiler/GHC/ByteCode/InfoTable.hs
@@ -13,7 +13,6 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where
import GHC.Prelude
import GHC.Driver.Session
-import GHC.Driver.Env
import GHC.Platform
import GHC.Platform.Profile
@@ -40,30 +39,30 @@ import GHC.Utils.Panic
-}
-- Make info tables for the data decls in this module
-mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
-mkITbls hsc_env tcs =
+mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
+mkITbls interp profile tcs =
foldr plusNameEnv emptyNameEnv <$>
- mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+ mapM mkITbl (filter isDataTyCon tcs)
where
- mkITbl :: HscEnv -> TyCon -> IO ItblEnv
- mkITbl hsc_env tc
+ mkITbl :: TyCon -> IO ItblEnv
+ mkITbl tc
| dcs `lengthIs` n -- paranoia; this is an assertion.
- = make_constr_itbls hsc_env dcs
+ = make_constr_itbls interp profile dcs
where
dcs = tyConDataCons tc
n = tyConFamilySize tc
- mkITbl _ _ = panic "mkITbl"
+ mkITbl _ = panic "mkITbl"
mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
-- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
-make_constr_itbls hsc_env cons =
+make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
+make_constr_itbls interp profile cons =
+ -- TODO: the profile should be bundled with the interpreter: the rts ways are
+ -- fixed for an interpreter
mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
where
- profile = targetProfile (hsc_dflags hsc_env)
-
mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
mk_itbl dcon conNo = do
let rep_args = [ NonVoid prim_rep
@@ -85,6 +84,6 @@ make_constr_itbls hsc_env cons =
constants = platformConstants platform
tables_next_to_code = platformTablesNextToCode platform
- r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
+ r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really
conNo (tagForCon platform dcon) descr)
return (getName dcon, ItblPtr r)
diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs
index 5c58d319ef..50bef7972e 100644
--- a/compiler/GHC/ByteCode/Linker.hs
+++ b/compiler/GHC/ByteCode/Linker.hs
@@ -8,19 +8,22 @@
--
-- | Bytecode assembler and linker
-module GHC.ByteCode.Linker (
- ClosureEnv, emptyClosureEnv, extendClosureEnv,
- linkBCO, lookupStaticPtr,
- lookupIE,
- nameToCLabel, linkFail
- ) where
+module GHC.ByteCode.Linker
+ ( ClosureEnv
+ , emptyClosureEnv
+ , extendClosureEnv
+ , linkBCO
+ , lookupStaticPtr
+ , lookupIE
+ , nameToCLabel
+ , linkFail
+ )
+where
#include "HsVersions.h"
import GHC.Prelude
-import GHC.Driver.Env
-
import GHC.Runtime.Interpreter
import GHC.ByteCode.Types
import GHCi.RemoteTypes
@@ -65,88 +68,104 @@ extendClosureEnv cl_env pairs
-}
linkBCO
- :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+ :: Interp
+ -> ItblEnv
+ -> ClosureEnv
+ -> NameEnv Int
+ -> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
-linkBCO hsc_env ie ce bco_ix breakarray
+linkBCO interp ie ce bco_ix breakarray
(UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
- lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)
- ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
+ lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)
+ ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)
return (ResolvedBCO isLittleEndian 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 _ _ (BCONPtrStr _) =
- -- should be eliminated during assembleBCOs
- panic "lookupLiteral: BCONPtrStr"
-
-lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
-lookupStaticPtr hsc_env addr_of_label_string = do
- m <- lookupSymbol hsc_env addr_of_label_string
+lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral interp ie ptr = case ptr of
+ BCONPtrWord lit -> return lit
+ BCONPtrLbl sym -> do
+ Ptr a# <- lookupStaticPtr interp sym
+ return (W# (int2Word# (addr2Int# a#)))
+ BCONPtrItbl nm -> do
+ Ptr a# <- lookupIE interp ie nm
+ return (W# (int2Word# (addr2Int# a#)))
+ BCONPtrStr _ ->
+ -- should be eliminated during assembleBCOs
+ panic "lookupLiteral: BCONPtrStr"
+
+lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
+lookupStaticPtr interp addr_of_label_string = do
+ m <- lookupSymbol interp addr_of_label_string
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
(unpackFS addr_of_label_string)
-lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
-lookupIE hsc_env ie con_nm =
+lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE interp ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr 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
+ m <- lookupSymbol interp 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 hsc_env sym_to_find2
+ n <- lookupSymbol interp sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
(unpackFS sym_to_find1 ++ " or " ++
unpackFS sym_to_find2)
-lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
-lookupPrimOp hsc_env primop = do
+lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
+lookupPrimOp interp primop = do
let sym_to_find = primopToCLabel primop "closure"
- m <- lookupSymbol hsc_env (mkFastString sym_to_find)
+ m <- lookupSymbol interp (mkFastString sym_to_find)
case m of
Just p -> return (toRemotePtr p)
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
resolvePtr
- :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+ :: Interp
+ -> ItblEnv
+ -> ClosureEnv
+ -> NameEnv Int
+ -> RemoteRef BreakArray
-> 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 (unsafeForeignRefToRemoteRef 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 "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
-resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
- ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
-resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
- ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
-resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
- return (ResolvedBCOPtrBreakArray breakarray)
+resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
+ 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 (unsafeForeignRefToRemoteRef rhv))
+
+ | otherwise
+ -> ASSERT2(isExternalName nm, ppr nm)
+ do
+ let sym_to_find = nameToCLabel nm "closure"
+ m <- lookupSymbol interp sym_to_find
+ case m of
+ Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+
+ BCOPtrPrimOp op
+ -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
+
+ BCOPtrBCO bco
+ -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco
+
+ BCOPtrBreakArray
+ -> return (ResolvedBCOPtrBreakArray breakarray)
linkFail :: String -> String -> IO a
linkFail who what
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index 23282eab27..94ba48c019 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -6,7 +6,6 @@ module GHC.Driver.Env.Types
import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )
-import GHC.Linker.Types ( Loader )
import GHC.Prelude
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types ( Interp )
@@ -120,9 +119,6 @@ data HscEnv
-- ^ target code interpreter (if any) to use for TH and GHCi.
-- See Note [Target code interpreter]
- , hsc_loader :: Loader
- -- ^ Loader (dynamic linker)
-
, hsc_plugins :: ![LoadedPlugin]
-- ^ plugins dynamically loaded after processing arguments. What
-- will be loaded here is directed by DynFlags.pluginModNames.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 50e5a0a067..c61ae00b55 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -100,7 +100,7 @@ import GHC.Driver.Config
import GHC.Driver.Hooks
import GHC.Runtime.Context
-import GHC.Runtime.Interpreter ( addSptEntry )
+import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )
import GHC.Runtime.Loader ( initializePlugins )
import GHCi.RemoteTypes ( ForeignHValue )
import GHC.ByteCode.Types
@@ -248,7 +248,6 @@ newHscEnv dflags = do
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
- emptyLoader <- uninitializedLoader
logger <- initLogger
tmpfs <- initTmpFs
-- FIXME: it's sad that we have so many "unitialized" fields filled with
@@ -265,7 +264,6 @@ newHscEnv dflags = do
, hsc_FC = fc_var
, hsc_type_env_var = Nothing
, hsc_interp = Nothing
- , hsc_loader = emptyLoader
, hsc_unit_env = panic "hsc_unit_env not initialized"
, hsc_plugins = []
, hsc_static_plugins = []
@@ -1897,8 +1895,10 @@ hscDeclsWithLocation hsc_env str source linenumber = do
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
- {- Rename and typecheck it -}
hsc_env <- getHscEnv
+ let interp = hscInterp hsc_env
+
+ {- Rename and typecheck it -}
tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
{- Grab the new instances -}
@@ -1953,7 +1953,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
stg_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
- liftIO $ loadDecls hsc_env src_span cbc
+ liftIO $ loadDecls interp hsc_env src_span cbc
{- Load static pointer table entries -}
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
@@ -1983,10 +1983,11 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env entries = do
+ let interp = hscInterp hsc_env
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i fpr) = do
- val <- loadName hsc_env (idName i)
- addSptEntry hsc_env fpr val
+ val <- loadName interp hsc_env (idName i)
+ addSptEntry interp fpr val
mapM_ add_spt_entry entries
{-
@@ -2135,7 +2136,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
stg_expr
{- load it -}
- ; loadExpr hsc_env srcspan bcos }
+ ; loadExpr (hscInterp hsc_env) hsc_env srcspan bcos }
{- **********************************************************************
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 20fb7ecc86..0d30d81de9 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -47,6 +47,7 @@ import GHC.Prelude
import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad ( initIfaceCheck )
+import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types
@@ -433,6 +434,7 @@ load' how_much mHscMessage mod_graph = do
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
+ let interp = hscInterp hsc_env
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
@@ -506,7 +508,7 @@ load' how_much mHscMessage mod_graph = do
-- this list only serves as a poor man's set.
Just hmi <- [lookupHpt pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
- liftIO $ unload hsc_env stable_linkables
+ liftIO $ unload interp hsc_env stable_linkables
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
@@ -710,7 +712,8 @@ loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
-- If the link failed, unload everything and return.
loadFinish _all_ok Failed
= do hsc_env <- getSession
- liftIO $ unload hsc_env []
+ let interp = hscInterp hsc_env
+ liftIO $ unload interp hsc_env []
modifySession discardProg
return Failed
@@ -841,10 +844,10 @@ findPartiallyCompletedCycles modsDone theGraph
-- ---------------------------------------------------------------------------
--
-- | Unloading
-unload :: HscEnv -> [Linkable] -> IO ()
-unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'
+unload :: Interp -> HscEnv -> [Linkable] -> IO ()
+unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'
= case ghcLink (hsc_dflags hsc_env) of
- LinkInMemory -> Linker.unload hsc_env stable_linkables
+ LinkInMemory -> Linker.unload interp hsc_env stable_linkables
_other -> return ()
-- -----------------------------------------------------------------------------
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index c3df228778..8a6bb4e160 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -146,8 +146,9 @@ guessSourceFile binds orig_file =
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
mkModBreaks hsc_env mod count entries
- | breakpointsEnabled (hsc_dflags hsc_env) = do
- breakArray <- GHCi.newBreakArray hsc_env (length entries)
+ | Just interp <- hsc_interp hsc_env
+ , breakpointsEnabled (hsc_dflags hsc_env) = do
+ breakArray <- GHCi.newBreakArray interp (length entries)
ccs <- mkCCSArray hsc_env mod count entries
let
locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
@@ -169,7 +170,7 @@ mkCCSArray hsc_env modul count entries =
case hsc_interp hsc_env of
Just interp | GHCi.interpreterProfiled interp -> do
let module_str = moduleNameString (moduleName modul)
- costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
+ costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
return (listArray (0,count-1) costcentres)
_ -> return (listArray (0,-1) [])
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index cc1fde53a3..ebc5a0b0c0 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -48,7 +48,6 @@ import GHC.Driver.Ppr
import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
import GHC.Iface.Load
@@ -116,25 +115,19 @@ import GHC.Utils.Exception
uninitialised :: a
uninitialised = panic "Loader not initialised"
-modifyLS_ :: Loader -> (LoaderState -> IO LoaderState) -> IO ()
-modifyLS_ dl f =
- modifyMVar_ (loader_state dl) (fmap pure . f . fromMaybe uninitialised)
+modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO ()
+modifyLoaderState_ interp f =
+ modifyMVar_ (loader_state (interpLoader interp))
+ (fmap pure . f . fromMaybe uninitialised)
-modifyLS :: Loader -> (LoaderState -> IO (LoaderState, a)) -> IO a
-modifyLS dl f =
- modifyMVar (loader_state dl) (fmapFst pure . f . fromMaybe uninitialised)
+modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a
+modifyLoaderState interp f =
+ modifyMVar (loader_state (interpLoader interp))
+ (fmapFst pure . f . fromMaybe uninitialised)
where fmapFst f = fmap (\(x, y) -> (f x, y))
-readLS :: Loader -> IO LoaderState
-readLS dl =
- (fmap (fromMaybe uninitialised) . readMVar) (loader_state dl)
-
-modifyMbLS_
- :: Loader -> (Maybe LoaderState -> IO (Maybe LoaderState)) -> IO ()
-modifyMbLS_ dl f = modifyMVar_ (loader_state dl) f
-
-emptyLS :: LoaderState
-emptyLS = LoaderState
+emptyLoaderState :: LoaderState
+emptyLoaderState = LoaderState
{ closure_env = emptyNameEnv
, itbl_env = emptyNameEnv
, pkgs_loaded = init_pkgs
@@ -149,21 +142,21 @@ emptyLS = LoaderState
-- explicit list. See rts/Linker.c for details.
where init_pkgs = [rtsUnitId]
-extendLoadedPkgs :: Loader -> [UnitId] -> IO ()
-extendLoadedPkgs dl pkgs =
- modifyLS_ dl $ \s ->
+extendLoadedPkgs :: Interp -> [UnitId] -> IO ()
+extendLoadedPkgs interp pkgs =
+ modifyLoaderState_ interp $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
-extendLoadedEnv :: Loader -> [(Name,ForeignHValue)] -> IO ()
-extendLoadedEnv dl new_bindings =
- modifyLS_ dl $ \pls@LoaderState{..} -> do
+extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
+extendLoadedEnv interp new_bindings =
+ modifyLoaderState_ interp $ \pls@LoaderState{..} -> do
let new_ce = extendClosureEnv closure_env new_bindings
return $! pls{ closure_env = new_ce }
-- strictness is important for not retaining old copies of the pls
-deleteFromLoadedEnv :: Loader -> [Name] -> IO ()
-deleteFromLoadedEnv dl to_remove =
- modifyLS_ dl $ \pls -> do
+deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
+deleteFromLoadedEnv interp to_remove =
+ modifyLoaderState_ interp $ \pls -> do
let ce = closure_env pls
let new_ce = delListFromNameEnv ce to_remove
return pls{ closure_env = new_ce }
@@ -171,15 +164,14 @@ deleteFromLoadedEnv dl to_remove =
-- | Load the module containing the given Name and get its associated 'HValue'.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-loadName :: HscEnv -> Name -> IO ForeignHValue
-loadName hsc_env name = do
- let dl = hsc_loader hsc_env
- initLoaderState hsc_env
- modifyLS dl $ \pls0 -> do
+loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue
+loadName interp hsc_env name = do
+ initLoaderState interp hsc_env
+ modifyLoaderState interp $ \pls0 -> do
pls <- if not (isExternalName name)
then return pls0
else do
- (pls', ok) <- loadDependencies hsc_env pls0 noSrcSpan
+ (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan
[nameModule name]
if failed ok
then throwGhcExceptionIO (ProgramError "")
@@ -189,40 +181,47 @@ loadName hsc_env name = do
Just (_,aa) -> return (pls,aa)
Nothing -> ASSERT2(isExternalName name, ppr name)
do let sym_to_find = nameToCLabel name "closure"
- m <- lookupClosure hsc_env (unpackFS sym_to_find)
+ m <- lookupClosure interp (unpackFS sym_to_find)
r <- case m of
- Just hvref -> mkFinalizedHValue hsc_env hvref
+ Just hvref -> mkFinalizedHValue interp hvref
Nothing -> linkFail "GHC.Linker.Loader.loadName"
(unpackFS sym_to_find)
return (pls,r)
-loadDependencies :: HscEnv -> LoaderState
- -> SrcSpan -> [Module]
- -> IO (LoaderState, SuccessFlag)
-loadDependencies hsc_env pls span needed_mods = do
+loadDependencies
+ :: Interp
+ -> HscEnv
+ -> LoaderState
+ -> SrcSpan -> [Module]
+ -> IO (LoaderState, SuccessFlag)
+loadDependencies interp hsc_env pls span needed_mods = do
-- initLoaderState (hsc_dflags hsc_env) dl
let hpt = hsc_HPT hsc_env
+ let dflags = hsc_dflags hsc_env
-- The interpreter and dynamic linker can only handle object code built
-- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
-- So here we check the build tag: if we're building a non-standard way
-- then we need to find & link object files built the "normal" way.
- maybe_normal_osuf <- checkNonStdWay hsc_env span
+ maybe_normal_osuf <- checkNonStdWay dflags interp span
-- Find what packages and linkables are required
(lnks, pkgs) <- getLinkDeps hsc_env hpt pls
maybe_normal_osuf span needed_mods
-- Link the packages and modules required
- pls1 <- loadPackages' hsc_env pkgs pls
- loadModules hsc_env pls1 lnks
+ pls1 <- loadPackages' interp hsc_env pkgs pls
+ loadModules interp hsc_env pls1 lnks
-- | Temporarily extend the loaded env.
-
-withExtendedLoadedEnv :: (ExceptionMonad m) =>
- Loader -> [(Name,ForeignHValue)] -> m a -> m a
-withExtendedLoadedEnv dl new_env action
- = MC.bracket (liftIO $ extendLoadedEnv dl new_env)
+withExtendedLoadedEnv
+ :: (ExceptionMonad m)
+ => Interp
+ -> [(Name,ForeignHValue)]
+ -> m a
+ -> m a
+withExtendedLoadedEnv interp new_env action
+ = MC.bracket (liftIO $ extendLoadedEnv interp new_env)
(\_ -> reset_old_env)
(\_ -> action)
where
@@ -232,21 +231,25 @@ withExtendedLoadedEnv dl new_env action
-- package), so the reset action only removes the names we
-- added earlier.
reset_old_env = liftIO $
- modifyLS_ dl $ \pls ->
+ modifyLoaderState_ interp $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
in return pls{ closure_env = new }
--- | Display the persistent linker state.
-showLoaderState :: Loader -> IO SDoc
-showLoaderState dl
- = do pls <- readLS dl
- return $ withPprStyle defaultDumpStyle
- (vcat [text "----- Loader state -----",
- text "Pkgs:" <+> ppr (pkgs_loaded pls),
- text "Objs:" <+> ppr (objs_loaded pls),
- text "BCOs:" <+> ppr (bcos_loaded pls)])
+-- | Display the loader state.
+showLoaderState :: Interp -> IO SDoc
+showLoaderState interp = do
+ ls <- readMVar (loader_state (interpLoader interp))
+ let docs = case ls of
+ Nothing -> [ text "Loader not initialised"]
+ Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)
+ , text "Objs:" <+> ppr (objs_loaded pls)
+ , text "BCOs:" <+> ppr (bcos_loaded pls)
+ ]
+
+ return $ withPprStyle defaultDumpStyle
+ $ vcat (text "----- Loader state -----":docs)
{- **********************************************************************
@@ -273,38 +276,40 @@ showLoaderState dl
-- nothing. This is useful in Template Haskell, where we call it before
-- trying to link.
--
-initLoaderState :: HscEnv -> IO ()
-initLoaderState hsc_env = do
- let dl = hsc_loader hsc_env
- modifyMbLS_ dl $ \pls -> do
+initLoaderState :: Interp -> HscEnv -> IO ()
+initLoaderState interp hsc_env = do
+ modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do
case pls of
Just _ -> return pls
- Nothing -> Just <$> reallyInitLoaderState hsc_env
+ Nothing -> Just <$> reallyInitLoaderState interp hsc_env
-reallyInitLoaderState :: HscEnv -> IO LoaderState
-reallyInitLoaderState hsc_env = do
+reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState
+reallyInitLoaderState interp hsc_env = do
-- Initialise the linker state
- let pls0 = emptyLS
+ let pls0 = emptyLoaderState
-- (a) initialise the C dynamic linker
- initObjLinker hsc_env
+ initObjLinker interp
-- (b) Load packages from the command-line (Note [preload packages])
- pls <- loadPackages' hsc_env (preloadUnits (hsc_units hsc_env)) pls0
+ pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0
-- steps (c), (d) and (e)
- loadCmdLineLibs' hsc_env pls
+ loadCmdLineLibs' interp hsc_env pls
-loadCmdLineLibs :: HscEnv -> IO ()
-loadCmdLineLibs hsc_env = do
- let dl = hsc_loader hsc_env
- initLoaderState hsc_env
- modifyLS_ dl $ \pls ->
- loadCmdLineLibs' hsc_env pls
+loadCmdLineLibs :: Interp -> HscEnv -> IO ()
+loadCmdLineLibs interp hsc_env = do
+ initLoaderState interp hsc_env
+ modifyLoaderState_ interp $ \pls ->
+ loadCmdLineLibs' interp hsc_env pls
-loadCmdLineLibs' :: HscEnv -> LoaderState -> IO LoaderState
-loadCmdLineLibs' hsc_env pls =
+loadCmdLineLibs'
+ :: Interp
+ -> HscEnv
+ -> LoaderState
+ -> IO LoaderState
+loadCmdLineLibs' interp hsc_env pls =
do
let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
, libraryPaths = lib_paths_base})
@@ -335,7 +340,7 @@ loadCmdLineLibs' hsc_env pls =
maybePutStr logger dflags (unlines $ map (" "++) gcc_paths)
libspecs
- <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
+ <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls
-- (d) Link .o files from the command-line
classified_ld_inputs <- mapM (classifyLdInput logger dflags)
@@ -364,17 +369,17 @@ loadCmdLineLibs' hsc_env pls =
in nub $ map normalise paths
let lib_paths = nub $ lib_paths_base ++ gcc_paths
all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
- pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+ pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
let merged_specs = mergeStaticObjects cmdline_lib_specs
- pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
+ pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls
merged_specs
maybePutStr logger dflags "final link ... "
- ok <- resolveObjs hsc_env
+ ok <- resolveObjs interp
-- DLLs are loaded, reset the search paths
- mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+ mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
if succeeded ok then maybePutStrLn logger dflags "done"
else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
@@ -431,9 +436,14 @@ classifyLdInput logger dflags f
where platform = targetPlatform dflags
preloadLib
- :: HscEnv -> [String] -> [String] -> LoaderState
- -> LibrarySpec -> IO LoaderState
-preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
+ :: Interp
+ -> HscEnv
+ -> [String]
+ -> [String]
+ -> LoaderState
+ -> LibrarySpec
+ -> IO LoaderState
+preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
case lib_spec of
Objects static_ishs -> do
@@ -447,7 +457,7 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
return pls
DLL dll_unadorned -> do
- maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned)
+ maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
case maybe_errstr of
Nothing -> maybePutStrLn logger dflags "done"
Just mm | platformOS platform /= OSDarwin ->
@@ -457,14 +467,14 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
-- since (apparently) some things install that way - see
-- ticket #8770.
let libfile = ("lib" ++ dll_unadorned) <.> "so"
- err2 <- loadDLL hsc_env libfile
+ err2 <- loadDLL interp libfile
case err2 of
Nothing -> maybePutStrLn logger dflags "done"
Just _ -> preloadFailed mm lib_paths lib_spec
return pls
DLLPath dll_path -> do
- do maybe_errstr <- loadDLL hsc_env dll_path
+ do maybe_errstr <- loadDLL interp dll_path
case maybe_errstr of
Nothing -> maybePutStrLn logger dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
@@ -472,7 +482,7 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
Framework framework ->
if platformUsesFrameworks (targetPlatform dflags)
- then do maybe_errstr <- loadFramework hsc_env framework_paths framework
+ then do maybe_errstr <- loadFramework interp framework_paths framework
case maybe_errstr of
Nothing -> maybePutStrLn logger dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
@@ -501,9 +511,9 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
= do b <- or <$> mapM doesFileExist names
if not b then return (False, pls)
else if hostIsDynamic
- then do pls1 <- dynLoadObjs hsc_env pls names
+ then do pls1 <- dynLoadObjs interp hsc_env pls names
return (True, pls1)
- else do mapM_ (loadObj hsc_env) names
+ else do mapM_ (loadObj interp) names
return (True, pls)
preload_static_archive _paths name
@@ -512,7 +522,7 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
else do if hostIsDynamic
then throwGhcExceptionIO $
CmdLineError dynamic_msg
- else loadArchive hsc_env name
+ else loadArchive interp name
return True
where
dynamic_msg = unlines
@@ -535,38 +545,31 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
-- Raises an IO exception ('ProgramError') if it can't find a compiled
-- version of the dependents to load.
--
-loadExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
-loadExpr hsc_env span root_ul_bco
- = do {
- -- Initialise the linker (if it's not been done already)
- ; initLoaderState hsc_env
-
- -- Extract the Loader value for passing into required places
- ; let dl = hsc_loader hsc_env
-
- -- Take lock for the actual work.
- ; modifyLS dl $ \pls0 -> do {
-
- -- Load the packages and modules required
- ; (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods
- ; if failed ok then
- throwGhcExceptionIO (ProgramError "")
- else do {
-
- -- Load the expression itself
- let ie = itbl_env pls
- ce = closure_env pls
-
- -- Load the necessary packages and linkables
-
- ; let nobreakarray = error "no break array"
- bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
- ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
- ; [root_hvref] <- createBCOs hsc_env [resolved]
- ; fhv <- mkFinalizedHValue hsc_env root_hvref
- ; return (pls, fhv)
- }}}
- where
+loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
+loadExpr interp hsc_env span root_ul_bco = do
+ -- Initialise the linker (if it's not been done already)
+ initLoaderState interp hsc_env
+
+ -- Take lock for the actual work.
+ modifyLoaderState interp $ \pls0 -> do
+ -- Load the packages and modules required
+ (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
+ if failed ok
+ then throwGhcExceptionIO (ProgramError "")
+ else do
+ -- Load the expression itself
+ let ie = itbl_env pls
+ ce = closure_env pls
+
+ -- Load the necessary packages and linkables
+ let nobreakarray = error "no break array"
+ bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
+ resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco
+ [root_hvref] <- createBCOs interp dflags [resolved]
+ fhv <- mkFinalizedHValue interp root_hvref
+ return (pls, fhv)
+ where
+ dflags = hsc_dflags hsc_env
free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
@@ -583,9 +586,9 @@ dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
-checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath)
-checkNonStdWay hsc_env srcspan
- | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing
+checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)
+checkNonStdWay dflags interp srcspan
+ | ExternalInterp {} <- interpInstance interp = 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.
@@ -594,12 +597,12 @@ checkNonStdWay hsc_env srcspan
-- Only if we are compiling with the same ways as GHC is built
-- with, can we dynamically load those object files. (see #3604)
- | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays)
- = failNonStd (hsc_dflags hsc_env) srcspan
+ | objectSuf dflags == normalObjectSuffix && not (null targetFullWays)
+ = failNonStd dflags srcspan
| otherwise = return (Just (hostWayTag ++ "o"))
where
- targetFullWays = fullWays (ways (hsc_dflags hsc_env))
+ targetFullWays = fullWays (ways dflags)
hostWayTag = case waysTag hostFullWays of
"" -> ""
tag -> tag ++ "_"
@@ -771,18 +774,15 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
********************************************************************* -}
-loadDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
-loadDecls hsc_env span cbc@CompiledByteCode{..} = do
+loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
+loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
-- Initialise the linker (if it's not been done already)
- initLoaderState hsc_env
-
- -- Extract the Loader for passing into required places
- let dl = hsc_loader hsc_env
+ initLoaderState interp hsc_env
-- Take lock for the actual work.
- modifyLS_ dl $ \pls0 -> do
+ modifyLoaderState_ interp $ \pls0 -> do
-- Link the packages and modules required
- (pls, ok) <- loadDependencies hsc_env pls0 span needed_mods
+ (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
if failed ok
then throwGhcExceptionIO (ProgramError "")
else do
@@ -791,12 +791,13 @@ loadDecls hsc_env span cbc@CompiledByteCode{..} = do
ce = closure_env pls
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
- nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
+ new_bindings <- linkSomeBCOs dflags interp ie ce [cbc]
+ nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
, itbl_env = ie }
return pls2
where
+ dflags = hsc_dflags hsc_env
free_names = uniqDSetToList $
foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
@@ -816,12 +817,11 @@ loadDecls hsc_env span cbc@CompiledByteCode{..} = do
********************************************************************* -}
-loadModule :: HscEnv -> Module -> IO ()
-loadModule hsc_env mod = do
- initLoaderState hsc_env
- let dl = hsc_loader hsc_env
- modifyLS_ dl $ \pls -> do
- (pls', ok) <- loadDependencies hsc_env pls noSrcSpan [mod]
+loadModule :: Interp -> HscEnv -> Module -> IO ()
+loadModule interp hsc_env mod = do
+ initLoaderState interp hsc_env
+ modifyLoaderState_ interp $ \pls -> do
+ (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod]
if failed ok
then throwGhcExceptionIO (ProgramError "could not load module")
else return pls'
@@ -834,20 +834,21 @@ loadModule hsc_env mod = do
********************************************************************* -}
-loadModules :: HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
-loadModules hsc_env pls linkables
+loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
+loadModules interp hsc_env pls linkables
= mask_ $ do -- don't want to be interrupted by ^C in here
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
+ let dflags = hsc_dflags hsc_env
-- Load objects first; they can't depend on BCOs
- (pls1, ok_flag) <- loadObjects hsc_env pls objs
+ (pls1, ok_flag) <- loadObjects interp hsc_env pls objs
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs hsc_env pls1 bcos
+ pls2 <- dynLinkBCOs dflags interp pls1 bcos
return (pls2, Succeeded)
@@ -887,35 +888,39 @@ linkableInSet l objs_loaded =
--
-- If the interpreter uses dynamic-linking, build a shared library and load it.
-- Otherwise, use the RTS linker.
-loadObjects :: HscEnv -> LoaderState -> [Linkable]
- -> IO (LoaderState, SuccessFlag)
-loadObjects hsc_env pls objs = do
+loadObjects
+ :: Interp
+ -> HscEnv
+ -> LoaderState
+ -> [Linkable]
+ -> IO (LoaderState, SuccessFlag)
+loadObjects interp hsc_env pls objs = do
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 interpreterDynamic (hscInterp hsc_env)
- then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
+ if interpreterDynamic interp
+ then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
return (pls2, Succeeded)
- else do mapM_ (loadObj hsc_env) wanted_objs
+ else do mapM_ (loadObj interp) wanted_objs
-- Link them all together
- ok <- resolveObjs hsc_env
+ ok <- resolveObjs interp
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then
return (pls1, Succeeded)
else do
- pls2 <- unload_wkr hsc_env [] pls1
+ pls2 <- unload_wkr interp [] pls1
return (pls2, Failed)
-- | Create a shared library containing the given object files and load it.
-dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
-dynLoadObjs _ pls [] = return pls
-dynLoadObjs hsc_env pls@LoaderState{..} objs = do
+dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
+dynLoadObjs _ _ pls [] = return pls
+dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do
let unit_env = hsc_unit_env hsc_env
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
@@ -974,7 +979,7 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do
-- if we got this far, extend the lifetime of the library file
changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
- m <- loadDLL hsc_env soFile
+ m <- loadDLL interp soFile
case m of
Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
Just err -> linkFail msg err
@@ -1000,8 +1005,8 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: HscEnv -> LoaderState -> [Linkable] -> IO LoaderState
-dynLinkBCOs hsc_env pls bcos = do
+dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState
+dynLinkBCOs dflags interp pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -1016,21 +1021,22 @@ dynLinkBCOs hsc_env pls bcos = do
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs
+ names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs
-- 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)
+ freeHValueRefs interp (map snd to_drop)
-- Wrap finalizers on the ones we want to keep
- new_binds <- makeForeignNamedHValueRefs hsc_env to_add
+ new_binds <- makeForeignNamedHValueRefs interp to_add
return pls1 { closure_env = extendClosureEnv gce new_binds,
itbl_env = final_ie }
-- Link a bunch of BCOs and return references to their values
-linkSomeBCOs :: HscEnv
+linkSomeBCOs :: DynFlags
+ -> Interp
-> ItblEnv
-> ClosureEnv
-> [CompiledByteCode]
@@ -1039,7 +1045,7 @@ linkSomeBCOs :: HscEnv
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
+linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum =
case bc_breaks of
@@ -1052,16 +1058,16 @@ linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
names = map (unlinkedBCOName . snd) flat
bco_ix = mkNameEnv (zip names [0..])
- resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
+ resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco
| (breakarray, bco) <- flat ]
- hvrefs <- createBCOs hsc_env resolved
+ hvrefs <- createBCOs interp dflags 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
+ :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
+makeForeignNamedHValueRefs interp bindings =
+ mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings
{- **********************************************************************
@@ -1083,21 +1089,20 @@ makeForeignNamedHValueRefs hsc_env bindings =
--
-- * we also implicitly unload all temporary bindings at this point.
--
-unload :: HscEnv
- -> [Linkable] -- ^ The linkables to *keep*.
- -> IO ()
-unload hsc_env linkables
+unload
+ :: Interp
+ -> HscEnv
+ -> [Linkable] -- ^ The linkables to *keep*.
+ -> IO ()
+unload interp 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)
- initLoaderState hsc_env
-
- -- Extract Loader for passing into required places
- let dl = hsc_loader hsc_env
+ initLoaderState interp hsc_env
new_pls
- <- modifyLS dl $ \pls -> do
- pls1 <- unload_wkr hsc_env linkables pls
+ <- modifyLoaderState interp $ \pls -> do
+ pls1 <- unload_wkr interp linkables pls
return (pls1, pls1)
let dflags = hsc_dflags hsc_env
@@ -1108,14 +1113,15 @@ unload hsc_env linkables
text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
return ()
-unload_wkr :: HscEnv
- -> [Linkable] -- stable linkables
- -> LoaderState
- -> IO LoaderState
+unload_wkr
+ :: Interp
+ -> [Linkable] -- stable linkables
+ -> LoaderState
+ -> IO LoaderState
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the LS get and put)
-unload_wkr hsc_env keep_linkables pls@LoaderState{..} = do
+unload_wkr interp keep_linkables pls@LoaderState{..} = do
-- NB. careful strictness here to avoid keeping the old LS when
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
@@ -1136,7 +1142,7 @@ unload_wkr hsc_env keep_linkables pls@LoaderState{..} = do
-- of lookupSymbol results.
when (not (null (objs_to_unload ++
filter (not . null . linkableObjs) bcos_to_unload))) $
- purgeLookupSymbolCache hsc_env
+ purgeLookupSymbolCache interp
let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
@@ -1168,7 +1174,7 @@ unload_wkr hsc_env keep_linkables pls@LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
+ = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
-- The components of a BCO linkable may contain
-- dot-o files. Which is very confusing.
--
@@ -1237,7 +1243,7 @@ showLS (Framework nm) = "(framework) " ++ nm
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-loadPackages :: HscEnv -> [UnitId] -> IO ()
+loadPackages :: Interp -> 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.
--
@@ -1246,16 +1252,15 @@ loadPackages :: HscEnv -> [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.
-loadPackages hsc_env new_pkgs = do
+loadPackages interp hsc_env new_pkgs = do
-- It's probably not safe to try to load packages concurrently, so we take
-- a lock.
- initLoaderState hsc_env
- let dl = hsc_loader hsc_env
- modifyLS_ dl $ \pls ->
- loadPackages' hsc_env new_pkgs pls
+ initLoaderState interp hsc_env
+ modifyLoaderState_ interp $ \pls ->
+ loadPackages' interp hsc_env new_pkgs pls
-loadPackages' :: HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
-loadPackages' hsc_env new_pks pls = do
+loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
+loadPackages' interp hsc_env new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
@@ -1271,20 +1276,20 @@ loadPackages' hsc_env new_pks pls = do
= do { -- Link dependents first
pkgs' <- link pkgs (unitDepends pkg_cfg)
-- Now link the package itself
- ; loadPackage hsc_env pkg_cfg
+ ; loadPackage interp hsc_env pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
= throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
-loadPackage :: HscEnv -> UnitInfo -> IO ()
-loadPackage hsc_env pkg
+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ()
+loadPackage interp hsc_env pkg
= do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
platform = targetPlatform dflags
- is_dyn = interpreterDynamic (hscInterp hsc_env)
+ is_dyn = interpreterDynamic interp
dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg
| otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg
@@ -1314,9 +1319,9 @@ loadPackage hsc_env pkg
dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
hs_classifieds
- <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs'
+ <- mapM (locateLib interp hsc_env True dirs_env gcc_paths) hs_libs'
extra_classifieds
- <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs
+ <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs
let classifieds = hs_classifieds ++ extra_classifieds
-- Complication: all the .so's must be loaded before any of the .o's.
@@ -1330,7 +1335,7 @@ loadPackage hsc_env pkg
let dll_paths = map takeDirectory known_dlls
all_paths = nub $ map normalise $ dll_paths ++ dirs
all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
- pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+ pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
maybePutSDoc logger dflags
(text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
@@ -1338,28 +1343,28 @@ loadPackage hsc_env pkg
-- See comments with partOfGHCi
#if defined(CAN_LOAD_DLL)
when (unitPackageName pkg `notElem` partOfGHCi) $ do
- loadFrameworks hsc_env platform pkg
+ loadFrameworks interp platform pkg
-- See Note [Crash early load_dyn and locateLib]
-- Crash early if can't load any of `known_dlls`
- mapM_ (load_dyn hsc_env True) known_dlls
+ mapM_ (load_dyn interp hsc_env True) known_dlls
-- For remaining `dlls` crash early only when there is surely
-- no package's DLL around ... (not is_dyn)
- mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName platform) dlls
+ mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls
#endif
-- 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 hsc_env) objs
- mapM_ (loadArchive hsc_env) archs
+ mapM_ (loadObj interp) objs
+ mapM_ (loadArchive interp) archs
maybePutStr logger dflags "linking ... "
- ok <- resolveObjs hsc_env
+ ok <- resolveObjs interp
-- DLLs are loaded, reset the search paths
-- Import libraries will be loaded via loadArchive so only
-- reset the DLL search path after all archives are loaded
-- as well.
- mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+ mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
if succeeded ok
then maybePutStrLn logger dflags "done."
@@ -1414,9 +1419,9 @@ restriction very easily.
-- can be passed directly to loadDLL. They are either fully-qualified
-- ("/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 :: HscEnv -> Bool -> FilePath -> IO ()
-load_dyn hsc_env crash_early dll = do
- r <- loadDLL hsc_env dll
+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()
+load_dyn interp hsc_env crash_early dll = do
+ r <- loadDLL interp dll
case r of
Nothing -> return ()
Just err ->
@@ -1436,14 +1441,14 @@ load_dyn hsc_env crash_early dll = do
, "(the package DLL is loaded by the system linker"
, " which manages dependencies by itself)." ]
-loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO ()
-loadFrameworks hsc_env platform pkg
+loadFrameworks :: Interp -> Platform -> UnitInfo -> IO ()
+loadFrameworks interp platform pkg
= when (platformUsesFrameworks platform) $ mapM_ load frameworks
where
fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg
frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg
- load fw = do r <- loadFramework hsc_env fw_dirs fw
+ load fw = do r <- loadFramework interp fw_dirs fw
case r of
Nothing -> return ()
Just err -> cmdLineErrorIO ("can't load framework: "
@@ -1455,9 +1460,15 @@ loadFrameworks hsc_env platform pkg
-- standard system search path.
-- For GHCi we tend to prefer dynamic libraries over static ones as
-- they are easier to load and manage, have less overhead.
-locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
- -> IO LibrarySpec
-locateLib hsc_env is_hs lib_dirs gcc_dirs lib
+locateLib
+ :: Interp
+ -> HscEnv
+ -> Bool
+ -> [FilePath]
+ -> [FilePath]
+ -> String
+ -> IO LibrarySpec
+locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
| not is_hs
-- For non-Haskell libraries (e.g. gmp, iconv):
-- first look in library-dirs for a dynamic library (on User paths only)
@@ -1510,7 +1521,6 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
where
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
- interp = hscInterp hsc_env
dirs = lib_dirs ++ gcc_dirs
gcc = False
user = True
@@ -1549,7 +1559,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs
in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $
- findSystemLibrary hsc_env so_name
+ findSystemLibrary interp so_name
tryGcc = let search = searchForLibUsingGcc logger dflags
dllpath = liftM (fmap DLLPath)
short = dllpath $ search so_name lib_dirs
diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs
index d95255acda..4851ae96b9 100644
--- a/compiler/GHC/Linker/MacOS.hs
+++ b/compiler/GHC/Linker/MacOS.hs
@@ -10,7 +10,6 @@ import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
-import GHC.Driver.Env
import GHC.Unit.Types
import GHC.Unit.State
@@ -18,7 +17,7 @@ import GHC.Unit.Env
import GHC.SysTools.Tasks
-import GHC.Runtime.Interpreter (loadDLL)
+import GHC.Runtime.Interpreter
import GHC.Utils.Exception
import GHC.Utils.Logger
@@ -123,8 +122,8 @@ addresses.
-- 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 :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
-loadFramework hsc_env extraPaths rootname
+loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework interp extraPaths rootname
= do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
@@ -147,7 +146,7 @@ loadFramework hsc_env extraPaths rootname
-- has no built-in paths for frameworks: give up
return $ Just errs
findLoadDLL (p:ps) errs =
- do { dll <- loadDLL hsc_env (p </> fwk_file)
+ do { dll <- loadDLL interp (p </> fwk_file)
; case dll of
Nothing -> return Nothing
Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 5051a97f52..387d52b6de 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -135,8 +135,8 @@ bindSuspensions t = do
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
- dl = hsc_loader hsc_env
- liftIO $ extendLoadedEnv dl (zip names fhvs)
+ interp = hscInterp hsc_env
+ liftIO $ extendLoadedEnv interp (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic }
return t'
where
@@ -197,12 +197,12 @@ showTerm term = do
let expr = "Prelude.return (Prelude.show " ++
showPpr dflags bname ++
") :: Prelude.IO Prelude.String"
- dl = hsc_loader hsc_env
- txt_ <- withExtendedLoadedEnv dl
+ interp = hscInterp hsc_env
+ txt_ <- withExtendedLoadedEnv interp
[(bname, fhv)]
(GHC.compileExprRemote expr)
let myprec = 10 -- application precedence. TODO Infix constructors
- txt <- liftIO $ evalString hsc_env txt_
+ txt <- liftIO $ evalString interp txt_
if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index e3ba232add..b90bb044c4 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -57,7 +57,6 @@ import GHC.Driver.Ppr
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter as GHCi
-import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Heap.Inspect
import GHC.Runtime.Context
import GHCi.Message
@@ -210,6 +209,7 @@ execStmt input exec_opts@ExecOptions{..} = do
execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' stmt stmt_text ExecOptions{..} = do
hsc_env <- getSession
+ let interp = hscInterp hsc_env
-- Turn off -fwarn-unused-local-binds when running a statement, to hide
-- warnings about the implicit bindings we introduce.
@@ -229,7 +229,7 @@ execStmt' stmt stmt_text ExecOptions{..} = do
status <-
withVirtualCWD $
liftIO $
- evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
+ evalStmt interp idflags' (isStep execSingleStep) (execWrap hval)
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_rn_gbl_env ic)
@@ -282,7 +282,7 @@ withVirtualCWD m = do
-- a virtual CWD is only necessary when we're running interpreted code in
-- the same process as the compiler.
- case hsc_interp hsc_env of
+ case interpInstance <$> hsc_interp hsc_env of
Just (ExternalInterp {}) -> m
_ -> do
let ic = hsc_IC hsc_env
@@ -323,6 +323,8 @@ handleRunStatus step expr bindings final_ids status history
, not is_exception
= do
hsc_env <- getSession
+ let interp = hscInterp hsc_env
+ let dflags = hsc_dflags hsc_env
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
(mkUniqueGrimily mod_uniq)
@@ -330,18 +332,18 @@ handleRunStatus step expr bindings final_ids status history
breaks = getModBreaks hmi
b <- liftIO $
- breakpointStatus hsc_env (modBreaks_flags breaks) ix
+ breakpointStatus interp (modBreaks_flags breaks) ix
if b
then not_tracing
-- This breakpoint is explicitly enabled; we want to stop
-- instead of just logging it.
else do
- apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+ apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let bi = BreakInfo modl ix
!history' = mkHistory hsc_env apStack_fhv bi `consBL` history
-- history is strict, otherwise our BoundedList is pointless.
- fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
- status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
+ fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
+ status <- liftIO $ GHCi.resumeStmt interp dflags True fhv
handleRunStatus RunAndLogSteps expr bindings final_ids
status history'
| otherwise
@@ -352,8 +354,9 @@ handleRunStatus step expr bindings final_ids status history
| EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
= do
hsc_env <- getSession
- resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
- apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+ let interp = hscInterp hsc_env
+ resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
+ apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
(mkUniqueGrimily mod_uniq)
@@ -382,8 +385,8 @@ handleRunStatus step expr bindings final_ids status history
= do hsc_env <- getSession
let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
final_names = map getName final_ids
- dl = hsc_loader hsc_env
- liftIO $ Loader.extendLoadedEnv dl (zip final_names hvals)
+ interp = hscInterp hsc_env
+ liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
setSession hsc_env'
return (ExecComplete (Right final_names) allocs)
@@ -425,8 +428,9 @@ resumeExec canLogSpan step mbCnt
new_names = [ n | thing <- ic_tythings ic
, let n = getName thing
, not (n `elem` old_names) ]
- dl = hsc_loader hsc_env
- liftIO $ Loader.deleteFromLoadedEnv dl new_names
+ interp = hscInterp hsc_env
+ dflags = hsc_dflags hsc_env
+ liftIO $ Loader.deleteFromLoadedEnv interp new_names
case r of
Resume { resumeStmt = expr, resumeContext = fhv
@@ -439,7 +443,7 @@ resumeExec canLogSpan step mbCnt
setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)
-- When the user specified a break ignore count, set it
-- in the interpreter
- status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
+ status <- liftIO $ GHCi.resumeStmt interp dflags (isStep step) fhv
let prevHistoryLst = fromListBL 50 hist
hist' = case mb_brkpt of
Nothing -> prevHistoryLst
@@ -457,7 +461,8 @@ setupBreakpoint hsc_env brkInfo cnt = do
ix = breakInfo_number brkInfo
modBreaks = breaks hsc_env modl
breakarray = modBreaks_flags modBreaks
- _ <- liftIO $ GHCi.storeBreakpoint hsc_env breakarray ix cnt
+ interp = hscInterp hsc_env
+ _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt
pure ()
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
@@ -535,9 +540,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
- dl = hsc_loader hsc_env
+ interp = hscInterp hsc_env
--
- Loader.extendLoadedEnv dl [(exn_name, apStack)]
+ Loader.extendLoadedEnv interp [(exn_name, apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
-- Just case: we stopped at a breakpoint, we have information about the location
@@ -546,6 +551,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
let
hmi = expectJust "bindLocalsAtBreakpoint" $
lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
+ interp = hscInterp hsc_env
breaks = getModBreaks hmi
info = expectJust "bindLocalsAtBreakpoint2" $
IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
@@ -568,7 +574,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
-- So that we don't fall over in a heap when this happens, just don't
-- bind any free variables instead, and we emit a warning.
mb_hValues <-
- mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
+ mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
@@ -592,11 +598,10 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
names = map idName new_ids
- dl = hsc_loader hsc_env
let fhvs = catMaybes mb_hValues
- Loader.extendLoadedEnv dl (zip names fhvs)
- when result_ok $ Loader.extendLoadedEnv dl [(result_name, apStack_fhv)]
+ Loader.extendLoadedEnv interp (zip names fhvs)
+ when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span, decl)
where
@@ -714,11 +719,12 @@ abandon = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
resume = ic_resume ic
+ interp = hscInterp hsc_env
case resume of
[] -> return False
r:rs -> do
setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
- liftIO $ abandonStmt hsc_env (resumeContext r)
+ liftIO $ abandonStmt interp (resumeContext r)
return True
abandonAll :: GhcMonad m => m Bool
@@ -726,11 +732,12 @@ abandonAll = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
resume = ic_resume ic
+ interp = hscInterp hsc_env
case resume of
[] -> return False
rs -> do
setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
- liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
+ liftIO $ mapM_ (abandonStmt interp. resumeContext) rs
return True
-- -----------------------------------------------------------------------------
@@ -1185,6 +1192,9 @@ compileExprRemote expr = do
-- the resulting HValue.
compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
+ let dflags = hsc_dflags hsc_env
+ let interp = hscInterp hsc_env
+
-- > let _compileParsedExpr = expr
-- Create let stmt from expr to make hscParsedStmt happy.
-- We will ignore the returned [Id], namely [expr_id], and not really
@@ -1202,7 +1212,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
_ -> panic "compileParsedExprRemote"
updateFixityEnv fix_env
- status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
+ status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io)
case status of
EvalComplete _ (EvalSuccess [hval]) -> return hval
EvalComplete _ (EvalException e) ->
@@ -1212,9 +1222,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
compileParsedExpr expr = do
fhv <- compileParsedExprRemote expr
- hsc_env <- getSession
- liftIO $ withInterp hsc_env $ \interp ->
- wormhole interp fhv
+ interp <- hscInterp <$> getSession
+ liftIO $ wormhole interp fhv
-- | Compile an expression, run it and return the result as a Dynamic.
dynCompileExpr :: GhcMonad m => String -> m Dynamic
@@ -1251,23 +1260,25 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
#if defined(HAVE_INTERNAL_INTERPRETER)
-obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case
+obtainTermFromVal hsc_env bound force ty x = case interpInstance interp of
InternalInterp -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
#else
-obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case
+obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of
#endif
ExternalInterp {} -> throwIO (InstallationError
"this operation requires -fno-external-interpreter")
+ where
+ interp = hscInterp hsc_env
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
- hv <- Loader.loadName hsc_env (varName id)
+ hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)
cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
- hv <- Loader.loadName hsc_env (varName id)
+ hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index 4e0372c0b8..d6619e0e2f 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -730,6 +730,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Type obtained: " <> ppr (termType term))
return term
where
+ interp = hscInterp hsc_env
+
go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
-- I believe that my_ty should not have any enclosing
-- foralls, nor any free RuntimeUnk skolems;
@@ -740,18 +742,18 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
- clos <- trIO $ GHCi.getClosure hsc_env a
+ clos <- trIO $ GHCi.getClosure interp a
return (Suspension (tipe (info clos)) my_ty a Nothing)
go !max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
- clos <- trIO $ GHCi.getClosure hsc_env a
+ clos <- trIO $ GHCi.getClosure interp a
case clos of
-- Thunks we may want to force
t | isThunk t && force -> do
traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
- evalRslt <- liftIO $ GHCi.seqHValue hsc_env a
+ evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a
case evalRslt of -- #2950
EvalSuccess _ -> go (pred max_depth) my_ty old_ty a
EvalException ex -> do
@@ -764,7 +766,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
BlackholeClosure{indirectee=ind} -> do
traceTR (text "Following a BLACKHOLE")
- ind_clos <- trIO (GHCi.getClosure hsc_env ind)
+ ind_clos <- trIO (GHCi.getClosure interp ind)
let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
case ind_clos of
-- TSO and BLOCKING_QUEUE cases
@@ -995,6 +997,8 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
return new_ty
where
+ interp = hscInterp hsc_env
+
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
int max_depth <> text " steps")
@@ -1009,7 +1013,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
go my_ty a = do
traceTR (text "go" <+> ppr my_ty)
- clos <- trIO $ GHCi.getClosure hsc_env a
+ clos <- trIO $ GHCi.getClosure interp a
case clos of
BlackholeClosure{indirectee=ind} -> go my_ty ind
IndClosure{indirectee=ind} -> go my_ty ind
diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs
index cc5f289f48..c4b266a534 100644
--- a/compiler/GHC/Runtime/Interpreter.hs
+++ b/compiler/GHC/Runtime/Interpreter.hs
@@ -6,8 +6,10 @@
-- external process or in the current process.
--
module GHC.Runtime.Interpreter
- ( -- * High-level interface to the interpreter
- evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
+ ( module GHC.Runtime.Interpreter.Types
+
+ -- * High-level interface to the interpreter
+ , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
, resumeStmt
, abandonStmt
, evalIO
@@ -42,8 +44,8 @@ module GHC.Runtime.Interpreter
, findSystemLibrary
-- * Lower-level API using messages
- , iservCmd, Message(..), withIServ, withIServ_
- , withInterp, hscInterp, stopInterp
+ , interpCmd, Message(..), withIServ, withIServ_
+ , hscInterp, stopInterp
, iservCall, readIServ, writeIServ
, purgeLookupSymbolCache
, freeHValueRefs
@@ -186,23 +188,17 @@ Other Notes on Remote GHCi
-- 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 msg = withInterp hsc_env $ \case
+interpCmd :: Binary a => Interp -> Message a -> IO a
+interpCmd interp msg = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> run msg -- Just run it directly
#endif
- (ExternalInterp c i) -> withIServ_ c i $ \iserv ->
+ ExternalInterp c i -> withIServ_ c i $ \iserv ->
uninterruptibleMask_ $ -- Note [uninterruptibleMask_]
iservCall iserv msg
--- | Execute an action with the interpreter
---
--- Fails if no target code interpreter is available
-withInterp :: HscEnv -> (Interp -> IO a) -> IO a
-withInterp hsc_env action = action (hscInterp hsc_env)
-
--- | Retrieve the targe code interpreter
+-- | Retrieve the target code interpreter
--
-- Fails if no target code interpreter is available
hscInterp :: HscEnv -> Interp
@@ -210,7 +206,7 @@ hscInterp hsc_env = case hsc_interp hsc_env of
Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")
Just i -> i
--- Note [uninterruptibleMask_ and iservCmd]
+-- Note [uninterruptibleMask_ and interpCmd]
--
-- 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
@@ -261,13 +257,15 @@ withIServ_ conf iserv action = withIServ conf iserv $ \inst ->
-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
-- each of the results.
evalStmt
- :: HscEnv -> Bool -> EvalExpr ForeignHValue
+ :: Interp
+ -> DynFlags -- used by mkEvalOpts
+ -> Bool -- "step" for mkEvalOpts
+ -> EvalExpr ForeignHValue
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-evalStmt hsc_env step foreign_expr = do
- let dflags = hsc_dflags hsc_env
+evalStmt interp dflags step foreign_expr = do
status <- withExpr foreign_expr $ \expr ->
- iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
- handleEvalStatus hsc_env status
+ interpCmd interp (EvalStmt (mkEvalOpts dflags step) expr)
+ handleEvalStatus interp status
where
withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
withExpr (EvalThis fhv) cont =
@@ -278,23 +276,26 @@ evalStmt hsc_env step foreign_expr = do
cont (EvalApp fl' fr')
resumeStmt
- :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
+ :: Interp
+ -> DynFlags -- used by mkEvalOpts
+ -> Bool -- "step" for mkEvalOpts
+ -> ForeignRef (ResumeContext [HValueRef])
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-resumeStmt hsc_env step resume_ctxt = do
- let dflags = hsc_dflags hsc_env
+resumeStmt interp dflags step resume_ctxt = do
status <- withForeignRef resume_ctxt $ \rhv ->
- iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
- handleEvalStatus hsc_env status
+ interpCmd interp (ResumeStmt (mkEvalOpts dflags step) rhv)
+ handleEvalStatus interp status
-abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
-abandonStmt hsc_env resume_ctxt =
+abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
+abandonStmt interp resume_ctxt =
withForeignRef resume_ctxt $ \rhv ->
- iservCmd hsc_env (AbandonStmt rhv)
+ interpCmd interp (AbandonStmt rhv)
handleEvalStatus
- :: HscEnv -> EvalStatus [HValueRef]
+ :: Interp
+ -> EvalStatus [HValueRef]
-> IO (EvalStatus_ [ForeignHValue] [HValueRef])
-handleEvalStatus hsc_env status =
+handleEvalStatus interp status =
case status of
EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
EvalComplete alloc res ->
@@ -302,48 +303,47 @@ handleEvalStatus hsc_env status =
where
addFinalizer (EvalException e) = return (EvalException e)
addFinalizer (EvalSuccess rs) =
- EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
+ EvalSuccess <$> mapM (mkFinalizedHValue interp) rs
-- | Execute an action of type @IO ()@
-evalIO :: HscEnv -> ForeignHValue -> IO ()
-evalIO hsc_env fhv =
+evalIO :: Interp -> ForeignHValue -> IO ()
+evalIO interp fhv =
liftIO $ withForeignRef fhv $ \fhv ->
- iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
+ interpCmd interp (EvalIO fhv) >>= fromEvalResult
-- | Execute an action of type @IO String@
-evalString :: HscEnv -> ForeignHValue -> IO String
-evalString hsc_env fhv =
+evalString :: Interp -> ForeignHValue -> IO String
+evalString interp fhv =
liftIO $ withForeignRef fhv $ \fhv ->
- iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
+ interpCmd interp (EvalString fhv) >>= fromEvalResult
-- | Execute an action of type @String -> IO String@
-evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
-evalStringToIOString hsc_env fhv str =
+evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String
+evalStringToIOString interp fhv str =
liftIO $ withForeignRef fhv $ \fhv ->
- iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
+ interpCmd interp (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 (RemotePtr ())
-mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
+mallocData :: Interp -> ByteString -> IO (RemotePtr ())
+mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres
- :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres hsc_env mod ccs =
- iservCmd hsc_env (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs =
+ interpCmd interp (MkCostCentres mod ccs)
-- | Create a set of BCOs that may be mutually recursive.
-createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
-createBCOs hsc_env rbcos = do
- n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
+createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]
+createBCOs interp dflags rbcos = do
+ n_jobs <- case parMakeCount dflags of
Nothing -> liftIO getNumProcessors
Just n -> return n
-- Serializing ResolvedBCO is expensive, so if we're in parallel mode
-- (-j<n>) parallelise the serialization.
if (n_jobs == 1)
then
- iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
+ interpCmd interp (CreateBCOs [runPut (put rbcos)])
else do
old_caps <- getNumCapabilities
@@ -352,7 +352,7 @@ createBCOs hsc_env rbcos = do
else bracket_ (setNumCapabilities n_jobs)
(setNumCapabilities old_caps)
(void $ evaluate puts)
- iservCmd hsc_env (CreateBCOs puts)
+ interpCmd interp (CreateBCOs puts)
where
puts = parMap doChunk (chunkList 100 rbcos)
@@ -365,56 +365,57 @@ createBCOs hsc_env rbcos = do
parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
where fx = f x; fxs = parMap f xs
-addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
-addSptEntry hsc_env fpr ref =
+addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()
+addSptEntry interp fpr ref =
withForeignRef ref $ \val ->
- iservCmd hsc_env (AddSptEntry fpr val)
+ interpCmd interp (AddSptEntry fpr val)
-costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
-costCentreStackInfo hsc_env ccs =
- iservCmd hsc_env (CostCentreStackInfo ccs)
+costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]
+costCentreStackInfo interp ccs =
+ interpCmd interp (CostCentreStackInfo ccs)
-newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
-newBreakArray hsc_env size = do
- breakArray <- iservCmd hsc_env (NewBreakArray size)
- mkFinalizedHValue hsc_env breakArray
+newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
+newBreakArray interp size = do
+ breakArray <- interpCmd interp (NewBreakArray size)
+ mkFinalizedHValue interp breakArray
-storeBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Int -> IO ()
-storeBreakpoint hsc_env ref ix cnt = do -- #19157
+storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
+storeBreakpoint interp ref ix cnt = do -- #19157
withForeignRef ref $ \breakarray ->
- iservCmd hsc_env (SetupBreakpoint breakarray ix cnt)
+ interpCmd interp (SetupBreakpoint breakarray ix cnt)
-breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
-breakpointStatus hsc_env ref ix =
+breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool
+breakpointStatus interp ref ix =
withForeignRef ref $ \breakarray ->
- iservCmd hsc_env (BreakpointStatus breakarray ix)
+ interpCmd interp (BreakpointStatus breakarray ix)
-getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
-getBreakpointVar hsc_env ref ix =
+getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
+getBreakpointVar interp ref ix =
withForeignRef ref $ \apStack -> do
- mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
- mapM (mkFinalizedHValue hsc_env) mb
+ mb <- interpCmd interp (GetBreakpointVar apStack ix)
+ mapM (mkFinalizedHValue interp) mb
-getClosure :: HscEnv -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
-getClosure hsc_env ref =
+getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
+getClosure interp ref =
withForeignRef ref $ \hval -> do
- mb <- iservCmd hsc_env (GetClosure hval)
- mapM (mkFinalizedHValue hsc_env) mb
+ mb <- interpCmd interp (GetClosure hval)
+ mapM (mkFinalizedHValue interp) mb
-- | Send a Seq message to the iserv process to force a value #2950
-seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ())
-seqHValue hsc_env ref =
- withForeignRef ref $ \hval ->
- iservCmd hsc_env (Seq hval) >>= handleSeqHValueStatus hsc_env
+seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())
+seqHValue interp hsc_env ref =
+ withForeignRef ref $ \hval -> do
+ status <- interpCmd interp (Seq hval)
+ handleSeqHValueStatus interp hsc_env status
-- | Process the result of a Seq or ResumeSeq message. #2950
-handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ())
-handleSeqHValueStatus hsc_env eval_status =
+handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())
+handleSeqHValueStatus interp hsc_env eval_status =
case eval_status of
(EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do
-- A breakpoint was hit; inform the user and tell them
-- which breakpoint was hit.
- resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+ resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
(mkUniqueGrimily mod_uniq)
@@ -425,8 +426,9 @@ handleSeqHValueStatus hsc_env eval_status =
putStrLn ("*** Ignoring breakpoint " ++
(showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp))
-- resume the seq (:force) processing in the iserv process
- withForeignRef resume_ctxt_fhv $ \hval ->
- iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env
+ withForeignRef resume_ctxt_fhv $ \hval -> do
+ status <- interpCmd interp (ResumeSeq hval)
+ handleSeqHValueStatus interp hsc_env status
(EvalComplete _ r) -> return r
where
getSeqBpSpan :: Maybe BreakInfo -> SrcSpan
@@ -444,11 +446,11 @@ handleSeqHValueStatus hsc_env eval_status =
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker
-initObjLinker :: HscEnv -> IO ()
-initObjLinker hsc_env = iservCmd hsc_env InitLinker
+initObjLinker :: Interp -> IO ()
+initObjLinker interp = interpCmd interp InitLinker
-lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
-lookupSymbol hsc_env str = withInterp hsc_env $ \case
+lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol interp str = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
#endif
@@ -472,17 +474,16 @@ lookupSymbol hsc_env str = withInterp hsc_env $ \case
iserv' = iserv {iservLookupSymbolCache = cache'}
return (iserv', Just p)
-lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
-lookupClosure hsc_env str =
- iservCmd hsc_env (LookupClosure str)
+lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
+lookupClosure interp str =
+ interpCmd interp (LookupClosure str)
-purgeLookupSymbolCache :: HscEnv -> IO ()
-purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of
- Nothing -> pure ()
+purgeLookupSymbolCache :: Interp -> IO ()
+purgeLookupSymbolCache interp = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- Just InternalInterp -> pure ()
+ InternalInterp -> pure ()
#endif
- Just (ExternalInterp _ (IServ mstate)) ->
+ ExternalInterp _ (IServ mstate) ->
modifyMVar_ mstate $ \state -> pure $ case state of
IServPending -> state
IServRunning iserv -> IServRunning
@@ -499,42 +500,42 @@ purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of
--
-- Nothing => success
-- Just err_msg => failure
-loadDLL :: HscEnv -> String -> IO (Maybe String)
-loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+loadDLL :: Interp -> String -> IO (Maybe String)
+loadDLL interp str = interpCmd interp (LoadDLL str)
-loadArchive :: HscEnv -> String -> IO ()
-loadArchive hsc_env path = do
+loadArchive :: Interp -> String -> IO ()
+loadArchive interp path = do
path' <- canonicalizePath path -- Note [loadObj and relative paths]
- iservCmd hsc_env (LoadArchive path')
+ interpCmd interp (LoadArchive path')
-loadObj :: HscEnv -> String -> IO ()
-loadObj hsc_env path = do
+loadObj :: Interp -> String -> IO ()
+loadObj interp path = do
path' <- canonicalizePath path -- Note [loadObj and relative paths]
- iservCmd hsc_env (LoadObj path')
+ interpCmd interp (LoadObj path')
-unloadObj :: HscEnv -> String -> IO ()
-unloadObj hsc_env path = do
+unloadObj :: Interp -> String -> IO ()
+unloadObj interp path = do
path' <- canonicalizePath path -- Note [loadObj and relative paths]
- iservCmd hsc_env (UnloadObj path')
+ interpCmd interp (UnloadObj path')
-- Note [loadObj and relative paths]
-- the iserv process might have a different current directory from the
-- GHC process, so we must make paths absolute before sending them
-- over.
-addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
-addLibrarySearchPath hsc_env str =
- fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+addLibrarySearchPath :: Interp -> String -> IO (Ptr ())
+addLibrarySearchPath interp str =
+ fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str)
-removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
-removeLibrarySearchPath hsc_env p =
- iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool
+removeLibrarySearchPath interp p =
+ interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p))
-resolveObjs :: HscEnv -> IO SuccessFlag
-resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+resolveObjs :: Interp -> IO SuccessFlag
+resolveObjs interp = successIf <$> interpCmd interp ResolveObjs
-findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
-findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+findSystemLibrary :: Interp -> String -> IO (Maybe String)
+findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)
-- -----------------------------------------------------------------------------
@@ -588,22 +589,21 @@ spawnIServ conf = do
}
-- | Stop the interpreter
-stopInterp :: HscEnv -> IO ()
-stopInterp hsc_env = case hsc_interp hsc_env of
- Nothing -> pure ()
+stopInterp :: Interp -> IO ()
+stopInterp interp = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- Just InternalInterp -> pure ()
+ InternalInterp -> pure ()
#endif
- Just (ExternalInterp _ (IServ mstate)) ->
- MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
- case state of
- IServPending -> pure state -- already stopped
- IServRunning i -> do
- ex <- getProcessExitCode (iservProcess i)
- if isJust ex
- then pure ()
- else iservCall i Shutdown
- pure IServPending
+ ExternalInterp _ (IServ mstate) ->
+ MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
+ case state of
+ IServPending -> pure state -- already stopped
+ IServRunning i -> do
+ ex <- getProcessExitCode (iservProcess i)
+ if isJust ex
+ then pure ()
+ else iservCall i Shutdown
+ pure IServPending
runWithPipes :: (CreateProcess -> IO ProcessHandle)
-> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
@@ -676,24 +676,23 @@ A ForeignRef is a RemoteRef with a finalizer that will free the
on the GHC side.
The finalizer adds the RemoteRef to the iservPendingFrees list in the
-IServ record. The next call to iservCmd will free any RemoteRefs 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
+IServ record. The next call to interpCmd will free any RemoteRefs in
+the list. It was done this way rather than calling interpCmd directly,
+because I didn't want to have arbitrary threads calling interpCmd. In
principle it would probably be ok, but it seems less hairy this way.
-}
-- | Creates a 'ForeignRef' that will automatically release the
-- 'RemoteRef' when it is no longer referenced.
-mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
-mkFinalizedHValue hsc_env rref = do
+mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)
+mkFinalizedHValue interp rref = do
let hvref = toHValueRef rref
- free <- case hsc_interp hsc_env of
- Nothing -> return (pure ())
+ free <- case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- Just InternalInterp -> return (freeRemoteRef hvref)
+ InternalInterp -> return (freeRemoteRef hvref)
#endif
- Just (ExternalInterp _ (IServ i)) -> return $ modifyMVar_ i $ \state ->
+ ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->
case state of
IServPending {} -> pure state -- already shut down
IServRunning inst -> do
@@ -703,9 +702,9 @@ mkFinalizedHValue hsc_env rref = do
mkForeignRef rref free
-freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs :: Interp -> [HValueRef] -> IO ()
freeHValueRefs _ [] = return ()
-freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)
-- | Convert a 'ForeignRef' to the value it references directly. This
-- only works when the interpreter is running in the same process as
@@ -717,12 +716,12 @@ wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)
-- only works when the interpreter is running in the same process as
-- the compiler, so it fails when @-fexternal-interpreter@ is on.
wormholeRef :: Interp -> RemoteRef a -> IO a
+wormholeRef interp _r = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
-wormholeRef InternalInterp _r = localRef _r
+ InternalInterp -> localRef _r
#endif
-wormholeRef (ExternalInterp {}) _r
- = throwIO (InstallationError
- "this operation requires -fno-external-interpreter")
+ ExternalInterp {}
+ -> throwIO (InstallationError "this operation requires -fno-external-interpreter")
-- -----------------------------------------------------------------------------
-- Misc utils
@@ -749,14 +748,16 @@ getModBreaks hmi
-- | Interpreter uses Profiling way
interpreterProfiled :: Interp -> Bool
+interpreterProfiled interp = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
-interpreterProfiled InternalInterp = hostIsProfiled
+ InternalInterp -> hostIsProfiled
#endif
-interpreterProfiled (ExternalInterp c _) = iservConfProfiled c
+ ExternalInterp c _ -> iservConfProfiled c
-- | Interpreter uses Dynamic way
interpreterDynamic :: Interp -> Bool
+interpreterDynamic interp = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
-interpreterDynamic InternalInterp = hostIsDynamic
+ InternalInterp -> hostIsDynamic
#endif
-interpreterDynamic (ExternalInterp c _) = iservConfDynamic c
+ ExternalInterp c _ -> iservConfDynamic c
diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs
index 5c267f5ec1..e1b33198d0 100644
--- a/compiler/GHC/Runtime/Interpreter/Types.hs
+++ b/compiler/GHC/Runtime/Interpreter/Types.hs
@@ -3,6 +3,7 @@
-- | Types used by the runtime interpreter
module GHC.Runtime.Interpreter.Types
( Interp(..)
+ , InterpInstance(..)
, IServ(..)
, IServInstance(..)
, IServConfig(..)
@@ -11,6 +12,7 @@ module GHC.Runtime.Interpreter.Types
where
import GHC.Prelude
+import GHC.Linker.Types
import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
@@ -21,8 +23,17 @@ import Foreign
import Control.Concurrent
import System.Process ( ProcessHandle, CreateProcess )
--- | Runtime interpreter
-data Interp
+-- | Interpreter
+data Interp = Interp
+ { interpInstance :: !InterpInstance
+ -- ^ Interpreter instance (internal, external)
+
+ , interpLoader :: !Loader
+ -- ^ Interpreter loader
+ }
+
+
+data InterpInstance
= ExternalInterp !IServConfig !IServ -- ^ External interpreter
#if defined(HAVE_INTERNAL_INTERPRETER)
| InternalInterp -- ^ Internal interpreter
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 73ad45c246..4f8f1e6edb 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -28,7 +28,7 @@ import GHC.Driver.Hooks
import GHC.Driver.Plugins
import GHC.Linker.Loader ( loadModule, loadName )
-import GHC.Runtime.Interpreter ( wormhole, withInterp )
+import GHC.Runtime.Interpreter ( wormhole, hscInterp )
import GHC.Runtime.Interpreter.Types
import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn )
@@ -113,11 +113,10 @@ loadFrontendPlugin hsc_env mod_name = do
-- #14335
checkExternalInterpreter :: HscEnv -> IO ()
-checkExternalInterpreter hsc_env
- | Just (ExternalInterp {}) <- hsc_interp hsc_env
- = throwIO (InstallationError "Plugins require -fno-external-interpreter")
- | otherwise
- = pure ()
+checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
+ Just (ExternalInterp {})
+ -> throwIO (InstallationError "Plugins require -fno-external-interpreter")
+ _ -> pure ()
loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
loadPlugin' occ_name plugin_name hsc_env mod_name
@@ -189,20 +188,21 @@ forceLoadTyCon hsc_env con_name = do
getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
mb_hval <- case getValueSafelyHook hooks of
- Nothing -> getHValueSafely hsc_env val_name expected_type
- Just h -> h hsc_env val_name expected_type
+ Nothing -> getHValueSafely interp hsc_env val_name expected_type
+ Just h -> h hsc_env val_name expected_type
case mb_hval of
Nothing -> return Nothing
Just hval -> do
value <- lessUnsafeCoerce logger dflags "getValueSafely" hval
return (Just value)
where
+ interp = hscInterp hsc_env
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
-getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
-getHValueSafely hsc_env val_name expected_type = do
+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)
+getHValueSafely interp hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-- Now look up the names for the value and type constructor in the type environment
mb_val_thing <- lookupType hsc_env val_name
@@ -215,11 +215,13 @@ getHValueSafely hsc_env val_name expected_type = do
then do
-- Link in the module that contains the value, if it has such a module
case nameModule_maybe val_name of
- Just mod -> do loadModule hsc_env mod
+ Just mod -> do loadModule interp hsc_env mod
return ()
Nothing -> return ()
-- Find the value that we just linked in and cast it given that we have proved it's type
- hval <- withInterp hsc_env $ \interp -> loadName hsc_env val_name >>= wormhole interp
+ hval <- do
+ v <- loadName interp hsc_env val_name
+ wormhole interp v
return (Just hval)
else return Nothing
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index e14de72eb5..b2743ece43 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -117,7 +117,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
StgTopStringLit b str -> [Left (b, str)]
flattenBind (StgNonRec b e) = [(b,e)]
flattenBind (StgRec bs) = bs
- stringPtrs <- allocateTopStrings hsc_env strings
+ stringPtrs <- allocateTopStrings interp strings
us <- mkSplitUniqSupply 'y'
(BcM_State{..}, proto_bcos) <-
@@ -134,7 +134,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr proto_bcos)))
- cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
+ cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs)
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
@@ -151,14 +151,16 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
where dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
+ interp = hscInterp hsc_env
+ profile = targetProfile dflags
allocateTopStrings
- :: HscEnv
+ :: Interp
-> [(Id, ByteString)]
-> IO [(Var, RemotePtr ())]
-allocateTopStrings hsc_env topStrings = do
+allocateTopStrings interp topStrings = do
let !(bndrs, strings) = unzip topStrings
- ptrs <- iservCmd hsc_env $ MallocStrings strings
+ ptrs <- interpCmd interp $ MallocStrings strings
return $ zip bndrs ptrs
{-
@@ -169,7 +171,7 @@ literals:
1. Top-level string literal bindings are separated from the rest of the module.
-2. The strings are allocated via iservCmd, in allocateTopStrings
+2. The strings are allocated via interpCmd, in allocateTopStrings
3. The mapping from binders to allocated strings (topStrings) are maintained in
BcM and used when generating code for variable references.
@@ -207,9 +209,11 @@ stgExprToBCOs hsc_env this_mod expr_ty expr
dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode
(ppr proto_bco)
- assembleOneBCO hsc_env proto_bco
+ assembleOneBCO interp profile proto_bco
where dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
+ profile = targetProfile dflags
+ interp = hscInterp hsc_env
-- we need an otherwise unused Id for bytecode generation
dummy_id = mkSysLocal (fsLit "BCO_toplevel")
(mkPseudoUniqueE 0)
@@ -1601,8 +1605,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l
let ffires = primRepToFFIType platform r_rep
ffiargs = map (primRepToFFIType platform) a_reps
- hsc_env <- getHscEnv
- token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+ interp <- hscInterp <$> getHscEnv
+ token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)
recordFFIBc token
let
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 456578f729..9c84c98ff9 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -77,7 +77,6 @@ import GHC.Iface.Load
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.Types
import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
import GHC.Rename.Expr
@@ -797,11 +796,11 @@ runAnnotation target expr = do
convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized)
convertAnnotationWrapper fhv = do
interp <- tcGetInterp
- case interp of
+ case interpInstance interp of
ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
- annotation_wrapper <- liftIO $ wormhole InternalInterp fhv
+ annotation_wrapper <- liftIO $ wormhole interp fhv
return $ Right $
case unsafeCoerce annotation_wrapper of
AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
@@ -836,7 +835,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
withForeignRefs (x : xs) f = withForeignRef x $ \r ->
withForeignRefs xs $ \rs -> f (r : rs)
interp <- tcGetInterp
- case interp of
+ case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
@@ -1382,7 +1381,7 @@ addModFinalizerRef finRef = do
finishTH :: TcM ()
finishTH = do
hsc_env <- getTopEnv
- case hsc_interp hsc_env of
+ case interpInstance <$> hsc_interp hsc_env of
Nothing -> pure ()
#if defined(HAVE_INTERNAL_INTERPRETER)
Just InternalInterp -> pure ()
@@ -1407,11 +1406,11 @@ runTHDec = runTH THDec
runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
runTH ty fhv = do
interp <- tcGetInterp
- case interp of
+ case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
-- Run it in the local TcM
- hv <- liftIO $ wormhole InternalInterp fhv
+ hv <- liftIO $ wormhole interp fhv
r <- runQuasi (unsafeCoerce hv :: TH.Q a)
return r
#endif
@@ -1520,8 +1519,8 @@ getTHState i = do
case th_state of
Just rhv -> return rhv
Nothing -> do
- hsc_env <- getTopEnv
- fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
+ interp <- tcGetInterp
+ fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH
writeTcRef (tcg_th_remote_state tcg) (Just fhv)
return fhv
@@ -1549,8 +1548,8 @@ handleTHMessage msg = case msg of
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
AddModFinalizer r -> do
- hsc_env <- getTopEnv
- wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
+ interp <- hscInterp <$> getTopEnv
+ wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index ea2c8f25bb..494ab29021 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -41,7 +41,6 @@ import GHC.Runtime.Debugger
-- The GHC interface
import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
import GHCi.BreakArray( breakOn, breakOff )
import GHC.ByteCode.Types
@@ -1476,8 +1475,8 @@ getCallStackAtCurrentBreakpoint = do
case resumes of
[] -> return Nothing
(r:_) -> do
- hsc_env <- GHC.getSession
- Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))
+ interp <- hscInterp <$> GHC.getSession
+ Just <$> liftIO (costCentreStackInfo interp (GHC.resumeCCS r))
getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)
getCurrentBreakModule = do
@@ -1605,12 +1604,12 @@ changeDirectory dir = do
liftIO $ setCurrentDirectory dir'
-- With -fexternal-interpreter, we have to change the directory of the subprocess too.
-- (this gives consistent behaviour with and without -fexternal-interpreter)
- hsc_env <- GHC.getSession
- case hsc_interp hsc_env of
- Just (ExternalInterp {}) -> do
+ interp <- hscInterp <$> GHC.getSession
+ case interpInstance interp of
+ ExternalInterp {} -> do
fhv <- compileGHCiExpr $
"System.Directory.setCurrentDirectory " ++ show dir'
- liftIO $ evalIO hsc_env fhv
+ liftIO $ evalIO interp fhv
_ -> pure ()
trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
@@ -1741,8 +1740,8 @@ runMacro
-> String
-> m Bool
runMacro fun s = do
- hsc_env <- GHC.getSession
- str <- liftIO $ evalStringToIOString hsc_env fun s
+ interp <- hscInterp <$> GHC.getSession
+ str <- liftIO $ evalStringToIOString interp fun s
enqueueCommands (lines str)
return False
@@ -1775,8 +1774,8 @@ cmdCmd str = handleSourceError GHC.printException $ do
let new_expr = step `mkHsApp` expr
hv <- GHC.compileParsedExprRemote new_expr
- hsc_env <- GHC.getSession
- cmds <- liftIO $ evalString hsc_env hv
+ interp <- hscInterp <$> GHC.getSession
+ cmds <- liftIO $ evalString interp hv
enqueueCommands (lines cmds)
-- | Generate a typed ghciStepIO expression
@@ -3054,6 +3053,7 @@ newDynFlags interactive_only minus_opts = do
-- the new packages.
hsc_env <- GHC.getSession
let dflags2 = hsc_dflags hsc_env
+ let interp = hscInterp hsc_env
when (packageFlagsChanged dflags2 dflags0) $ do
when (verbosity dflags2 > 0) $
liftIO . putStrLn $
@@ -3062,7 +3062,7 @@ newDynFlags interactive_only minus_opts = do
clearAllTargets
when must_reload $ do
let units = preloadUnits (hsc_units hsc_env)
- liftIO $ Loader.loadPackages hsc_env units
+ liftIO $ Loader.loadPackages interp hsc_env units
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad False []
-- and copy the package flags to the interactive DynFlags
@@ -3081,7 +3081,7 @@ newDynFlags interactive_only minus_opts = do
, cmdlineFrameworks = newCLFrameworks } }
when (not (null newLdInputs && null newCLFrameworks)) $
- liftIO $ Loader.loadCmdLineLibs hsc_env'
+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
return ()
@@ -3183,7 +3183,7 @@ showCmd str = do
, action "modules" $ showModules
, action "bindings" $ showBindings
, action "linker" $ do
- msg <- liftIO $ Loader.showLoaderState (hsc_loader hsc_env)
+ msg <- liftIO $ Loader.showLoaderState (hscInterp hsc_env)
putLogMsgM NoReason SevDump noSrcSpan msg
, action "breaks" $ showBkptTable
, action "context" $ showContext
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 80d4539849..11d575524f 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -468,8 +468,8 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
revertCAFs :: GhciMonad m => m ()
revertCAFs = do
- hsc_env <- GHC.getSession
- liftIO $ iservCmd hsc_env RtsRevertCAFs
+ interp <- hscInterp <$> GHC.getSession
+ liftIO $ interpCmd interp RtsRevertCAFs
s <- getGHCiState
when (not (ghc_e s)) turnOffBuffering
-- Have to turn off buffering again, because we just
@@ -495,8 +495,8 @@ initInterpBuffering = do
flushInterpBuffers :: GhciMonad m => m ()
flushInterpBuffers = do
st <- getGHCiState
- hsc_env <- GHC.getSession
- liftIO $ evalIO hsc_env (flushStdHandles st)
+ interp <- hscInterp <$> GHC.getSession
+ liftIO $ evalIO interp (flushStdHandles st)
-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
turnOffBuffering :: GhciMonad m => m ()
@@ -506,8 +506,8 @@ turnOffBuffering = do
turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
turnOffBuffering_ fhv = do
- hsc_env <- getSession
- liftIO $ evalIO hsc_env fhv
+ interp <- hscInterp <$> getSession
+ liftIO $ evalIO interp fhv
mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
mkEvalWrapper progname args =
diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs
index 6529dd654d..ae4bd7562a 100644
--- a/testsuite/tests/rts/linker/LinkerUnload.hs
+++ b/testsuite/tests/rts/linker/LinkerUnload.hs
@@ -5,6 +5,7 @@ import GHC.Unit.State
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Backend
+import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Loader
import System.Environment
import GHC.Utils.Monad ( MonadIO(..) )
@@ -20,4 +21,4 @@ loadPackages = do
, ghcLink = LinkInMemory }
setSessionDynFlags dflags'
hsc_env <- getSession
- liftIO $ Loader.loadPackages hsc_env (preloadUnits (hsc_units hsc_env))
+ liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env (preloadUnits (hsc_units hsc_env))
View Lorry Controller Status