diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-04-28 16:47:48 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-04-30 23:22:13 -0400 |
commit | c7ca3619e2544d7627c082b6e5bbe57a6b8abc05 (patch) | |
tree | 2e5cdf0b9a7f91123d9edff6c1c0749f69ae58d0 /compiler | |
parent | c0c0b4e0d3112a9ee294d1c3b7849b68b0bebfc8 (diff) | |
download | haskell-c7ca3619e2544d7627c082b6e5bbe57a6b8abc05.tar.gz |
Interpreter: replace DynFlags with EvalOpts/BCOOpts
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Driver/Config.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Linker/Loader.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Runtime/Interpreter.hs | 43 |
4 files changed, 68 insertions, 45 deletions
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs index 6bd8988add..cd3b165a65 100644 --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -3,6 +3,8 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts , initParserOpts + , initBCOOpts + , initEvalOpts ) where @@ -12,6 +14,11 @@ import GHC.Driver.Session import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt import GHC.Parser.Lexer +import GHC.Runtime.Interpreter (BCOOpts(..)) +import GHCi.Message (EvalOpts(..)) + +import GHC.Conc (getNumProcessors) +import Control.Monad.IO.Class -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts @@ -36,3 +43,24 @@ initParserOpts = <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream <*> const True + +-- | Extract BCO options from DynFlags +initBCOOpts :: DynFlags -> IO BCOOpts +initBCOOpts dflags = do + -- Serializing ResolvedBCO is expensive, so if we're in parallel mode + -- (-j<n>) parallelise the serialization. + n_jobs <- case parMakeCount dflags of + Nothing -> liftIO getNumProcessors + Just n -> return n + return $ BCOOpts n_jobs + +-- | Extract GHCi options from DynFlags and step +initEvalOpts :: DynFlags -> Bool -> EvalOpts +initEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = step + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags + } + diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 735f6ceb16..2137725343 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -44,6 +44,7 @@ import GHC.Driver.Phases import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Config import GHC.Tc.Utils.Monad @@ -565,11 +566,11 @@ loadExpr interp hsc_env span root_ul_bco = do 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] + bco_opts <- initBCOOpts (hsc_dflags hsc_env) + [root_hvref] <- createBCOs interp bco_opts [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] @@ -794,13 +795,13 @@ loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do ce = closure_env pls -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs dflags interp ie ce [cbc] + bco_opts <- initBCOOpts (hsc_dflags hsc_env) + new_bindings <- linkSomeBCOs bco_opts 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 @@ -843,7 +844,7 @@ loadModules interp hsc_env pls linkables let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) - let dflags = hsc_dflags hsc_env + bco_opts <- initBCOOpts (hsc_dflags hsc_env) -- Load objects first; they can't depend on BCOs (pls1, ok_flag) <- loadObjects interp hsc_env pls objs @@ -851,7 +852,7 @@ loadModules interp hsc_env pls linkables if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs dflags interp pls1 bcos + pls2 <- dynLinkBCOs bco_opts interp pls1 bcos return (pls2, Succeeded) @@ -1008,8 +1009,8 @@ rmDupLinkables already ls ********************************************************************* -} -dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState -dynLinkBCOs dflags interp pls bcos = do +dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState +dynLinkBCOs bco_opts interp pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -1024,7 +1025,7 @@ dynLinkBCOs dflags interp pls bcos = do gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs + names_and_refs <- linkSomeBCOs bco_opts 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 @@ -1038,7 +1039,7 @@ dynLinkBCOs dflags interp pls bcos = do itbl_env = final_ie } -- Link a bunch of BCOs and return references to their values -linkSomeBCOs :: DynFlags +linkSomeBCOs :: BCOOpts -> Interp -> ItblEnv -> ClosureEnv @@ -1048,7 +1049,7 @@ linkSomeBCOs :: DynFlags -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods [] +linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of @@ -1063,7 +1064,7 @@ linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods [] bco_ix = mkNameEnv (zip names [0..]) resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco | (breakarray, bco) <- flat ] - hvrefs <- createBCOs interp dflags resolved + hvrefs <- createBCOs interp bco_opts resolved return (zip names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs' diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 80868c1eea..6880c2fec7 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -54,6 +54,7 @@ import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Config import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi @@ -228,8 +229,9 @@ execStmt' stmt stmt_text ExecOptions{..} = do status <- withVirtualCWD $ - liftIO $ - evalStmt interp idflags' (isStep execSingleStep) (execWrap hval) + liftIO $ do + let eval_opts = initEvalOpts idflags' (isStep execSingleStep) + evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -309,7 +311,7 @@ emptyHistory :: Int -> BoundedList History emptyHistory size = nilBL size handleRunStatus :: GhcMonad m - => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] + => SingleStep -> String -> ([TyThing],GlobalRdrEnv) -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> BoundedList History -> m ExecResult @@ -343,7 +345,8 @@ handleRunStatus step expr bindings final_ids status history !history' = mkHistory hsc_env apStack_fhv bi `consBL` history -- history is strict, otherwise our BoundedList is pointless. fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - status <- liftIO $ GHCi.resumeStmt interp dflags True fhv + let eval_opts = initEvalOpts dflags True + status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv handleRunStatus RunAndLogSteps expr bindings final_ids status history' | otherwise @@ -443,7 +446,8 @@ 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 interp dflags (isStep step) fhv + let eval_opts = initEvalOpts dflags (isStep step) + status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist hist' = case mb_brkpt of Nothing -> prevHistoryLst @@ -1212,7 +1216,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io) + let eval_opts = initEvalOpts dflags False + status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval EvalComplete _ (EvalException e) -> diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 25674396d3..6b6576ed5b 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -11,6 +11,7 @@ module GHC.Runtime.Interpreter ( module GHC.Runtime.Interpreter.Types -- * High-level interface to the interpreter + , BCOOpts (..) , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) , resumeStmt , abandonStmt @@ -53,7 +54,6 @@ module GHC.Runtime.Interpreter , freeHValueRefs , mkFinalizedHValue , wormhole, wormholeRef - , mkEvalOpts , fromEvalResult ) where @@ -62,7 +62,6 @@ import GHC.Prelude import GHC.IO (catchException) import GHC.Driver.Ppr (showSDoc) import GHC.Driver.Env -import GHC.Driver.Session import GHC.Runtime.Interpreter.Types import GHCi.Message @@ -120,7 +119,7 @@ import System.Posix as Posix #endif import System.Directory import System.Process -import GHC.Conc (getNumProcessors, pseq, par) +import GHC.Conc (pseq, par) {- Note [Remote GHCi] @@ -261,13 +260,12 @@ withIServ_ conf iserv action = withIServ conf iserv $ \inst -> -- each of the results. evalStmt :: Interp - -> DynFlags -- used by mkEvalOpts - -> Bool -- "step" for mkEvalOpts + -> EvalOpts -> EvalExpr ForeignHValue -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -evalStmt interp dflags step foreign_expr = do +evalStmt interp opts foreign_expr = do status <- withExpr foreign_expr $ \expr -> - interpCmd interp (EvalStmt (mkEvalOpts dflags step) expr) + interpCmd interp (EvalStmt opts expr) handleEvalStatus interp status where withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a @@ -280,13 +278,12 @@ evalStmt interp dflags step foreign_expr = do resumeStmt :: Interp - -> DynFlags -- used by mkEvalOpts - -> Bool -- "step" for mkEvalOpts + -> EvalOpts -> ForeignRef (ResumeContext [HValueRef]) -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) -resumeStmt interp dflags step resume_ctxt = do +resumeStmt interp opts resume_ctxt = do status <- withForeignRef resume_ctxt $ \rhv -> - interpCmd interp (ResumeStmt (mkEvalOpts dflags step) rhv) + interpCmd interp (ResumeStmt opts rhv) handleEvalStatus interp status abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO () @@ -336,18 +333,18 @@ mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCent mkCostCentres interp mod ccs = interpCmd interp (MkCostCentres mod ccs) +newtype BCOOpts = BCOOpts + { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization + } + -- | Create a set of BCOs that may be mutually recursive. -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. +createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef] +createBCOs interp opts rbcos = do + let n_jobs = bco_n_jobs opts + -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel if (n_jobs == 1) then interpCmd interp (CreateBCOs [runPut (put rbcos)]) - else do old_caps <- getNumCapabilities if old_caps == n_jobs @@ -729,14 +726,6 @@ wormholeRef interp _r = case interpInstance interp of -- ----------------------------------------------------------------------------- -- Misc utils -mkEvalOpts :: DynFlags -> Bool -> EvalOpts -mkEvalOpts dflags step = - EvalOpts - { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step - , breakOnException = gopt Opt_BreakOnException dflags - , breakOnError = gopt Opt_BreakOnError dflags } - fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a |