Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 88657af0 by Simon Peyton Jones at 2025-12-16T09:11:10+00:00 Add better case merging - - - - - 395e1128 by Simon Peyton Jones at 2025-12-16T09:11:28+00:00 Flip the sense of BinderSwapDecision It was weird before, which led to a bug in my new patch - - - - - f4ca153a by Simon Peyton Jones at 2025-12-16T09:37:31+00:00 Do isReflexiveCo in the Simplifier - - - - - 6 changed files: - compiler/GHC/Core/Coercion.hs - 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 Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -709,7 +709,10 @@ isReflCo_maybe _ = Nothing -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCo :: Coercion -> Bool -isReflexiveCo = isJust . isReflexiveCo_maybe +isReflexiveCo (Refl {}) = True +isReflexiveCo (GRefl _ _ mco) = isReflKindMCo mco +isReflexiveCo (SymCo co) = isReflexiveCo co +isReflexiveCo co = coercionLKind co `eqType` coercionRKind co isReflexiveMCo :: MCoercion -> Bool isReflexiveMCo MRefl = True ===================================== 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 @@ -3535,6 +3535,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 }) @@ -3542,7 +3543,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 } @@ -3552,27 +3553,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 ) @@ -1531,7 +1531,8 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } - -> rebuild_go env (mkCast expr co') cont + | isReflexiveCo co -> rebuild_go env expr cont + | otherwise -> rebuild_go env (mkCast expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where co' = optOutCoercion env co opt @@ -3593,11 +3594,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 ===================================== @@ -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 ) @@ -2025,9 +2024,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/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, @@ -116,7 +117,6 @@ 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 +590,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,9 +673,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 @@ -665,6 +687,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! @@ -702,11 +727,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) + ; fix_up_binds <- okToFloatJoin bndr_swap outer_bndr bind - ; return (bind:joins, alts ) } + ; return (fix_up_binds ++ (bind : joins), alts ) } | otherwise = Nothing @@ -718,7 +742,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] @@ -927,10 +969,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/-/compare/52dbcf4b15f9dddd06931bae45ee5c5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/52dbcf4b15f9dddd06931bae45ee5c5... You're receiving this email because of your account on gitlab.haskell.org.