Simon Peyton Jones pushed to branch wip/T26615 at Glasgow Haskell Compiler / GHC Commits: 0e70ef52 by Simon Peyton Jones at 2025-11-29T23:21:57+00:00 Add better case merging - - - - - 6 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/Opt/Specialise.hs - compiler/GHC/Core/Utils.hs 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 @@ -3446,6 +3446,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 }) @@ -3463,27 +3464,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 ) ===================================== 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 ===================================== @@ -30,7 +30,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 ) @@ -2026,9 +2025,9 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) -- , text "spec_call_args" <+> ppr spec_call_args -- , text "rule_rhs" <+> ppr rule_rhs -- , text "adds_void_worker_arg" <+> ppr add_void_arg ----- , text "body" <+> ppr body ----- , text "spec_rhs" <+> ppr spec_rhs ----- , text "how_bound" <+> ppr (sc_how_bound env) ] +-- , text "body" <+> ppr body +-- , text "spec_rhs" <+> ppr spec_rhs +-- , text "how_bound" <+> ppr (sc_how_bound env) ] -- ] ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1798,8 +1798,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "rule_act" <+> ppr rule_act ] - ; pprTrace "spec_call: rule" _rule_trace_doc - return ( spec_rule : rules_acc + ; return ( spec_rule : rules_acc , (spec_fn, spec_rhs1) : pairs_acc , rhs_uds2 `thenUDs` uds_acc ) } } ===================================== 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, @@ -117,7 +118,6 @@ import Data.Function ( on ) import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) import qualified Data.List as Partial ( init, last ) import Data.Ord ( comparing ) -import Control.Monad ( guard ) import qualified Data.Set as Set {- @@ -591,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 +-- 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 +-- +-- 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 (mkSymCo 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) @@ -652,9 +674,9 @@ 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) -- NB: mergeAlts gives priority to the left @@ -666,6 +688,9 @@ 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 + bndr_swap :: BinderSwapDecision + bndr_swap = scrutOkForBinderSwap scrut + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) -- Whizzo: we can merge! @@ -704,16 +729,9 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) -- Check for capture; but only if we could otherwise do a merge -- (i.e. the recursive `go` succeeds) - -- "Capture" means - -- (a) case x of r { DEFAULT -> join r = ... in ...r... } - -- (b) case x of r { DEFAULT -> join j = ...r.. in ... } - -- In both cases we can't float the join point out - -- because r changes its meaning - ; let capture = outer_bndr `elem` bindersOf bind -- (a) - || outer_bndr `elemVarSet` bindFreeVars bind -- (b) - ; guard (not capture) - - ; return (bind:joins, alts ) } + ; fix_up_binds <- okToFloatJoin bndr_swap outer_bndr bind + + ; return (fix_up_binds ++ (bind : joins), alts ) } | otherwise = Nothing @@ -725,7 +743,25 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) go _ = Nothing -mergeCaseAlts _ _ = Nothing +mergeCaseAlts _ _ _ = Nothing + +okToFloatJoin :: BinderSwapDecision -> Id -> CoreBind -> Maybe [CoreBind] +-- Check a join-point binding to see if it can be floated out of +-- the DEFAULT branch of a `case`. A Just result means "yes", +-- and the [CoreBInd] are the extra fix-up bindings to add. +-- See Note [Floating join points out of DEFAULT alternatives] +okToFloatJoin bndr_swap outer_bndr bind + | outer_bndr `elem` bindersOf bind -- (a) + = Nothing + | outer_bndr `elemVarSet` bindFreeVars bind -- (b) + = case bndr_swap of + DoBinderSwap scrut_var mco + | scrut_var /= outer_bndr + -> Just [ NonRec outer_bndr (mkCastMCo (Var scrut_var) mco) ] + _ -> Nothing + | otherwise + = Just [] + --------------------------------- mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] @@ -934,10 +970,43 @@ 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 x of r { DEFAULT -> join j = ...r.. in ... } +In both cases we can't float the join point out because r changes its meaning. + +BUT we can fix up case (b) by adding an extra binding, like this + let r = x in + join j = rhs[r] + case x of r + DEFAULT -> ...r... + ...other alts... + +This extra binding is figured out by `okToFloatJoin`. + +Note that the cases that still don't work (e.g. (a)) will probably work fine the +next iteration of the Simplifier, because they involve shadowing, and the Simplifier +generally eliminates shadowing. Note [Cascading case merge] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e70ef52af7368cc12525e4502904b32... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e70ef52af7368cc12525e4502904b32... You're receiving this email because of your account on gitlab.haskell.org.