Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c7aa0c10 by Andreas Klebinger at 2025-06-15T05:47:24-04:00
Revert "Specialise: Don't float out constraint components."
This reverts commit c9abb87ccc0c91cd94f42b3e36270158398326ef.
Turns out two benchmarks from #19747 regresses by a factor of 7-8x if
we do not float those out.
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Specialise.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -64,7 +64,7 @@ import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
import Data.List( partition )
--- import Data.List.NonEmpty ( NonEmpty (..) )
+import Data.List.NonEmpty ( NonEmpty (..) )
import GHC.Core.Subst (substTickish)
{-
@@ -1277,8 +1277,67 @@ specCase :: SpecEnv
, OutId
, [OutAlt]
, UsageDetails)
--- We used to float out super class selections here,
--- but no longer do so. See Historical Note [Floating dictionaries out of cases]
+specCase env scrut' case_bndr [Alt con args rhs]
+ | -- See Note [Floating dictionaries out of cases]
+ interestingDict scrut' (idType case_bndr)
+ , not (isDeadBinder case_bndr && null sc_args')
+ = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
+
+ ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
+ scrut_bind = mkDB (NonRec case_bndr_flt scrut')
+
+ sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss
+ sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')
+ [Alt con args' (Var sc_arg')]
+ | sc_arg' <- sc_args' ]
+ cb_set = unitVarSet case_bndr_flt'
+ sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set }
+ | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]
+
+ flt_binds = scrut_bind : sc_binds
+
+ -- Extend the substitution for RHS to map the *original* binders
+ -- to their floated versions.
+ mb_sc_flts :: [Maybe DictId]
+ mb_sc_flts = map (lookupVarEnv clone_env) args'
+ clone_env = zipVarEnv sc_args' sc_args_flt'
+
+ subst_prs = (case_bndr, Var case_bndr_flt)
+ : [ (arg, Var sc_flt)
+ | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
+ subst' = se_subst env_rhs
+ `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')
+ `Core.extendIdSubstList` subst_prs
+ env_rhs' = env_rhs { se_subst = subst' }
+
+ ; (rhs', rhs_uds) <- specExpr env_rhs' rhs
+ ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
+ all_uds = flt_binds `consDictBinds` free_uds
+ alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')
+-- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
+ ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
+ where
+ (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
+ sc_args' = filter is_flt_sc_arg args'
+
+ clone_me bndr = do { uniq <- getUniqueM
+ ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
+ where
+ name = idName bndr
+ wght = idMult bndr
+ ty = idType bndr
+ occ = nameOccName name
+ loc = getSrcSpan name
+
+ arg_set = mkVarSet args'
+ is_flt_sc_arg var = isId var
+ && not (isDeadBinder var)
+ && isDictTy var_ty
+ && tyCoVarsOfType var_ty `disjointVarSet` arg_set
+ where
+ var_ty = idType var
+
+
specCase env scrut case_bndr alts
= do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
; return (scrut, case_bndr', alts', uds_alts) }
@@ -1355,36 +1414,36 @@ Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is,
if we run rules in the specialiser, does it matter if we make rules "win" over
inlining in the Simplifier? Yes, it does! See the discussion in #21851.
-Historical Note [Floating dictionaries out of cases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Function `specCase` used to give special treatment to a case-expression
-that scrutinised a dictionary, like this:
+Note [Floating dictionaries out of cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
g = \d. case d of { MkD sc ... -> ...(f sc)... }
-But actually
-
-* We never explicitly case-analyse a dictionary; rather the class-op
- rules select superclasses from it. (NB: worker/wrapper can unbox
- tuple dictionaries -- see (DNB1) in Note [Do not unbox class dictionaries];
- but that's only after worker/wrapper, and specialisation happens before
- that.)
-
-* Calling `interestingDict` on every scrutinee is hardly sensible;
- generally `interestingDict` is called only on Constraint-kinded things.
-
-* It was giving a Lint scope error in !14272
-
-So now there is no special case. This Note just records the change
-in case we ever want to reinstate it. The original note was
-added in
-
- commit c107a00ccf1e641a2d008939cf477c71caa028d5
- Author: Simon Peyton Jones