Simon Peyton Jones pushed to branch wip/T27078 at Glasgow Haskell Compiler / GHC Commits: f8ddc8c3 by Simon Peyton Jones at 2026-03-31T00:12:05+01:00 Wibbles - - - - - 3 changed files: - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/SubstTypeLets.hs - compiler/GHC/HsToCore/Utils.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -435,7 +435,7 @@ lintPassResult logger cfg binds renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger (lpr_passPpr cfg) - (pprCoreBindings binds) warns_and_errs + (pprCoreBindings binds1) warns_and_errs } displayLintResults :: Logger ===================================== compiler/GHC/Core/SubstTypeLets.hs ===================================== @@ -0,0 +1,89 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +module GHC.Core.SubstTypeLets( + substTypeLets + ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils( mkInScopeSetBndrs ) + +import GHC.Types.Var + +import GHC.Utils.Misc( mapSnd ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +{- Note [Substituting type-lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ToDo: write me + +NB: only substitutes /nested/ type-lets, not top level. +-} + +substTypeLets :: CoreProgram -> CoreProgram +substTypeLets binds = map stl_top binds + where + stl_top (NonRec b r) = NonRec b (stlExpr empty_subst r) + stl_top (Rec prs) = Rec (mapSnd (stlExpr empty_subst) prs) + + empty_subst = mkEmptySubst $ + mkInScopeSetBndrs binds + +---------------------- +stlBind :: Subst -> CoreBind -> (Subst, CoreBind) +stlBind subst (Rec prs) + = assertPpr (not (any isTyVar bndrs)) (ppr prs) $ + (subst', Rec prs') + where + (bndrs,rhss) = unzip prs + (subst', bndrs') = substBndrs subst bndrs + rhss' = map (stlExpr subst') rhss + prs' = bndrs' `zip` rhss' + +stlBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (stlExpr subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +---------------------- +stlExpr :: Subst -> CoreExpr -> CoreExpr + +-- This case is the main payload of the entire pass +stlExpr subst (Let (NonRec tv (Type ty)) body) + = stlExpr (extendTvSubst subst tv ty) body + +stlExpr subst (Let bind body) + = Let bind' (stlExpr subst' body) + where + (subst', bind') = stlBind subst bind + +stlExpr subst (Lam bndr body) + = Lam bndr' (stlExpr subst' body) + where + (subst', bndr') = substBndr subst bndr + +stlExpr subst (Case scrut bndr ty alts) + = Case (stlExpr subst scrut) bndr' (substTy subst ty) + (map stl_alt alts) + where + (subst', bndr') = substBndr subst bndr + + stl_alt (Alt con bndrs rhs) + = Alt con bndrs' (stlExpr subst'' rhs) + where + (subst'', bndrs') = substBndrs subst' bndrs + +-- Simple cases +stlExpr _ (Lit l) = Lit l +stlExpr subst (Var v) = lookupIdSubst subst v +stlExpr subst (App e1 e2) = App (stlExpr subst e1) (stlExpr subst e2) +stlExpr subst (Type ty) = Type (substTy subst ty) +stlExpr subst (Tick t e) = Tick (substTickish subst t) (stlExpr subst e) +stlExpr subst (Cast e co) = Cast (stlExpr subst e) (substCo subst co) +stlExpr subst (Coercion co) = Coercion (substCo subst co) ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -248,7 +248,6 @@ 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) -- Used to force variables when desugaring strict binders. It's crucial that the -- variable is shadowed by the case binder. See Wrinkle 1 in View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8ddc8c3b61ac4fc2d2399db8763515d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8ddc8c3b61ac4fc2d2399db8763515d... You're receiving this email because of your account on gitlab.haskell.org.