diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-03-15 18:19:16 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-23 13:01:15 -0400 |
commit | 05c5c0549bee022be84344cef46f0eded5564c3b (patch) | |
tree | 1c50af925a1993c602b78c96155126b65c477af7 | |
parent | 7a6577513633b943202fc82ab7aa162e1d293c0a (diff) | |
download | haskell-05c5c0549bee022be84344cef46f0eded5564c3b.tar.gz |
Move loader state into Interp
The loader state was stored into HscEnv. As we need to have two
interpreters and one loader state per interpreter in #14335, it's
natural to make the loader state a field of the Interp type.
As a side effect, many functions now only require a Interp parameter
instead of HscEnv. Sadly we can't fully free GHC.Linker.Loader of HscEnv
yet because the loader is initialised lazily from the HscEnv the first
time it is used. This is left as future work.
HscEnv may not contain an Interp value (i.e. hsc_interp :: Maybe Interp).
So a side effect of the previous side effect is that callers of the
modified functions now have to provide an Interp. It is satisfying as it
pushes upstream the handling of the case where HscEnv doesn't contain an
Interpreter. It is better than raising a panic (less partial functions,
"parse, don't validate", etc.).
-rw-r--r-- | compiler/GHC.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/ByteCode/Asm.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/ByteCode/InfoTable.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/ByteCode/Linker.hs | 125 | ||||
-rw-r--r-- | compiler/GHC/Driver/Env/Types.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Linker/Loader.hs | 454 | ||||
-rw-r--r-- | compiler/GHC/Linker/MacOS.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Debugger.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 73 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Heap/Inspect.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 301 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter/Types.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Loader.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/StgToByteCode.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 21 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 28 | ||||
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/rts/linker/LinkerUnload.hs | 3 |
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)) |