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
2 changed files:
Changes:
| ... | ... | @@ -367,6 +367,7 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) |
| 367 | 367 | tvs' body_floats2 body2
|
| 368 | 368 | ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds
|
| 369 | 369 | ; return (poly_floats, body3) }
|
| 370 | + ; tickLetFloatFromLet rhs_floats
|
|
| 370 | 371 | |
| 371 | 372 | ; let env1 = env `setInScopeFromF` rhs_floats
|
| 372 | 373 | ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont
|
| ... | ... | @@ -632,6 +633,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co) |
| 632 | 633 | |
| 633 | 634 | ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict
|
| 634 | 635 | work_id (emptyFloats env) rhs
|
| 636 | + ; tickLetFloatFromLet rhs_floats
|
|
| 635 | 637 | |
| 636 | 638 | ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs
|
| 637 | 639 | |
| ... | ... | @@ -751,14 +753,18 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs |
| 751 | 753 | ; let all_floats = rhs_floats1 `addLetFloats` anf_floats
|
| 752 | 754 | ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2
|
| 753 | 755 | then -- Float!
|
| 754 | - do { tick LetFloatFromLet
|
|
| 755 | - ; return (all_floats, rhs2) }
|
|
| 756 | + return (all_floats, rhs2)
|
|
| 756 | 757 | |
| 757 | 758 | else -- Abandon floating altogether; revert to original rhs
|
| 758 | 759 | -- Since we have already built rhs1, we just need to add
|
| 759 | 760 | -- rhs_floats1 to it
|
| 760 | 761 | return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }
|
| 761 | 762 | |
| 763 | +tickLetFloatFromLet :: SimplFloats -> SimplM ()
|
|
| 764 | +tickLetFloatFromLet floats
|
|
| 765 | + | isEmptyFloats floats = return ()
|
|
| 766 | + | otherwise = tick LetFloatFromLet
|
|
| 767 | + |
|
| 762 | 768 | {- Note [prepareRhs]
|
| 763 | 769 | ~~~~~~~~~~~~~~~~~~~~
|
| 764 | 770 | prepareRhs takes a putative RHS, checks whether it's a PAP or
|
| ... | ... | @@ -1695,6 +1701,8 @@ completeBindX env from_what bndr rhs body cont |
| 1695 | 1701 | |
| 1696 | 1702 | ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
|
| 1697 | 1703 | bndr2 (emptyFloats env) rhs
|
| 1704 | + ; tickLetFloatFromLet rhs_floats
|
|
| 1705 | + |
|
| 1698 | 1706 | -- NB: it makes a surprisingly big difference (5% in compiler allocation
|
| 1699 | 1707 | -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
|
| 1700 | 1708 | -- because this is completeBindX, so bndr is not in scope in the RHS.
|
| ... | ... | @@ -76,7 +76,6 @@ import GHC.Types.Var.Set |
| 76 | 76 | import GHC.Types.Basic
|
| 77 | 77 | import GHC.Types.Name.Env
|
| 78 | 78 | |
| 79 | -import GHC.Data.OrdList ( isNilOL )
|
|
| 80 | 79 | import GHC.Data.FastString ( fsLit )
|
| 81 | 80 | |
| 82 | 81 | import GHC.Utils.Misc
|
| ... | ... | @@ -2380,14 +2379,9 @@ new binding is abstracted. Several points worth noting |
| 2380 | 2379 | abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
|
| 2381 | 2380 | -> OutExpr -> SimplM ([OutBind], OutExpr)
|
| 2382 | 2381 | abstractFloats uf_opts top_lvl main_tvs floats body
|
| 2383 | - | assert (notNull body_floats) $
|
|
| 2384 | - assert (isNilOL (sfJoinFloats floats)) $
|
|
| 2385 | - any isCoVar (bindersOfBinds body_floats) -- ToDo: Explain this case
|
|
| 2386 | - = return ([], wrapFloats floats body)
|
|
| 2387 | - | otherwise
|
|
| 2388 | 2382 | = do { let sccs = concatMap to_sccs body_floats
|
| 2389 | 2383 | ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs
|
| 2390 | - ; return (float_binds, GHC.Core.Subst.substExpr subst body) }
|
|
| 2384 | + ; return (catMaybes float_binds, GHC.Core.Subst.substExpr subst body) }
|
|
| 2391 | 2385 | where
|
| 2392 | 2386 | is_top_lvl = isTopLevel top_lvl
|
| 2393 | 2387 | body_floats = letFloatBinds (sfLetFloats floats)
|
| ... | ... | @@ -2404,12 +2398,18 @@ abstractFloats uf_opts top_lvl main_tvs floats body |
| 2404 | 2398 | (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
|
| 2405 | 2399 | (zip3 ids rhss (map exprFreeVars rhss))
|
| 2406 | 2400 | |
| 2407 | - abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
|
|
| 2401 | + abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet)
|
|
| 2402 | + -> SimplM (GHC.Core.Subst.Subst, Maybe OutBind)
|
|
| 2408 | 2403 | abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
|
| 2409 | - = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
|
|
| 2404 | + | Coercion co <- rhs -- Coercions: can't abstract, so just substitute
|
|
| 2405 | + = return (GHC.Core.Subst.extendCvSubst subst id co, Nothing)
|
|
| 2406 | + |
|
| 2407 | + | otherwise
|
|
| 2408 | + = assertPpr (isId id) (ppr id) $
|
|
| 2409 | + do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
|
|
| 2410 | 2410 | ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
|
| 2411 | 2411 | !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
|
| 2412 | - ; return (subst', NonRec poly_id2 poly_rhs) }
|
|
| 2412 | + ; return (subst', Just $ NonRec poly_id2 poly_rhs) }
|
|
| 2413 | 2413 | where
|
| 2414 | 2414 | rhs' = GHC.Core.Subst.substExpr subst rhs
|
| 2415 | 2415 | |
| ... | ... | @@ -2422,7 +2422,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body |
| 2422 | 2422 | poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
|
| 2423 | 2423 | | (poly_id, rhs) <- poly_ids `zip` rhss
|
| 2424 | 2424 | , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
|
| 2425 | - ; return (subst', Rec poly_pairs) }
|
|
| 2425 | + ; return (subst', Just $ Rec poly_pairs) }
|
|
| 2426 | 2426 | where
|
| 2427 | 2427 | (ids,rhss,_fvss) = unzip3 trpls
|
| 2428 | 2428 |