Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC Commits: c42c8498 by Simon Peyton Jones at 2026-10-08T16:17:13+01:00 Work in progress on modifying the Simplifier's FloatBinds ...in collaboration with Claude - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -45,7 +45,7 @@ module GHC.Core.Opt.Simplify.Env ( -- * LetFloats LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat, - addLetFlts, mapLetFloats, + unitCaseFloat, addLetFlts, mapLetFloats, -- * JoinFloats JoinFloat, JoinFloats, emptyJoinFloats, @@ -65,7 +65,8 @@ import GHC.Core.Subst( substExprSC ) import GHC.Core.Unfold import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst) import GHC.Core.Multiplicity( Scaled(..), mkMultMul ) -import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) +import GHC.Core.Make ( mkWildValBinder ) +import qualified GHC.Core.Make import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo , extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion @@ -760,10 +761,46 @@ Examples NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge NonRec x# (a /# b) FltCareful -- Might fail; does not satisfy let-can-float invariant NonRec x# (f y) FltCareful -- Might diverge; does not satisfy let-can-float invariant + +A binding that does not satisfy the let-can-float invariant (the last two +examples above) is represented by a FloatCase, not a FloatLet: + FloatCase (a /# b) x# DEFAULT [] +That is done once and for all by `unitLetFloat`, so a FloatLet in a LetFloats +is always a valid let-binding, and `wrapFloats` does not need to check. +Such bindings can arise from `makeTrivial`, because an argument need not +satisfy the let-can-float invariant. They also arise because +exprOkForSpeculation is conservative: e.g. it says False for (# s, x #) +where x is lifted, because it checks the arguments against the +(representation-polymorphic) type of the unboxed-tuple worker. + +However, a FloatLet can still be FltCareful: the first FltCareful example +above, NonRec x* (f y), where x* is lifted but has a strict demand +(isStrUsedDmd). That is a perfectly valid (lazy) let-binding, but its demand +info is valid only where it is. If we floated it out of the RHS of a lazy +binding + let v = let x* = f y in x*+1 in body + ==> let x* = f y; v = x*+1 in body +then x's demand info would be a lie, and CorePrep, which case-binds a let +whose binder has a strict demand, would evaluate (f y) eagerly. Hence +FltCareful, which doFloatFromRhs allows to float only out of a strict binding. + +As well as let-bindings, a LetFloats can contain single-alternative case +floats (FloatCase), for example + case e of b { (# a, c #) -> <hole> } +These are classified just like a strict binding: + + FloatCase (y +# 3) b DEFAULT [] FltOkSpec -- Scrutinee ok-for-speculation + FloatCase (f y) b (# a,c #) [a,c] FltCareful -- Might fail or diverge + +Being strict they are never FltLifted, so they never float to top level or into +a recursive group. + +Currently, we never put a FloatTick in a LetFloats. -} -data LetFloats = LetFloats (OrdList OutBind) FloatFlag +data LetFloats = LetFloats FloatBinds FloatFlag -- See Note [LetFloats] + -- Contains only FloatLet and FloatCase; never FloatTick type JoinFloat = OutBind type JoinFloats = OrdList JoinFloat @@ -864,17 +901,35 @@ isEmptyJoinFloats = isNilOL unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form +-- If the binding does not satisfy the let-can-float invariant, it +-- makes a FloatCase. See Note [LetFloats] unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ - LetFloats (unitOL bind) (flag bind) + mk_float bind where - flag (Rec {}) = FltLifted - flag (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprIsTickedString rhs = FltLifted + mk_float bind@(Rec {}) = let_float FltLifted bind + mk_float bind@(NonRec bndr rhs) + | not (isStrictId bndr) = let_float FltLifted bind + | exprIsTickedString rhs = let_float FltLifted bind -- String literals can be floated freely. -- See Note [Core top-level string literals] in GHC.Core. - | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) - | otherwise = FltCareful + | exprOkForSpeculation rhs = let_float FltOkSpec bind -- Unlifted, and lifted but ok-for-spec (eg HNF) + | needsCaseBinding (idType bndr) rhs + = pprTrace "TMP-unitLetFloat-case" (ppr bind) $ + LetFloats (unitOL (FloatCase rhs bndr DEFAULT [])) FltCareful + -- Unlifted, and not ok-for-spec: does not satisfy let-can-float invariant + | otherwise = let_float FltCareful bind + + let_float flag bind = LetFloats (unitOL (FloatLet bind)) flag + +unitCaseFloat :: OutExpr -> OutId -> AltCon -> [OutVar] -> LetFloats +-- Constructs a singleton single-alternative case float +-- case scrut of bndr { con bndrs -> <hole> } +-- See Note [LetFloats] +unitCaseFloat scrut bndr con bndrs + = LetFloats (unitOL (FloatCase scrut bndr con bndrs)) flag + where + flag | exprOkForSpeculation scrut = FltOkSpec + | otherwise = FltCareful unitJoinFloat :: OutBind -> JoinFloats unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $ @@ -929,7 +984,11 @@ addLetFloats floats let_floats extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet extendInScopeFromLF in_scope (LetFloats binds _) - = foldlOL extendInScopeSetBind in_scope binds + = foldlOL extend in_scope binds + where + extend in_scope (FloatLet bind) = in_scope `extendInScopeSetBind` bind + extend in_scope (FloatCase _ b _ bs) = in_scope `extendInScopeSetList` (b:bs) + extend in_scope (FloatTick {}) = in_scope addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats addJoinFloats floats join_floats @@ -952,7 +1011,12 @@ addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2) = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2) letFloatBinds :: LetFloats -> [CoreBind] -letFloatBinds (LetFloats bs _) = fromOL bs +-- Precondition: there are no case-floats +-- True, for example, if the FloatFlag is FltLifted +letFloatBinds (LetFloats bs _) = map get_bind (fromOL bs) + where + get_bind (FloatLet bind) = bind + get_bind flt = pprPanic "letFloatBinds" (ppr flt) addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats addJoinFlts = appOL @@ -960,7 +1024,7 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats -mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff +mkRecFloats floats@(SimplFloats { sfLetFloats = lfs@(LetFloats bs _ff) , sfJoinFloats = jbs , sfInScope = in_scope }) = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $ @@ -970,20 +1034,19 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff where -- See Note [Bangs in the Simplifier] !floats' | isNilOL bs = emptyLetFloats - | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + | otherwise = unitLetFloat (Rec (flattenBinds (letFloatBinds lfs))) !jfloats' | isNilOL jbs = emptyJoinFloats | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression -wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ , sfJoinFloats = jbs }) body - = foldrOL mk_let (wrapJoinFloats jbs body) bs + = GHC.Core.Make.wrapFloats bs (wrapJoinFloats jbs body) -- Note: Always safe to put the joins on the inside -- since the values can't refer to them - where - mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant - | otherwise = Let -- let-can-float invariant hold + -- No need to worry about the let-can-float invariant: unitLetFloat + -- has made a FloatCase for any binding that does not satisfy it wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) -- Wrap the sfJoinFloats of the env around the expression, @@ -1009,8 +1072,10 @@ mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats mapLetFloats (LetFloats fs ff) fun = LetFloats fs1 ff where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (strictMap fun bs) + app (FloatLet (NonRec b e)) = case fun (b,e) of (b',e') -> FloatLet (NonRec b' e') + app (FloatLet (Rec bs)) = FloatLet (Rec (strictMap fun bs)) + app (FloatCase e b con bs) = case fun (b,e) of (b',e') -> FloatCase e' b' con bs + app flt@(FloatTick {}) = pprPanic "mapLetFloats" (ppr flt) !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier] {- ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -256,6 +256,8 @@ simplRecBind env0 bind_cxt pairs0 ; let new_bndrs = map sndOf3 triples ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> go env triples + + -- In rec_floats, all the `sfLetFloats` bindings are `FltLifted` ; return (mkRecFloats rec_floats, env2) } where add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) @@ -284,7 +286,8 @@ simplRecOrTopPair :: SimplEnv -> BindContext -> InId -> OutBndr -> InExpr -- Binder and rhs -> SimplM (SimplFloats, SimplEnv) - +-- Invariant: in the returned SimplFloats, +-- all the `sfLetFloats` bindings are `FltLifted` simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) old_bndr (UnSimplified env) rhs MRefl @@ -3399,15 +3402,57 @@ doCaseToLet scrut case_bndr reallyRebuildCase (saf,env) scrut case_bndr alts cont = do { (floats, env', cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts (saf,env') scrut - (scaleIdBy holeScaling case_bndr) - (scaleAltsBy holeScaling alts) - cont' - ; return (floats, case_expr) } + ; traceSmpl "reallyRebuildCase" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env') ]) + ; (alt_env, scrut', case_bndr', imposs_deflt_cons, in_alts) + <- prepareCase (saf,env') scrut (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + ; case in_alts of + [in_alt] -> do { (alt_floats, alt') <- simplAlt (saf,alt_env) (Just scrut') + imposs_deflt_cons case_bndr' + bndr_swap cont' in_alt + ; (case_floats, res) <- rebuildSingleAltCase env' scrut' case_bndr' + cont' alt_floats alt' + ; return (floats `addFloats` case_floats, res) } + + _ -> do { case_expr <- simplAlts (saf,alt_env) scrut' case_bndr' + imposs_deflt_cons bndr_swap cont' in_alts + ; return (floats, case_expr) } } where holeScaling = contHoleScaling cont -- Note [Scaling in case-of-case] + bndr_swap = scrutOkForBinderSwap scrut + +rebuildSingleAltCase :: SimplEnv -> OutExpr -> OutId -> SimplCont + -> SimplFloats -> OutAlt + -> SimplM (SimplFloats, OutExpr) +-- Build a single-alternative case; but return it as a FloatCase float, so that +-- the floats from its RHS are not trapped inside it. +-- See Note [Floating single-alternative cases] +rebuildSingleAltCase env scrut case_bndr cont alt_floats (Alt con bs rhs) + = do { let alts_ty = contResultType cont + -- See Note [Avoiding space leaks in OutType] + ; case_expr <- seqType alts_ty `seq` + mkCase (seMode env) scrut case_bndr alts_ty + [Alt con bs (wrapFloats alt_floats rhs)] + -- wrapFloats: lazily; see (FSC1) + ; case case_expr of + Case scrut2 bndr2 _ [Alt con2 bs2 rhs2] + | not (noFloats alt_floats) + , bndr2 == case_bndr -- mkCase has not changed the case; see (FSC1) + -> return (case_float `addFloats` alt_floats, rhs) + | otherwise + -> return (case_float, rhs2) + where + case_float = emptyFloats env `addLetFloats` + unitCaseFloat scrut2 bndr2 con2 bs2 + _ -> return (emptyFloats env, case_expr) } + where + noFloats (SimplFloats { sfLetFloats = lfs, sfJoinFloats = jfs }) + = isEmptyLetFloats lfs && isEmptyJoinFloats jfs + {- simplCaseBinder checks whether the scrutinee is a variable, v. If so, try to eliminate uses of v in the RHSs in favour of case_bndr; that @@ -3540,17 +3585,16 @@ scale the entire case we are simplifying, by a scaling factor which can be computed in the continuation (with function `contHoleScaling`). -} -simplAlts :: (SimplAltFlag, SimplEnv) - -> OutExpr -- Scrutinee - -> InId -> [InAlt] -- Alts (non-empty) - -> SimplCont - -> SimplM OutExpr -- Returns the complete simplified case expression - -simplAlts (saf,env0) scrut case_bndr alts cont' - = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr - , text "cont':" <+> ppr cont' - , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplAltIdBinder (saf,env0) case_bndr +prepareCase :: (SimplAltFlag, SimplEnv) + -> OutExpr -- Scrutinee + -> InId -> [InAlt] -- Case binder and alts (non-empty) + -> SimplM ( SimplEnv -- For the alternatives + , OutExpr -- Scrutinee, perhaps improved by improveSeq + , OutId -- Case binder + , [AltCon] -- Constructors impossible in the DEFAULT alt + , [InAlt] ) -- Alternatives, from prepareAlts +prepareCase (saf,env0) scrut case_bndr alts + = do { (env1, case_bndr1) <- simplAltIdBinder (saf,env0) case_bndr ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding env2 = modifyInScope env1 case_bndr2 -- See Note [Case binder evaluated-ness] @@ -3565,16 +3609,61 @@ simplAlts (saf,env0) scrut case_bndr alts cont' -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils - ; alts' <- forM in_alts $ - simplAlt (saf,alt_env') (Just scrut') imposs_deflt_cons - case_bndr' (scrutOkForBinderSwap scrut) cont' + ; return (alt_env', scrut', case_bndr', imposs_deflt_cons, in_alts) } + +simplAlts :: (SimplAltFlag, SimplEnv) + -> OutExpr -> OutId -- Scrutinee and case binder + -> [AltCon] -- Constructors impossible in the DEFAULT alt + -> BinderSwapDecision + -> SimplCont + -> [InAlt] + -> SimplM OutExpr -- Returns the complete simplified case expression +-- The arguments are prepared by prepareCase +simplAlts (saf,env) scrut' case_bndr' imposs_deflt_cons bndr_swap cont' in_alts + = do { alts' <- forM in_alts $ + simplAltC (saf,env) (Just scrut') imposs_deflt_cons + case_bndr' bndr_swap cont' ; let alts_ty' = contResultType cont' -- See Note [Avoiding space leaks in OutType] ; seqType alts_ty' `seq` - mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } + mkCase (seMode env) scrut' case_bndr' alts_ty' alts' } +{- Note [Floating single-alternative cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reallyRebuildCase finds a single-alternative case (after prepareAlts) + case e of b { (# a, c #) -> let x1 = .. in ... let xn = .. in (# e1, e2 #) } +it does not return the case expression; instead it returns + * floats: [FloatCase e b (# a,c #) [a,c], x1 = .., ..., xn = ..] + * result: (# e1, e2 #) +This is done by rebuildSingleAltCase. See Note [LetFloats] in GHC.Core.Opt.Simplify.Env. + +Why? Because a caller (notably rebuildWithFloats, when case-of-case is +switched off) may want to do case-of-known-constructor on the result. If we +returned the whole case, exprIsConApp_maybe would have to walk all the way +down through the case and the lets, which can be quadratic (#27737, T18223). + +This is not restricted to the no-case-of-case path: when case-of-case is on, +the continuation has already been pushed into the alternative, and the +floats are simply wrapped around the result, or floated further out of a +strict let (which a StrictBind continuation would do anyway). The +FloatFlag (FltCareful or FltOkSpec) stops a case-float from floating out of +a lazy let, or to top level; see doFloatFromRhs. + +Wrinkles: + +(FSC1) mkCase may transform the case, e.g. by case-merging, identity-case + elimination, or caseRules (mkCase2), which renames the case binder and + wraps (let b = ..) around the RHS. So we call mkCase on the alternative + with its floats wrapped (lazily: mkCase inspects only the top of the RHS), + and then: + - If the alternative has floats, and mkCase has left the case binder + unchanged, mkCase cannot have done anything to the RHS (which starts + with a let), so we return (case-float + alt-floats, unwrapped RHS). + - Otherwise we return the case-float with whatever RHS mkCase produced. +-} + ------------------------------------ improveSeq :: (FamInstEnv, FamInstEnv) -> (SimplAltFlag, SimplEnv) @@ -3594,6 +3683,15 @@ improveSeq _ (_,env) scrut _ case_bndr1 _ ------------------------------------ +simplAltC :: (SimplAltFlag, SimplEnv) -> Maybe OutExpr -> [AltCon] -> OutId + -> BinderSwapDecision -> SimplCont -> InAlt + -> SimplM OutAlt +-- Like simplAlt, but wraps the floats around the RHS +simplAltC env scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' alt + = do { (floats, Alt con bs rhs) <- simplAlt env scrut' imposs_deflt_cons + case_bndr' bndr_swap' cont' alt + ; return (Alt con bs (wrapFloats floats rhs)) } + simplAlt :: (SimplAltFlag, SimplEnv) -> Maybe OutExpr -- The scrutinee -> [AltCon] -- These constructors can't be present when @@ -3603,19 +3701,21 @@ simplAlt :: (SimplAltFlag, SimplEnv) -- add unfolding `v :-> bndr |> sym co` -> SimplCont -> InAlt - -> SimplM OutAlt + -> SimplM (SimplFloats, OutAlt) + -- The floats scope over the RHS only, and may mention the + -- binders of the alternative simplAlt (saf,env) _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs) = assert (null bndrs) $ do { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons - ; rhs' <- simplAltExprC (saf,env') rhs cont' - ; return (Alt DEFAULT [] rhs') } + ; (floats, rhs') <- simplAltExprF (saf,env') rhs cont' + ; return (floats, Alt DEFAULT [] rhs') } simplAlt (saf,env) _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs) = assert (null bndrs) $ do { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit) - ; rhs' <- simplAltExprC (saf,env') rhs cont' - ; return (Alt (LitAlt lit) [] rhs') } + ; (floats, rhs') <- simplAltExprF (saf,env') rhs cont' + ; return (floats, Alt (LitAlt lit) [] rhs') } simplAlt (saf,env) scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] @@ -3633,8 +3733,8 @@ simplAlt (saf,env) scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rh con_app = mkConApp2 con inst_tys' vs' env'' = addAltUnfoldings env' case_bndr' bndr_swap' con_app - ; rhs' <- simplAltExprC (saf,env'') rhs cont' - ; return (Alt (DataAlt con) vs' rhs') } + ; (floats, rhs') <- simplAltExprF (saf,env'') rhs cont' + ; return (floats, Alt (DataAlt con) vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3815,11 +3915,6 @@ simplAltExprF (saf,env) expr cont SAF_Out -> simplOutExpr env expr cont SAF_In -> simplExprF env expr cont -simplAltExprC :: (SimplAltFlag, SimplEnv) -> CoreExpr -> SimplCont -> SimplM OutExpr -simplAltExprC env expr cont - = do { (floats, expr') <- simplAltExprF env expr cont - ; return (wrapFloats floats expr') } - {- Note [Case binder evaluated-ness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4338,7 +4433,7 @@ mkDupableContWithDmds env _ scaleIdBy cont_scaling case_bndr ; alts' <- forM (scaleAltsBy cont_scaling alts) $ - simplAlt (saf,alt_env1) Nothing [] case_bndr' NoBinderSwap alt_cont + simplAltC (saf,alt_env1) Nothing [] case_bndr' NoBinderSwap alt_cont -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c42c84984525e8c9cd722ce6b58f9c3f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c42c84984525e8c9cd722ce6b58f9c3f... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help