summaryrefslogtreecommitdiff
path: root/compiler/GHC/Runtime
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-03-15 18:19:16 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-23 13:01:15 -0400
commit05c5c0549bee022be84344cef46f0eded5564c3b (patch)
tree1c50af925a1993c602b78c96155126b65c477af7 /compiler/GHC/Runtime
parent7a6577513633b943202fc82ab7aa162e1d293c0a (diff)
downloadhaskell-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.).
Diffstat (limited to 'compiler/GHC/Runtime')
-rw-r--r--compiler/GHC/Runtime/Debugger.hs10
-rw-r--r--compiler/GHC/Runtime/Eval.hs73
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs14
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs301
-rw-r--r--compiler/GHC/Runtime/Interpreter/Types.hs15
-rw-r--r--compiler/GHC/Runtime/Loader.hs26
6 files changed, 234 insertions, 205 deletions
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