[Git][ghc/ghc][wip/spj-try-opt-coercion] Wibble let-floating to avoid simplifier iterations

26 May 2026


      Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC


Commits:
3f199564 by Simon Peyton Jones at 2026-05-26T13:09:09+01:00
Wibble let-floating to avoid simplifier iterations

- - - - -


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
=====================================
@@ -367,6 +367,7 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
                                                                 tvs' body_floats2 body2
                         ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds
                         ; return (poly_floats, body3) }
+        ; tickLetFloatFromLet rhs_floats
 
         ; let env1 = env `setInScopeFromF` rhs_floats
         ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont
@@ -632,6 +633,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
 
         ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict
                                                    work_id (emptyFloats env) rhs
+        ; tickLetFloatFromLet rhs_floats
 
         ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs
 
@@ -751,14 +753,18 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
        ; let all_floats = rhs_floats1 `addLetFloats` anf_floats
        ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2
          then -- Float!
-              do { tick LetFloatFromLet
-                 ; return (all_floats, rhs2) }
+              return (all_floats, rhs2)
 
          else -- Abandon floating altogether; revert to original rhs
               -- Since we have already built rhs1, we just need to add
               -- rhs_floats1 to it
               return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }
 
+tickLetFloatFromLet :: SimplFloats -> SimplM ()
+tickLetFloatFromLet floats
+  | isEmptyFloats floats = return ()
+  | otherwise            = tick LetFloatFromLet
+
 {- Note [prepareRhs]
 ~~~~~~~~~~~~~~~~~~~~
 prepareRhs takes a putative RHS, checks whether it's a PAP or
@@ -1695,6 +1701,8 @@ completeBindX env from_what bndr rhs body cont
 
         ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
                                                bndr2 (emptyFloats env) rhs
+        ; tickLetFloatFromLet rhs_floats
+
               -- NB: it makes a surprisingly big difference (5% in compiler allocation
               -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',
               -- because this is completeBindX, so bndr is not in scope in the RHS.


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -76,7 +76,6 @@ import GHC.Types.Var.Set
 import GHC.Types.Basic
 import GHC.Types.Name.Env
 
-import GHC.Data.OrdList ( isNilOL )
 import GHC.Data.FastString ( fsLit )
 
 import GHC.Utils.Misc
@@ -2380,14 +2379,9 @@ new binding is abstracted.  Several points worth noting
 abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
               -> OutExpr -> SimplM ([OutBind], OutExpr)
 abstractFloats uf_opts top_lvl main_tvs floats body
-  | assert (notNull body_floats) $
-    assert (isNilOL (sfJoinFloats floats)) $
-    any isCoVar (bindersOfBinds body_floats)   -- ToDo: Explain this case
-  = return ([], wrapFloats floats body)
-  | otherwise
   = do  { let sccs = concatMap to_sccs body_floats
         ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs
-        ; return (float_binds, GHC.Core.Subst.substExpr subst body) }
+        ; return (catMaybes float_binds, GHC.Core.Subst.substExpr subst body) }
   where
     is_top_lvl  = isTopLevel top_lvl
     body_floats = letFloatBinds (sfLetFloats floats)
@@ -2404,12 +2398,18 @@ abstractFloats uf_opts top_lvl main_tvs floats body
                        (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
                        (zip3 ids rhss (map exprFreeVars rhss))
 
-    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
+    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet)
+             -> SimplM (GHC.Core.Subst.Subst, Maybe OutBind)
     abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
-      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
+      | Coercion co <- rhs  -- Coercions: can't abstract, so just substitute
+      = return (GHC.Core.Subst.extendCvSubst subst id co, Nothing)
+
+      | otherwise
+      = assertPpr (isId id) (ppr id) $
+        do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
                  !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
-           ; return (subst', NonRec poly_id2 poly_rhs) }
+           ; return (subst', Just $ NonRec poly_id2 poly_rhs) }
       where
         rhs' = GHC.Core.Subst.substExpr subst rhs
 
@@ -2422,7 +2422,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
                               | (poly_id, rhs) <- poly_ids `zip` rhss
                               , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
-           ; return (subst', Rec poly_pairs) }
+           ; return (subst', Just $ Rec poly_pairs) }
       where
         (ids,rhss,_fvss) = unzip3 trpls
 



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

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

    

Simon Peyton Jones (＠simonpj)

tags

participants (1)