Get rid of `CoreDesugar`

It is not a Core -> Core pass and so it doesn't belong in that sum type.

5 files changed, 44 insertions, 22 deletions

diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index fa7f62104d..335cf14ec4 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
 
-    CoreDesugar               -> noCounts $ pprPanic "doCorePass" (ppr pass)
     CoreDesugarOpt            -> noCounts $ pprPanic "doCorePass" (ppr pass)
     CoreTidy                  -> noCounts $ pprPanic "doCorePass" (ppr pass)
     CorePrep                  -> noCounts $ pprPanic "doCorePass" (ppr pass)
diff --git a/compiler/GHC/Core/Opt/Pipeline/Types.hs b/compiler/GHC/Core/Opt/Pipeline/Types.hs
index b9f0f70ba4..2010c4956e 100644
--- a/compiler/GHC/Core/Opt/Pipeline/Types.hs
+++ b/compiler/GHC/Core/Opt/Pipeline/Types.hs
@@ -55,7 +55,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
-  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
   | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
                    --                 Core output, and hence useful to pass to endPass
 
@@ -79,7 +78,6 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecialising       = text "Specialise"
   ppr CoreDoSpecConstr         = text "SpecConstr"
   ppr CoreCSE                  = text "Common sub-expression"
-  ppr CoreDesugar              = text "Desugar (before optimization)"
   ppr CoreDesugarOpt           = text "Desugar (after optimization)"
   ppr CoreTidy                 = text "Tidy Core"
   ppr CoreAddCallerCcs         = text "Add caller cost-centres"
diff --git a/compiler/GHC/Driver/Config/Core/EndPass.hs b/compiler/GHC/Driver/Config/Core/EndPass.hs
index 8df1146317..3d8da463d1 100644
--- a/compiler/GHC/Driver/Config/Core/EndPass.hs
+++ b/compiler/GHC/Driver/Config/Core/EndPass.hs
@@ -1,5 +1,6 @@
 module GHC.Driver.Config.Core.EndPass
   ( endPass
+  , endPassDesugarBefore
   , endPassLintFlags
   , defaultLintFlags
   , lintPassResult
@@ -39,6 +40,14 @@ endPass hsc_env print_unqual pass binds rules = do
     (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual pass)
     binds rules
 
+endPassDesugarBefore :: HscEnv -> PrintUnqualified -> CoreProgram -> [CoreRule] -> IO ()
+endPassDesugarBefore hsc_env print_unqual binds rules = do
+  let dflags  = hsc_dflags hsc_env
+  endPassIO
+    (hsc_logger hsc_env)
+    (desugarBeforeConfig 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
@@ -56,6 +65,15 @@ initEndPassConfig dflags extra_vars print_unqual pass =
         (pprPassDetails pass)
         (showLintWarnings pass)
 
+desugarBeforeConfig :: DynFlags -> [Var] -> PrintUnqualified -> EndPassConfig
+desugarBeforeConfig dflags extra_vars print_unqual =
+  initEndPassConfig' dflags extra_vars print_unqual
+        (Just Opt_D_dump_ds_preopt)
+        (desugarBeforeFlags dflags)
+        (text "Desugar (before optimization)")
+        (Outputable.empty)
+        True
+
 initEndPassConfig'
   :: DynFlags -> [Var] -> PrintUnqualified -> Maybe DumpFlag -> LintFlags
   -> SDoc -> SDoc -> Bool -> EndPassConfig
@@ -88,7 +106,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 CoreDesugar              = Just Opt_D_dump_ds_preopt
 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 afae25f2a3..8564d501bc 100644
--- a/compiler/GHC/Driver/Config/Core/Lint.hs
+++ b/compiler/GHC/Driver/Config/Core/Lint.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 module GHC.Driver.Config.Core.Lint
   ( defaultLintFlags
+  , desugarBeforeFlags
   , lintPassResult
   , lintCoreBindings
   , initLintAnnotationsConfig
@@ -98,19 +99,9 @@ perPassFlags dflags pass
                , lf_check_inline_loop_breakers = check_lbs
                , lf_check_static_ptrs = check_static_ptrs
                , lf_check_linearity = check_linearity
-               , lf_check_fixed_rep = check_fixed_rep
+               , lf_check_fixed_rep = True
                }
   where
-    -- In the output of the desugarer, before optimisation,
-    -- we have eta-expanded data constructors with representation-polymorphic
-    -- bindings; so we switch off the representation-polymorphism checks.
-    -- The very simple optimiser will beta-reduce them away.
-    -- See Note [Checking for representation-polymorphic built-ins]
-    -- in GHC.HsToCore.Expr.
-    check_fixed_rep = case pass of
-                        CoreDesugar -> False
-                        _           -> True
-
     -- See Note [Checking for global Ids]
     check_globals = case pass of
                       CoreTidy -> False
@@ -119,7 +110,6 @@ perPassFlags dflags pass
 
     -- See Note [Checking for INLINE loop breakers]
     check_lbs = case pass of
-                      CoreDesugar    -> False
                       CoreDesugarOpt -> False
                       _              -> True
 
@@ -132,10 +122,28 @@ perPassFlags dflags pass
                           _                     -> AllowAnywhere
 
     -- See Note [Linting linearity]
-    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (
-                        case pass of
-                          CoreDesugar -> True
-                          _ -> False)
+    check_linearity = gopt Opt_DoLinearCoreLinting dflags
+
+desugarBeforeFlags :: DynFlags -> LintFlags
+desugarBeforeFlags 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 = True
+               -- In the output of the desugarer, before optimisation,
+               -- we have eta-expanded data constructors with representation-polymorphic
+               -- bindings; so we switch off the representation-polymorphism checks.
+               -- The very simple optimiser will beta-reduce them away.
+               -- See Note [Checking for representation-polymorphic built-ins]
+               -- in GHC.HsToCore.Expr.
+               , lf_check_fixed_rep = False
+               }
 
 initLintConfig :: DynFlags -> [Var] -> LintConfig
 initLintConfig dflags vars = LintConfig
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 9840d9bb51..c5d8d29082 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 )
+import GHC.Driver.Config.Core.EndPass ( endPass, endPassDesugarBefore )
 import GHC.Driver.Config.HsToCore.Ticks
 import GHC.Driver.Config.HsToCore.Usage
 import GHC.Driver.Env
@@ -211,7 +211,7 @@ deSugar hsc_env
         -- You might think it doesn't matter, but the simplifier brings all top-level
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-        ; endPass hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
+        ; endPassDesugarBefore hsc_env print_unqual final_pgm rules_for_imps
         ; let simpl_opts = initSimpleOpts dflags
         ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
                 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps