Interpreter: replace DynFlags with EvalOpts/BCOOpts

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