CoreToStg: purge `DynFlags`.

4 files changed, 86 insertions, 55 deletions

diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 5ba4decd4f..9446e1186e 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -14,13 +14,10 @@
 -- And, as we have the info in hand, we may convert some lets to
 -- let-no-escapes.
 
-module GHC.CoreToStg ( coreToStg ) where
+module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
 
 import GHC.Prelude
 
-import GHC.Driver.Session
-import GHC.Driver.Config.Stg.Debug
-
 import GHC.Core
 import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
                         , exprIsTickedString_maybe )
@@ -50,6 +47,7 @@ import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
 
 import GHC.Unit.Module
 import GHC.Data.FastString
+import GHC.Platform        ( Platform )
 import GHC.Platform.Ways
 import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
 
@@ -62,7 +60,6 @@ import GHC.Utils.Trace
 
 import Control.Monad (ap)
 import Data.Maybe (fromMaybe)
-import Data.Tuple (swap)
 
 -- Note [Live vs free]
 -- ~~~~~~~~~~~~~~~~~~~
@@ -235,24 +232,29 @@ import Data.Tuple (swap)
 -- --------------------------------------------------------------
 
 
-coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
+coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
           -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
-coreToStg dflags this_mod ml pgm
+coreToStg opts@CoreToStgOpts
+  { coreToStg_ways = ways
+  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
+  , coreToStg_InfoTableMap = opt_InfoTableMap
+  , coreToStg_stgDebugOpts = stgDebugOpts
+  } this_mod ml pgm
   = (pgm'', denv, final_ccs)
   where
     (_, (local_ccs, local_cc_stacks), pgm')
-      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+      = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm
 
     -- See Note [Mapping Info Tables to Source Positions]
-    (!pgm'', !denv) =
-        if gopt Opt_InfoTableMap dflags
-          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'
-          else (pgm', emptyInfoTableProvMap)
+    (!pgm'', !denv)
+      | opt_InfoTableMap
+      = collectDebugInformation stgDebugOpts ml pgm'
+      | otherwise = (pgm', emptyInfoTableProvMap)
 
-    prof = ways dflags `hasWay` WayProf
+    prof = hasWay ways WayProf
 
     final_ccs
-      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+      | prof && opt_AutoSccsOnIndividualCafs
       = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
       | prof
       = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
@@ -262,7 +264,7 @@ coreToStg dflags this_mod ml pgm
     (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
 
 coreTopBindsToStg
-    :: DynFlags
+    :: CoreToStgOpts
     -> Module
     -> IdEnv HowBound           -- environment for the bindings
     -> CollectedCCs
@@ -271,17 +273,17 @@ coreTopBindsToStg
 
 coreTopBindsToStg _      _        env ccs []
   = (env, ccs, [])
-coreTopBindsToStg dflags this_mod env ccs (b:bs)
+coreTopBindsToStg opts this_mod env ccs (b:bs)
   | NonRec _ rhs <- b, isTyCoArg rhs
-  = coreTopBindsToStg dflags this_mod env1 ccs1 bs
+  = coreTopBindsToStg opts this_mod env1 ccs1 bs
   | otherwise
   = (env2, ccs2, b':bs')
   where
-    (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b
-    (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs
+    (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b
+    (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs
 
 coreTopBindToStg
-        :: DynFlags
+        :: CoreToStgOpts
         -> Module
         -> IdEnv HowBound
         -> CollectedCCs
@@ -297,16 +299,18 @@ coreTopBindToStg _ _ env ccs (NonRec id e)
         how_bound = LetBound TopLet 0
     in (env', ccs, StgTopStringLit id str)
 
-coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
+coreTopBindToStg opts@CoreToStgOpts
+  { coreToStg_platform = platform
+  } this_mod env ccs (NonRec id rhs)
   = let
         env'      = extendVarEnv env id how_bound
         how_bound = LetBound TopLet $! manifestArity rhs
 
-        (stg_rhs, ccs') =
-            initCts dflags env $
-              coreToTopStgRhs dflags ccs this_mod (id,rhs)
+        (ccs', (id', stg_rhs)) =
+            initCts platform env $
+              coreToTopStgRhs opts this_mod ccs (id,rhs)
 
-        bind = StgTopLifted $ StgNonRec id stg_rhs
+        bind = StgTopLifted $ StgNonRec id' stg_rhs
     in
       -- NB: previously the assertion printed 'rhs' and 'bind'
       --     as well as 'id', but that led to a black hole
@@ -314,42 +318,38 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
       --     assertion again!
     (env', ccs', bind)
 
-coreTopBindToStg dflags this_mod env ccs (Rec pairs)
+coreTopBindToStg opts@CoreToStgOpts
+  { coreToStg_platform = platform
+  } this_mod env ccs (Rec pairs)
   = assert (not (null pairs)) $
     let
-        binders = map fst pairs
-
         extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                      | (b, rhs) <- pairs ]
         env' = extendVarEnvList env extra_env'
 
         -- generate StgTopBindings and CAF cost centres created for CAFs
         (ccs', stg_rhss)
-          = initCts dflags env' $
-              mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
-                         ccs
-                         pairs
-        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
+          = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
+        bind = StgTopLifted $ StgRec stg_rhss
     in
     (env', ccs', bind)
 
 coreToTopStgRhs
-        :: DynFlags
-        -> CollectedCCs
+        :: CoreToStgOpts
         -> Module
+        -> CollectedCCs
         -> (Id,CoreExpr)
-        -> CtsM (StgRhs, CollectedCCs)
+        -> CtsM (CollectedCCs, (Id, StgRhs))
 
-coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
+coreToTopStgRhs opts this_mod ccs (bndr, rhs)
   = do { new_rhs <- coreToPreStgRhs rhs
 
        ; let (stg_rhs, ccs') =
-               mkTopStgRhs dflags this_mod ccs bndr new_rhs
+               mkTopStgRhs opts this_mod ccs bndr new_rhs
              stg_arity =
                stgRhsArity stg_rhs
 
-       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,
-                 ccs') }
+       ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }
   where
         -- It's vital that the arity on a top-level Id matches
         -- the arity of the generated STG binding, else an importing
@@ -616,7 +616,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         -- or foreign call.
         -- Wanted: a better solution than this hacky warning
 
-    platform <- targetPlatform <$> getDynFlags
+    platform <- getPlatform
     let
         arg_rep = typePrimRep (exprType arg)
         stg_arg_rep = typePrimRep (stgArgType stg_arg)
@@ -708,10 +708,14 @@ coreToPreStgRhs expr
 
 -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
 -- appended to `CollectedCCs` argument.
-mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
+mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
             -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
 
-mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
+mkTopStgRhs CoreToStgOpts
+  { coreToStg_platform = platform
+  , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
+  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
+  } this_mod ccs bndr (PreStgRhs bndrs rhs)
   | not (null bndrs)
   = -- The list of arguments is non-empty, so not CAF
     ( StgRhsClosure noExtFieldSilent
@@ -724,14 +728,14 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
   -- so this is not a function binding
   | StgConApp con mn args _ <- unticked_rhs
   , -- Dynamic StgConApps are updatable
-    not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)
+    not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
   = -- CorePrep does this right, but just to make sure
     assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
               (ppr bndr $$ ppr con $$ ppr args)
     ( StgRhsCon dontCareCCS con mn ticks args, ccs )
 
   -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
-  | gopt Opt_AutoSccsOnIndividualCafs dflags
+  | opt_AutoSccsOnIndividualCafs
   = ( StgRhsClosure noExtFieldSilent
                     caf_ccs
                     upd_flag [] rhs
@@ -855,7 +859,7 @@ isPAP env _               = False
 -- *down*.
 
 newtype CtsM a = CtsM
-    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
+    { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
              -> IdEnv HowBound
              -> a
     }
@@ -893,8 +897,8 @@ data LetInfo
 
 -- The std monad functions:
 
-initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
-initCts dflags env m = unCtsM m dflags env
+initCts :: Platform -> IdEnv HowBound -> CtsM a -> a
+initCts platform env m = unCtsM m platform env
 
 
 
@@ -905,8 +909,8 @@ returnCts :: a -> CtsM a
 returnCts e = CtsM $ \_ _ -> e
 
 thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
-thenCts m k = CtsM $ \dflags env
-  -> unCtsM (k (unCtsM m dflags env)) dflags env
+thenCts m k = CtsM $ \platform env
+  -> unCtsM (k (unCtsM m platform env)) platform env
 
 instance Applicative CtsM where
     pure = returnCts
@@ -915,15 +919,15 @@ instance Applicative CtsM where
 instance Monad CtsM where
     (>>=)  = thenCts
 
-instance HasDynFlags CtsM where
-    getDynFlags = CtsM $ \dflags _ -> dflags
+getPlatform :: CtsM Platform
+getPlatform = CtsM const
 
 -- Functions specific to this monad:
 
 extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
 extendVarEnvCts ids_w_howbound expr
-   =    CtsM $   \dflags env
-   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
+   =    CtsM $   \platform env
+   -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)
 
 lookupVarCts :: Id -> CtsM HowBound
 lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
@@ -995,3 +999,12 @@ stgArity :: Id -> HowBound -> Arity
 stgArity _ (LetBound _ arity) = arity
 stgArity f ImportBound        = idArity f
 stgArity _ LambdaBound        = 0
+
+data CoreToStgOpts = CoreToStgOpts
+  { coreToStg_platform :: Platform
+  , coreToStg_ways :: Ways
+  , coreToStg_AutoSccsOnIndividualCafs :: Bool
+  , coreToStg_InfoTableMap :: Bool
+  , coreToStg_ExternalDynamicRefs :: Bool
+  , coreToStg_stgDebugOpts :: StgDebugOpts
+  }
diff --git a/compiler/GHC/Driver/Config/CoreToStg.hs b/compiler/GHC/Driver/Config/CoreToStg.hs
new file mode 100644
index 0000000000..f73f8fafc7
--- /dev/null
+++ b/compiler/GHC/Driver/Config/CoreToStg.hs
@@ -0,0 +1,16 @@
+module GHC.Driver.Config.CoreToStg where
+
+import GHC.Driver.Config.Stg.Debug
+import GHC.Driver.Session
+
+import GHC.CoreToStg
+
+initCoreToStgOpts :: DynFlags -> CoreToStgOpts
+initCoreToStgOpts dflags = CoreToStgOpts
+  { coreToStg_platform = targetPlatform dflags
+  , coreToStg_ways = ways dflags
+  , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags
+  , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags
+  , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+  , coreToStg_stgDebugOpts = initStgDebugOpts dflags
+  }
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index e5a1d915fc..a130fed062 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -123,6 +123,7 @@ import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
 import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )
 import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
 import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
+import GHC.Driver.Config.CoreToStg
 import GHC.Driver.Config.CoreToStg.Prep
 import GHC.Driver.Config.Logger   (initLogFlags)
 import GHC.Driver.Config.Parser   (initParserOpts)
@@ -2141,7 +2142,7 @@ myCoreToStg :: Logger -> DynFlags -> InteractiveContext
 myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
     let (stg_binds, denv, cost_centre_info)
          = {-# SCC "Core2Stg" #-}
-           coreToStg dflags this_mod ml prepd_binds
+           coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds
 
     (stg_binds_with_fvs,stg_cg_info)
         <- {-# SCC "Stg2Stg" #-}
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 39e5e5f1ea..ebb39582a6 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -407,6 +407,7 @@ Library
         GHC.Driver.Config.Core.Opt.Simplify
         GHC.Driver.Config.Core.Opt.WorkWrap
         GHC.Driver.Config.Core.Rules
+        GHC.Driver.Config.CoreToStg
         GHC.Driver.Config.CoreToStg.Prep
         GHC.Driver.Config.Diagnostic
         GHC.Driver.Config.Finder