[Git][ghc/ghc][wip/T27078] More on this

29 Mar 2026

Simon Peyton Jones pushed to branch wip/T27078 at Glasgow Haskell Compiler / GHC


Commits:
2942a423 by Simon Peyton Jones at 2026-03-29T23:59:32+01:00
More on this

nearly working

- - - - -


5 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/ghc.cabal.in


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -46,6 +46,7 @@ import GHC.Core.FVs
 import GHC.Core.Utils
 import GHC.Core.Stats ( coreBindsStats )
 import GHC.Core.DataCon
+import GHC.Core.SubstTypeLets( substTypeLets )
 import GHC.Core.Ppr
 import GHC.Core.Coercion
 import GHC.Core.Type as Type
@@ -407,20 +408,28 @@ data LintPassResultConfig = LintPassResultConfig
   , lpr_platform         :: !Platform
   , lpr_makeLintFlags    :: !LintFlags
   , lpr_passPpr          :: !SDoc
+  , lpr_preSubst         :: Bool
   , lpr_localsInScope    :: ![Var]
   }
 
 lintPassResult :: Logger -> LintPassResultConfig
                -> CoreProgram -> IO ()
 lintPassResult logger cfg binds
-  = do { let warns_and_errs = lintCoreBindings'
-               (LintConfig
+  = do { let lint_config = LintConfig
                 { l_diagOpts = lpr_diagOpts cfg
                 , l_platform = lpr_platform cfg
                 , l_flags    = lpr_makeLintFlags cfg
                 , l_vars     = lpr_localsInScope cfg
-                })
-               binds
+                }
+
+       -- Do the pre-substitution if necessary
+       ; let binds1 | lpr_preSubst cfg = substTypeLets binds
+                    | otherwise        = binds
+
+       -- Do the main Lint pass itself
+       ; let warns_and_errs = lintCoreBindings' lint_config binds1
+
+       -- Report the results
        ; Err.showPass logger $
            "Core Linted result of " ++
            renderWithContext defaultSDocContext (lpr_passPpr cfg)


=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -13,7 +13,8 @@ module GHC.Core.Subst (
 
         -- ** Substituting into expressions and related types
         deShadowBinds, substRuleInfo, substRulesForImportedIds,
-        substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
+        substTy, substTyUnchecked, substCo,
+        substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
         lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
         substTickish, substDVarSet, substIdInfo,
@@ -42,8 +43,7 @@ import GHC.Core.FVs
 import GHC.Core.Seq
 import GHC.Core.Utils
 
-        -- We are defining local versions
-import GHC.Core.Type hiding ( substTy )
+import GHC.Core.Type
 import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr )
 import GHC.Core.TyCo.FVs
 


=====================================
compiler/GHC/Driver/Config/Core/Lint.hs
=====================================
@@ -52,6 +52,7 @@ endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules
 
 -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
 lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
+-- ToDo: this function is not called within GHC.  Why does it exist?
 lintCoreBindings dflags coreToDo vars -- binds
   = lintCoreBindings' $ LintConfig
       { l_diagOpts = initDiagOpts dflags
@@ -104,10 +105,15 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig
   { lpr_diagOpts      = initDiagOpts dflags
   , lpr_platform      = targetPlatform dflags
   , lpr_makeLintFlags = perPassFlags dflags pass
-  , lpr_passPpr = ppr pass
+  , lpr_passPpr       = ppr pass
+  , lpr_preSubst      = doPreSubst pass
   , lpr_localsInScope = extra_vars
   }
 
+doPreSubst :: CoreToDo -> Bool
+doPreSubst CoreDesugar = True
+doPreSubst _           = False
+
 perPassFlags :: DynFlags -> CoreToDo -> LintFlags
 perPassFlags dflags pass
   = (defaultLintFlags dflags)


=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -247,8 +247,8 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 wrapBind new old body   -- NB: this function must deal with term
   | new==old    = body  -- variables, type variables or coercion variables

---  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
-  | otherwise   = App (Lam new body) (varToCoreExpr old)
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
+--  | otherwise   = App (Lam new body) (varToCoreExpr old)
 
 -- Used to force variables when desugaring strict binders. It's crucial that the
 -- variable is shadowed by the case binder. See Wrinkle 1 in


=====================================
compiler/ghc.cabal.in
=====================================
@@ -408,6 +408,7 @@ Library
         GHC.Core.SimpleOpt
         GHC.Core.Stats
         GHC.Core.Subst
+        GHC.Core.SubstTypeLets
         GHC.Core.Tidy
         GHC.CoreToIface
         GHC.CoreToStg



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2942a423844b08f99ffe38627ca670d7...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2942a423844b08f99ffe38627ca670d7...
You're receiving this email because of your account on gitlab.haskell.org.

    

Simon Peyton Jones (＠simonpj)

tags

participants (1)