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.