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.