[Git][ghc/ghc][wip/T20264] Aggressively create type-lets

[Simon Peyton Jones (@simonpj)]

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


Commits:
b43a2e3c by Simon Peyton Jones at 2024-10-30T23:46:18+00:00
Aggressively create type-lets

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1804,7 +1804,9 @@ simpl_lam :: HasDebugCallStack
 -- Type beta-reduction
 simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
   = do { tick (BetaReduction bndr)
-       ; simplLam (extendTvSubst env bndr arg_ty) body cont }
+       ; (floats1, env1)  <- completeTyVarBindX env bndr arg_ty
+       ; (floats2, expr') <- simplLam env1 body cont
+       ; return (floats1 `addFloats` floats2, expr') } 
 
 -- Coercion beta-reduction
 simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se
@@ -1905,10 +1907,9 @@ simplNonRecE :: HasDebugCallStack
 simplNonRecE env from_what bndr (rhs, rhs_se) body cont
   | Type ty <- rhs
   = assert (isTyVar bndr) $
-    do { (env1, bndr1) <- simplNonRecBndr env bndr
-       ; ty'           <- simplType env ty
-       ; let (floats1, env2) = mkTyVarFloatBind env1 bndr bndr1 ty'
-       ; (floats2, expr') <- simplNonRecBody env2 from_what body cont
+    do { ty'              <- simplType (rhs_se `setInScopeFromE` env) ty
+       ; (floats1, env1)  <- completeTyVarBindX env bndr ty'
+       ; (floats2, expr') <- simplNonRecBody env1 from_what body cont
        ; return (floats1 `addFloats` floats2, expr') }
 
   | assert (isId bndr && not (isJoinId bndr) ) $
@@ -1936,6 +1937,13 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont
        -- (FromBeta Lifted) or FromLet: look at the demand info
        _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)
 
+completeTyVarBindX :: SimplEnv -> InTyVar -> OutType -> SimplM (SimplFloats, SimplEnv)
+completeTyVarBindX env tv rhs_ty
+  | postInlineTypeUnconditionally rhs_ty
+  = return (emptyFloats env, extendTvSubst env tv rhs_ty)
+  | otherwise
+  = do { (env1, tv1) <- simplNonRecBndr env tv
+       ; return (mkTyVarFloatBind env1 tv tv1 rhs_ty) }
 
 ------------------
 simplRecE :: SimplEnv


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Core.Opt.Simplify.Utils (
 
         -- Inlining,
         preInlineUnconditionally, postInlineUnconditionally,
+        postInlineTypeUnconditionally,
         activeRule,
         getUnfoldingInRuleMatch,
         updModeForStableUnfoldings, updModeForRules,
@@ -1455,7 +1456,8 @@ the former.
 -}
 
 preInlineUnconditionally
-    :: SimplEnv -> TopLevelFlag -> InId
+    :: SimplEnv -> TopLevelFlag
+    -> InVar                -- Works for TyVar, CoVar, and Id
     -> InExpr -> StaticEnv  -- These two go together
     -> Maybe SimplEnv       -- Returned env has extended substitution
 -- Precondition: rhs satisfies the let-can-float invariant
@@ -1601,6 +1603,9 @@ may seem surprising; for instance, the LHS of rules. See Note [Simplifying
 rules] for details.
 -}
 
+postInlineTypeUnconditionally :: Type -> Bool
+postInlineTypeUnconditionally _ = False
+
 postInlineUnconditionally
     :: SimplEnv -> BindContext
     -> InId -> OutId    -- The binder (*not* a CoVar), including its unfolding



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

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


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241030/210be527/attachment-0001.html>