DynFlags: add OptCoercionOpts

Use OptCoercionOpts to avoid threading DynFlags all the way down to
GHC.Core.Coercion.Opt

4 files changed, 47 insertions, 21 deletions

diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index fb2bde23d1..b9656a45bb 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -2,13 +2,17 @@
 
 {-# LANGUAGE CPP #-}
 
-module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where
+module GHC.Core.Coercion.Opt
+   ( optCoercion
+   , checkAxInstCo
+   , OptCoercionOpts (..)
+   )
+where
 
 #include "HsVersions.h"
 
 import GHC.Prelude
 
-import GHC.Driver.Session
 import GHC.Driver.Ppr
 
 import GHC.Core.TyCo.Rep
@@ -109,12 +113,17 @@ So we substitute the coercion variable c for the coercion
 (h1 ~N (n1; h2; sym n2)) in g.
 -}
 
-optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo
+-- | Coercion optimisation options
+newtype OptCoercionOpts = OptCoercionOpts
+   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)
+   }
+
+optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo
 -- ^ optCoercion applies a substitution to a coercion,
 --   *and* optimises it to reduce its size
-optCoercion dflags env co
-  | hasNoOptCoercion dflags = substCo env co
-  | otherwise               = optCoercion' env co
+optCoercion opts env co
+  | optCoercionEnabled opts = optCoercion' env co
+  | otherwise               = substCo env co
 
 optCoercion' :: TCvSubst -> Coercion -> NormalCo
 optCoercion' env co
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 9ae25ad8f8..d0477f505a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -1150,8 +1150,8 @@ simplCoercionF env co cont
 
 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
 simplCoercion env co
-  = do { dflags <- getDynFlags
-       ; let opt_co = optCoercion dflags (getTCvSubst env) co
+  = do { opts <- getOptCoercionOpts
+       ; let opt_co = optCoercion opts (getTCvSubst env) co
        ; seqCo opt_co `seq` return opt_co }
 
 -----------------------------------
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 1d1d401bcf..9fc51af32e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -10,7 +10,7 @@ module GHC.Core.Opt.Simplify.Monad (
         -- The monad
         SimplM,
         initSmpl, traceSmpl,
-        getSimplRules, getFamEnvs,
+        getSimplRules, getFamEnvs, getOptCoercionOpts,
 
         -- Unique supply
         MonadUnique(..), newId, newJoinId,
@@ -31,6 +31,7 @@ import GHC.Core.Type       ( Type, Mult )
 import GHC.Core.FamInstEnv ( FamInstEnv )
 import GHC.Core            ( RuleEnv(..) )
 import GHC.Core.Utils      ( mkLamTypes )
+import GHC.Core.Coercion.Opt
 import GHC.Types.Unique.Supply
 import GHC.Driver.Session
 import GHC.Core.Opt.Monad
@@ -78,9 +79,13 @@ pattern SM m <- SM' m
 
 data SimplTopEnv
   = STE { st_flags     :: DynFlags
-        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run
+        , st_max_ticks :: IntWithInf  -- ^ Max #ticks in this simplifier run
         , st_rules     :: RuleEnv
-        , st_fams      :: (FamInstEnv, FamInstEnv) }
+        , st_fams      :: (FamInstEnv, FamInstEnv)
+
+        , st_co_opt_opts :: !OptCoercionOpts
+            -- ^ Coercion optimiser options
+        }
 
 initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
          -> UniqSupply          -- No init count; set to 0
@@ -95,7 +100,11 @@ initSmpl dflags rules fam_envs us size m
   where
     env = STE { st_flags = dflags, st_rules = rules
               , st_max_ticks = computeMaxTicks dflags size
-              , st_fams = fam_envs }
+              , st_fams = fam_envs
+              , st_co_opt_opts = OptCoercionOpts
+                  { optCoercionEnabled = not (hasNoOptCoercion dflags)
+                  }
+              }
 
 computeMaxTicks :: DynFlags -> Int -> IntWithInf
 -- Compute the max simplifier ticks as
@@ -195,6 +204,9 @@ getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
 getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
 
+getOptCoercionOpts :: SimplM OptCoercionOpts
+getOptCoercionOpts = SM (\st_env us sc -> return (st_co_opt_opts st_env, us, sc))
+
 newId :: FastString -> Mult -> Type -> SimplM Id
 newId fs w ty = do uniq <- getUniqueM
                    return (mkSysLocalOrCoVar fs uniq w ty)
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index b040626f63..300588e0fc 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -42,7 +42,7 @@ import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Core.DataCon
 import GHC.Types.Demand( etaConvertStrictSig )
-import GHC.Core.Coercion.Opt ( optCoercion )
+import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )
 import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                             , isInScope, substTyVarBndr, cloneTyVarBndr )
 import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )
@@ -132,9 +132,7 @@ simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr
 simpleOptExprWith dflags subst expr
   = simple_opt_expr init_env (occurAnalyseExpr expr)
   where
-    init_env = SOE { soe_dflags = dflags
-                   , soe_inl = emptyVarEnv
-                   , soe_subst = subst }
+    init_env = (emptyEnv dflags) { soe_subst = subst }
 
 ----------------------
 simpleOptPgm :: DynFlags -> Module
@@ -171,13 +169,16 @@ type SimpleClo = (SimpleOptEnv, InExpr)
 
 data SimpleOptEnv
   = SOE { soe_dflags :: DynFlags
+        , soe_co_opt_opts :: !OptCoercionOpts
+             -- ^ Options for the coercion optimiser
+
         , soe_inl   :: IdEnv SimpleClo
-             -- Deals with preInlineUnconditionally; things
+             -- ^ Deals with preInlineUnconditionally; things
              -- that occur exactly once and are inlined
              -- without having first been simplified
 
         , soe_subst :: Subst
-             -- Deals with cloning; includes the InScopeSet
+             -- ^ Deals with cloning; includes the InScopeSet
         }
 
 instance Outputable SimpleOptEnv where
@@ -190,7 +191,11 @@ emptyEnv :: DynFlags -> SimpleOptEnv
 emptyEnv dflags
   = SOE { soe_dflags = dflags
         , soe_inl = emptyVarEnv
-        , soe_subst = emptySubst }
+        , soe_subst = emptySubst
+        , soe_co_opt_opts = OptCoercionOpts
+           { optCoercionEnabled = not (hasNoOptCoercion dflags)
+           }
+        }
 
 soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
 soeZapSubst env@(SOE { soe_subst = subst })
@@ -263,7 +268,7 @@ simple_opt_expr env expr
         (env', b') = subst_opt_bndr env b
 
     ----------------------
-    go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co
+    go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co
 
     ----------------------
     go_alt env (con, bndrs, rhs)
@@ -392,7 +397,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
     (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
 
   | Coercion co <- in_rhs
-  , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co
+  , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co
   = ASSERT( isCoVar in_bndr )
     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)