Get rid of `CoreDesugarOpt`

5 files changed, 37 insertions, 15 deletions

diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 335cf14ec4..1320123e7e 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -609,7 +609,6 @@ doCorePass logger hsc_env this_mod rule_base mask loc print_unqual vis_orphs pas
     CoreDoPluginPass _ p      -> {-# SCC "Plugin" #-} do
                                  runSimplCountM dflags $ liftCoreM $ p guts
 
-    CoreDesugarOpt            -> noCounts $ pprPanic "doCorePass" (ppr pass)
     CoreTidy                  -> noCounts $ pprPanic "doCorePass" (ppr pass)
     CorePrep                  -> noCounts $ pprPanic "doCorePass" (ppr pass)
   where
diff --git a/compiler/GHC/Core/Opt/Pipeline/Types.hs b/compiler/GHC/Core/Opt/Pipeline/Types.hs
index 2010c4956e..afc4eadd82 100644
--- a/compiler/GHC/Core/Opt/Pipeline/Types.hs
+++ b/compiler/GHC/Core/Opt/Pipeline/Types.hs
@@ -55,9 +55,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
-  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
-                   --                 Core output, and hence useful to pass to endPass
-
   | CoreTidy
   | CorePrep
   | CoreAddCallerCcs
@@ -78,7 +75,6 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecialising       = text "Specialise"
   ppr CoreDoSpecConstr         = text "SpecConstr"
   ppr CoreCSE                  = text "Common sub-expression"
-  ppr CoreDesugarOpt           = text "Desugar (after optimization)"
   ppr CoreTidy                 = text "Tidy Core"
   ppr CoreAddCallerCcs         = text "Add caller cost-centres"
   ppr CoreAddLateCcs           = text "Add late core cost-centres"
diff --git a/compiler/GHC/Driver/Config/Core/EndPass.hs b/compiler/GHC/Driver/Config/Core/EndPass.hs
index 3d8da463d1..89e4214b58 100644
--- a/compiler/GHC/Driver/Config/Core/EndPass.hs
+++ b/compiler/GHC/Driver/Config/Core/EndPass.hs
@@ -1,6 +1,7 @@
 module GHC.Driver.Config.Core.EndPass
   ( endPass
   , endPassDesugarBefore
+  , endPassDesugarAfter
   , endPassLintFlags
   , defaultLintFlags
   , lintPassResult
@@ -48,6 +49,14 @@ endPassDesugarBefore hsc_env print_unqual binds rules = do
     (desugarBeforeConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual)
     binds rules
 
+endPassDesugarAfter :: HscEnv -> PrintUnqualified -> CoreProgram -> [CoreRule] -> IO ()
+endPassDesugarAfter hsc_env print_unqual binds rules = do
+  let dflags  = hsc_dflags hsc_env
+  endPassIO
+    (hsc_logger hsc_env)
+    (desugarAfterConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual)
+    binds rules
+
 endPassLintFlags :: HscEnv -> PrintUnqualified -> Maybe DumpFlag -> LintFlags -> SDoc -> SDoc -> Bool -> CoreProgram -> [CoreRule] -> IO ()
 endPassLintFlags hsc_env print_unqual dump_flag lint_flags pretty_pass pass_details show_lint_warnings binds rules = do
   let dflags  = hsc_dflags hsc_env
@@ -74,6 +83,15 @@ desugarBeforeConfig dflags extra_vars print_unqual =
         (Outputable.empty)
         True
 
+desugarAfterConfig :: DynFlags -> [Var] -> PrintUnqualified -> EndPassConfig
+desugarAfterConfig dflags extra_vars print_unqual =
+  initEndPassConfig' dflags extra_vars print_unqual
+        (Just Opt_D_dump_ds)
+        (desugarAfterFlags dflags)
+        (text "Desugar (after optimization)")
+        (Outputable.empty)
+        True
+
 initEndPassConfig'
   :: DynFlags -> [Var] -> PrintUnqualified -> Maybe DumpFlag -> LintFlags
   -> SDoc -> SDoc -> Bool -> EndPassConfig
@@ -106,7 +124,6 @@ coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
-coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs
index 8564d501bc..44cbdf8820 100644
--- a/compiler/GHC/Driver/Config/Core/Lint.hs
+++ b/compiler/GHC/Driver/Config/Core/Lint.hs
@@ -2,6 +2,7 @@
 module GHC.Driver.Config.Core.Lint
   ( defaultLintFlags
   , desugarBeforeFlags
+  , desugarAfterFlags
   , lintPassResult
   , lintCoreBindings
   , initLintAnnotationsConfig
@@ -96,7 +97,7 @@ perPassFlags :: DynFlags -> CoreToDo -> LintFlags
 perPassFlags dflags pass
   = (defaultLintFlags dflags)
                { lf_check_global_ids = check_globals
-               , lf_check_inline_loop_breakers = check_lbs
+               , lf_check_inline_loop_breakers = True
                , lf_check_static_ptrs = check_static_ptrs
                , lf_check_linearity = check_linearity
                , lf_check_fixed_rep = True
@@ -108,11 +109,6 @@ perPassFlags dflags pass
                       CorePrep -> False
                       _        -> True
 
-    -- See Note [Checking for INLINE loop breakers]
-    check_lbs = case pass of
-                      CoreDesugarOpt -> False
-                      _              -> True
-
     -- See Note [Checking StaticPtrs]
     check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
                       | otherwise = case pass of
@@ -145,6 +141,21 @@ desugarBeforeFlags dflags
                , lf_check_fixed_rep = False
                }
 
+desugarAfterFlags :: DynFlags -> LintFlags
+desugarAfterFlags dflags
+  = (defaultLintFlags dflags)
+               {
+               -- See Note [Checking for global Ids]
+                 lf_check_global_ids = True
+               -- See Note [Checking for INLINE loop breakers]
+               , lf_check_inline_loop_breakers = False
+               -- See Note [Checking StaticPtrs]
+               , lf_check_static_ptrs = AllowAnywhere
+               -- See Note [Linting linearity]
+               , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags
+               , lf_check_fixed_rep = True
+               }
+
 initLintConfig :: DynFlags -> [Var] -> LintConfig
 initLintConfig dflags vars = LintConfig
   { l_diagOpts = initDiagOpts dflags
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index c5d8d29082..c62f5a4443 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -20,7 +20,7 @@ import GHC.Prelude
 
 import GHC.Driver.Session
 import GHC.Driver.Config
-import GHC.Driver.Config.Core.EndPass ( endPass, endPassDesugarBefore )
+import GHC.Driver.Config.Core.EndPass ( endPassDesugarAfter, endPassDesugarBefore )
 import GHC.Driver.Config.HsToCore.Ticks
 import GHC.Driver.Config.HsToCore.Usage
 import GHC.Driver.Env
@@ -55,7 +55,6 @@ import GHC.Core.Coercion
 import GHC.Core.DataCon ( dataConWrapId )
 import GHC.Core.Make
 import GHC.Core.Rules
-import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
 import GHC.Core.Ppr
 
 import GHC.Builtin.Names
@@ -220,7 +219,7 @@ deSugar hsc_env
         ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
 
-        ; endPass hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
+        ; endPassDesugarAfter hsc_env print_unqual ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
               pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))