Simon Peyton Jones pushed to branch wip/T26709 at Glasgow Haskell Compiler / GHC Commits: 45c8cc6d by Simon Peyton Jones at 2025-12-31T10:25:39+00:00 Refactor srutOkForBinderSwap This MR does a small refactor: * Moves `scrutOkForBinderSwap` and `BinderSwapDecision` to GHC.Core.Utils * Inverts the sense of the coercion it returns, which makes more sense No effect on behaviour - - - - - e091ab8d by Simon Peyton Jones at 2025-12-31T10:25:40+00:00 Improve case merging This small MR makes case merging happen a bit more often than it otherwise could, by getting join points out of the way. See #26709 and GHC.Core.Utils Note [Floating join points out of DEFAULT alternatives] - - - - - 8 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Utils.hs - + testsuite/tests/simplCore/should_compile/T26709.hs - + testsuite/tests/simplCore/should_compile/T26709.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -28,7 +28,7 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr, - zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap + zapLambdaBndrs ) where import GHC.Prelude hiding ( head, init, last, tail ) @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - mkCastMCo, mkTicks ) + mkCastMCo, mkTicks, BinderSwapDecision(..), scrutOkForBinderSwap ) import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Type @@ -3537,6 +3537,7 @@ doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. -} addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [Binder swap] -- See Note [The binder-swap substitution] addBndrSwap scrut case_bndr env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) @@ -3544,7 +3545,7 @@ addBndrSwap scrut case_bndr , scrut_var /= case_bndr -- Consider: case x of x { ... } -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop - = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mkSymMCo mco) , occ_bs_rng = rng_vars `extendVarSet` case_bndr' `unionVarSet` tyCoVarsOfMCo mco } @@ -3554,27 +3555,6 @@ addBndrSwap scrut case_bndr case_bndr' = zapIdOccInfo case_bndr -- See Note [Zap case binders in proxy bindings] --- | See bBinderSwaOk. -data BinderSwapDecision - = NoBinderSwap - | DoBinderSwap OutVar MCoercion - -scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision --- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then --- v = e |> mco --- See Note [Case of cast] --- See Historical Note [Care with binder-swap on dictionaries] --- --- We use this same function in SpecConstr, and Simplify.Iteration, --- when something binder-swap-like is happening -scrutOkForBinderSwap e - = case e of - Tick _ e -> scrutOkForBinderSwap e -- Drop ticks - Var v -> DoBinderSwap v MRefl - Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co)) - -- Cast: see Note [Case of cast] - _ -> NoBinderSwap - lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) -- See Note [The binder-swap substitution] -- Returns an expression of the same type as Id ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) @@ -3601,11 +3601,13 @@ addAltUnfoldings env case_bndr bndr_swap con_app env1 = addBinderUnfolding env case_bndr con_app_unf -- See Note [Add unfolding for scrutinee] + -- e.g. case (x |> co) of K a b -> blah + -- We add to `x` the unfolding (K a b |> sym co) env2 | DoBinderSwap v mco <- bndr_swap = addBinderUnfolding env1 v $ if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf then con_app_unf -- twice in the common case - else mk_simple_unf (mkCastMCo con_app mco) + else mk_simple_unf (mkCastMCo con_app (mkSymMCo mco)) | otherwise = env1 ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2693,7 +2693,7 @@ mkCase, mkCase1, mkCase2, mkCase3 mkCase mode scrut outer_bndr alts_ty alts | sm_case_merge mode - , Just (joins, alts') <- mergeCaseAlts outer_bndr alts + , Just (joins, alts') <- mergeCaseAlts scrut outer_bndr alts = do { tick (CaseMerge outer_bndr) ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts' ; return (mkLets joins case_expr) } ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Core.Opt.Simplify.Inline import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils -import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap ) import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -19,6 +19,7 @@ module GHC.Core.Utils ( mergeAlts, mergeCaseAlts, trimConArgs, filterAlts, combineIdenticalAlts, refineDefaultAlt, scaleAltsBy, + BinderSwapDecision(..), scrutOkForBinderSwap, -- * Properties of expressions exprType, coreAltType, coreAltsType, @@ -72,7 +73,7 @@ import GHC.Platform import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( bindFreeVars ) +import GHC.Core.FVs( exprFreeVars, bindFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) @@ -112,11 +113,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import Control.Monad ( guard ) import Data.ByteString ( ByteString ) import Data.Function ( on ) import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) import Data.Ord ( comparing ) -import Control.Monad ( guard ) import qualified Data.Set as Set {- @@ -590,6 +591,28 @@ The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder. -} +data BinderSwapDecision + = NoBinderSwap + | DoBinderSwap OutVar MCoercion + +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then +-- e = v |> mco +-- See Note [Case of cast] +-- See Historical Note [Care with binder-swap on dictionaries] +-- +-- We use this same function in SpecConstr, and Simplify.Iteration, +-- when something binder-swap-like is happening +-- +-- See Note [Binder swap] in GHC.Core.Opt.OccurAnal +scrutOkForBinderSwap e + = case e of + Tick _ e -> scrutOkForBinderSwap e -- Drop ticks + Var v -> DoBinderSwap v MRefl + Cast (Var v) co -> DoBinderSwap v (MCo co) + -- Cast: see Note [Case of cast] + _ -> NoBinderSwap + -- | Extract the default case alternative findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) @@ -651,11 +674,12 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. -} --------------------------------- -mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) +mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) -- See Note [Merge Nested Cases] -mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) +mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) | Just (joins, inner_alts) <- go deflt_rhs - = Just (joins, mergeAlts outer_alts inner_alts) + , Just aux_binds <- mk_aux_binds joins + = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts ) -- NB: mergeAlts gives priority to the left -- case x of -- A -> e1 @@ -665,6 +689,20 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) -- When we merge, we must ensure that e1 takes -- precedence over e2 as the value for A! where + scrut_fvs = exprFreeVars scrut + + -- See Note [Floating join points out of DEFAULT alternatives] + mk_aux_binds join_binds + | not (any mentions_outer_bndr join_binds) + = Just [] -- Good! No auxiliary bindings needed + | exprIsTrivial scrut + , not (outer_bndr `elemVarSet` scrut_fvs) + = Just [NonRec outer_bndr scrut] -- Need a fixup binding + | otherwise + = Nothing -- Can't do it + + mentions_outer_bndr bind = outer_bndr `elemVarSet` bindFreeVars bind + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) -- Whizzo: we can merge! @@ -702,11 +740,10 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) = do { (joins, alts) <- go body -- Check for capture; but only if we could otherwise do a merge - ; let capture = outer_bndr `elem` bindersOf bind - || outer_bndr `elemVarSet` bindFreeVars bind - ; guard (not capture) + -- (i.e. the recursive `go` succeeds) + ; guard (okToFloatJoin scrut_fvs outer_bndr bind) - ; return (bind:joins, alts ) } + ; return (bind : joins, alts ) } | otherwise = Nothing @@ -718,7 +755,18 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) go _ = Nothing -mergeCaseAlts _ _ = Nothing +mergeCaseAlts _ _ _ = Nothing + +okToFloatJoin :: VarSet -> Id -> CoreBind -> Bool +-- Check a join-point binding to see if it can be floated out of +-- the DEFAULT branch of a `case`. +-- See Note [Floating join points out of DEFAULT alternatives] +okToFloatJoin scrut_fvs outer_bndr bind + = not (any bad_bndr (bindersOf bind)) + where + bad_bndr bndr = bndr == outer_bndr -- (a) + || bndr `elemVarSet` scrut_fvs -- (b) + --------------------------------- mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] @@ -927,10 +975,46 @@ Wrinkles non-join-points unless the /outer/ case has just one alternative; doing so would risk more allocation + Floating out join points isn't entirely straightforward. + See Note [Floating join points out of DEFAULT alternatives] + (MC5) See Note [Cascading case merge] See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils +Note [Floating join points out of DEFAULT alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, from (MC4) of Note [Merge Nested Cases] + case x of r + DEFAULT -> join j = rhs in case r of ... + alts + +We want to float that join point out to give this + join j = rhs + case x of r + DEFAULT -> case r of ... + alts + +But doing so is flat-out wrong if the scoping gets messed up: + (a) case x of r { DEFAULT -> join r = ... in ...r... } + (b) case j of r { DEFAULT -> join j = ... in ... } + (c) case x of r { DEFAULT -> join j = ...r.. in ... } +In all these cases we can't float the join point out because r changes its +meaning. For (a) and (b) the Simplifier removes shadowing, so they'll +be solved in the next iteration. But case (c) will persist. + +Happily, we can fix up case (c) by adding an auxiliary binding, like this + let r = e in + join j = rhs[r] + case e of r + DEFAULT -> ...r... + ...other alts... + +We can only do this if + * We don't introduce shadowing: that is `j` and `r` do not appear free in `e`. + (Again the Simplifier will eliminate such shadowing.) + * The scrutinee `e` is trivial so that the transformation doesn't duplicate work. + Note [Cascading case merge] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== testsuite/tests/simplCore/should_compile/T26709.hs ===================================== @@ -0,0 +1,11 @@ +module T26709 where + +data T = A | B | C + +f x = case x of + A -> True + _ -> let {-# NOINLINE j #-} + j y = y && not (f x) + in case x of + B -> j True + C -> j False ===================================== testsuite/tests/simplCore/should_compile/T26709.stderr ===================================== @@ -0,0 +1,32 @@ +[1 of 1] Compiling T26709 ( T26709.hs, T26709.o ) + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 26, types: 9, coercions: 0, joins: 1/1} + +Rec { +-- RHS size: {terms: 25, types: 7, coercions: 0, joins: 1/1} +f [Occ=LoopBreaker] :: T -> Bool +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []] +f = \ (x :: T) -> + join { + j [InlPrag=NOINLINE, Dmd=MC(1,L)] :: Bool -> Bool + [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []] + j (eta [OS=OneShot] :: Bool) + = case eta of { + False -> GHC.Internal.Types.False; + True -> + case f x of { + False -> GHC.Internal.Types.True; + True -> GHC.Internal.Types.False + } + } } in + case x of { + A -> GHC.Internal.Types.True; + B -> jump j GHC.Internal.Types.True; + C -> jump j GHC.Internal.Types.False + } +end Rec } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -563,3 +563,8 @@ test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uni test('T26116', normal, compile, ['-O -ddump-rules']) test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T26349', normal, compile, ['-O -ddump-rules']) + +# T26709: we expect three `case` expressions not four +test('T26709', [grep_errmsg(r'case')], + multimod_compile, + ['T26709', '-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb9b4d9713a833a4477649dfbd7469... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb9b4d9713a833a4477649dfbd7469... You're receiving this email because of your account on gitlab.haskell.org.