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
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:
| ... | ... | @@ -46,6 +46,7 @@ import GHC.Core.FVs |
| 46 | 46 | import GHC.Core.Utils
|
| 47 | 47 | import GHC.Core.Stats ( coreBindsStats )
|
| 48 | 48 | import GHC.Core.DataCon
|
| 49 | +import GHC.Core.SubstTypeLets( substTypeLets )
|
|
| 49 | 50 | import GHC.Core.Ppr
|
| 50 | 51 | import GHC.Core.Coercion
|
| 51 | 52 | import GHC.Core.Type as Type
|
| ... | ... | @@ -407,20 +408,28 @@ data LintPassResultConfig = LintPassResultConfig |
| 407 | 408 | , lpr_platform :: !Platform
|
| 408 | 409 | , lpr_makeLintFlags :: !LintFlags
|
| 409 | 410 | , lpr_passPpr :: !SDoc
|
| 411 | + , lpr_preSubst :: Bool
|
|
| 410 | 412 | , lpr_localsInScope :: ![Var]
|
| 411 | 413 | }
|
| 412 | 414 | |
| 413 | 415 | lintPassResult :: Logger -> LintPassResultConfig
|
| 414 | 416 | -> CoreProgram -> IO ()
|
| 415 | 417 | lintPassResult logger cfg binds
|
| 416 | - = do { let warns_and_errs = lintCoreBindings'
|
|
| 417 | - (LintConfig
|
|
| 418 | + = do { let lint_config = LintConfig
|
|
| 418 | 419 | { l_diagOpts = lpr_diagOpts cfg
|
| 419 | 420 | , l_platform = lpr_platform cfg
|
| 420 | 421 | , l_flags = lpr_makeLintFlags cfg
|
| 421 | 422 | , l_vars = lpr_localsInScope cfg
|
| 422 | - })
|
|
| 423 | - binds
|
|
| 423 | + }
|
|
| 424 | + |
|
| 425 | + -- Do the pre-substitution if necessary
|
|
| 426 | + ; let binds1 | lpr_preSubst cfg = substTypeLets binds
|
|
| 427 | + | otherwise = binds
|
|
| 428 | + |
|
| 429 | + -- Do the main Lint pass itself
|
|
| 430 | + ; let warns_and_errs = lintCoreBindings' lint_config binds1
|
|
| 431 | + |
|
| 432 | + -- Report the results
|
|
| 424 | 433 | ; Err.showPass logger $
|
| 425 | 434 | "Core Linted result of " ++
|
| 426 | 435 | renderWithContext defaultSDocContext (lpr_passPpr cfg)
|
| ... | ... | @@ -13,7 +13,8 @@ module GHC.Core.Subst ( |
| 13 | 13 | |
| 14 | 14 | -- ** Substituting into expressions and related types
|
| 15 | 15 | deShadowBinds, substRuleInfo, substRulesForImportedIds,
|
| 16 | - substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
|
|
| 16 | + substTy, substTyUnchecked, substCo,
|
|
| 17 | + substExpr, substExprSC, substBind, substBindSC,
|
|
| 17 | 18 | substUnfolding, substUnfoldingSC,
|
| 18 | 19 | lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
|
| 19 | 20 | substTickish, substDVarSet, substIdInfo,
|
| ... | ... | @@ -42,8 +43,7 @@ import GHC.Core.FVs |
| 42 | 43 | import GHC.Core.Seq
|
| 43 | 44 | import GHC.Core.Utils
|
| 44 | 45 | |
| 45 | - -- We are defining local versions
|
|
| 46 | -import GHC.Core.Type hiding ( substTy )
|
|
| 46 | +import GHC.Core.Type
|
|
| 47 | 47 | import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr )
|
| 48 | 48 | import GHC.Core.TyCo.FVs
|
| 49 | 49 |
| ... | ... | @@ -52,6 +52,7 @@ endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules |
| 52 | 52 | |
| 53 | 53 | -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
|
| 54 | 54 | lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
|
| 55 | +-- ToDo: this function is not called within GHC. Why does it exist?
|
|
| 55 | 56 | lintCoreBindings dflags coreToDo vars -- binds
|
| 56 | 57 | = lintCoreBindings' $ LintConfig
|
| 57 | 58 | { l_diagOpts = initDiagOpts dflags
|
| ... | ... | @@ -104,10 +105,15 @@ initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig |
| 104 | 105 | { lpr_diagOpts = initDiagOpts dflags
|
| 105 | 106 | , lpr_platform = targetPlatform dflags
|
| 106 | 107 | , lpr_makeLintFlags = perPassFlags dflags pass
|
| 107 | - , lpr_passPpr = ppr pass
|
|
| 108 | + , lpr_passPpr = ppr pass
|
|
| 109 | + , lpr_preSubst = doPreSubst pass
|
|
| 108 | 110 | , lpr_localsInScope = extra_vars
|
| 109 | 111 | }
|
| 110 | 112 | |
| 113 | +doPreSubst :: CoreToDo -> Bool
|
|
| 114 | +doPreSubst CoreDesugar = True
|
|
| 115 | +doPreSubst _ = False
|
|
| 116 | + |
|
| 111 | 117 | perPassFlags :: DynFlags -> CoreToDo -> LintFlags
|
| 112 | 118 | perPassFlags dflags pass
|
| 113 | 119 | = (defaultLintFlags dflags)
|
| ... | ... | @@ -247,8 +247,8 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) |
| 247 | 247 | wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
|
| 248 | 248 | wrapBind new old body -- NB: this function must deal with term
|
| 249 | 249 | | new==old = body -- variables, type variables or coercion variables
|
| 250 | --- | otherwise = Let (NonRec new (varToCoreExpr old)) body
|
|
| 251 | - | otherwise = App (Lam new body) (varToCoreExpr old)
|
|
| 250 | + | otherwise = Let (NonRec new (varToCoreExpr old)) body
|
|
| 251 | +-- | otherwise = App (Lam new body) (varToCoreExpr old)
|
|
| 252 | 252 | |
| 253 | 253 | -- Used to force variables when desugaring strict binders. It's crucial that the
|
| 254 | 254 | -- variable is shadowed by the case binder. See Wrinkle 1 in
|
| ... | ... | @@ -408,6 +408,7 @@ Library |
| 408 | 408 | GHC.Core.SimpleOpt
|
| 409 | 409 | GHC.Core.Stats
|
| 410 | 410 | GHC.Core.Subst
|
| 411 | + GHC.Core.SubstTypeLets
|
|
| 411 | 412 | GHC.Core.Tidy
|
| 412 | 413 | GHC.CoreToIface
|
| 413 | 414 | GHC.CoreToStg
|