Simon Peyton Jones pushed to branch wip/T26709 at Glasgow Haskell Compiler / GHC Commits: 1cb9b4d9 by Simon Peyton Jones at 2025-12-31T09:41:09+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] - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify/Utils.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/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/Utils.hs ===================================== @@ -73,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 ) @@ -113,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 {- @@ -674,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 @@ -688,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! @@ -725,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 @@ -741,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] @@ -950,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/-/commit/1cb9b4d9713a833a4477649dfbd74696... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cb9b4d9713a833a4477649dfbd74696... You're receiving this email because of your account on gitlab.haskell.org.