Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: d8f1c49d by Simon Peyton Jones at 2025-10-21T17:00:59+01:00 Do not treat CoercionHoles as free variables in coercions This fixes a long-standing wart in the free-variable finder; now CoercionHoles are no longer treated as a "free variable" of a coercion. I got big and unexpected performance regressions when making this change. Turned out that CallArity didn't discover that the free variable finder could be eta-expanded, which gave very poor code. So I re-used Note [The one-shot state monad trick] for Endo, resulting in GHC.Utils.EndoOS. Very simple, big win. - - - - - c3413786 by Simon Peyton Jones at 2025-10-21T17:00:59+01:00 Fix buglet in solving equalities from QCIs - - - - - 23988363 by Simon Peyton Jones at 2025-10-21T17:00:59+01:00 Improve equality checking for foralls a bit ...by re-using the TcEvBindsVar - - - - - 5f0af575 by Simon Peyton Jones at 2025-10-21T17:00:59+01:00 Update debug-tracing in CallArity No effect on behaviour, and commented out anyway - - - - - 9 changed files: - compiler/GHC/Core/Opt/CallArity.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Unique/DSM.hs - + compiler/GHC/Utils/EndoOS.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Core/Opt/CallArity.hs ===================================== @@ -598,9 +598,8 @@ callArityBind boring_vars ae_body int (NonRec v rhs) -- Recursive let. See Note [Recursion and fixpointing] callArityBind boring_vars ae_body int b@(Rec binds) - = -- (if length binds > 300 then - -- pprTrace "callArityBind:Rec" - -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $ + = -- pprTrace "callArityBind:Rec" + -- (vcat [ppr (map fst binds), ppr ae_body, ppr int, ppr ae_rhs]) $ (final_ae, Rec binds') where -- See Note [Taking boring variables into account] @@ -614,7 +613,9 @@ callArityBind boring_vars ae_body int b@(Rec binds) fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)]) fix ann_binds - | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $ + | -- pprTrace "callArityBind:fix" (vcat + -- [ text "binds" <+> vcat [ppr (id,stuff) | (id,stuff,_rhs) <- ann_binds] + -- , ppr any_change, ppr ae]) $ any_change = fix ann_binds' | otherwise @@ -650,7 +651,12 @@ callArityBind boring_vars ae_body int b@(Rec binds) | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once | otherwise = calledMultipleTimes ae_rhs - i' = i `setIdCallArity` trimmed_arity + i' = -- (if trimmed_arity == new_arity then id else + -- pprTrace "trimming" + -- (vcat [ ppr i <+> ppr new_arity <+> ppr trimmed_arity + -- , text "safe" <+> ppr safe_arity + -- , text "is_thunk" <+> ppr is_thunk ])) $ + i `setIdCallArity` trimmed_arity in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs')) where ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -66,7 +66,10 @@ import GHC.Types.Unique.Set import GHC.Types.Var.Set import GHC.Types.Var.Env + import GHC.Utils.Misc +import GHC.Utils.EndoOS + import GHC.Data.Pair import Data.Semigroup @@ -285,9 +288,9 @@ done by the Call Arity pass. TL;DR: check this regularly! -} -runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet +runTyCoVars :: EndoOS TyCoVarSet -> TyCoVarSet {-# INLINE runTyCoVars #-} -runTyCoVars f = appEndo f emptyVarSet +runTyCoVars f = appEndoOS f emptyVarSet {- ********************************************************************* * * @@ -320,28 +323,37 @@ tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co tyCoVarsOfCos :: [Coercion] -> TyCoVarSet tyCoVarsOfCos cos = runTyCoVars (deep_cos cos) -deep_ty :: Type -> Endo TyCoVarSet -deep_tys :: [Type] -> Endo TyCoVarSet -deep_co :: Coercion -> Endo TyCoVarSet -deep_cos :: [Coercion] -> Endo TyCoVarSet +deep_ty :: Type -> EndoOS TyCoVarSet +deep_tys :: [Type] -> EndoOS TyCoVarSet +deep_co :: Coercion -> EndoOS TyCoVarSet +deep_cos :: [Coercion] -> EndoOS TyCoVarSet (deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet -deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +deepTcvFolder :: TyCoFolder TyCoVarSet (EndoOS TyCoVarSet) +-- It's important that we use a one-shot EndoOS, to ensure that all +-- the free-variable finders are eta-expanded. Lacking the one-shot-ness +-- led to some big slow downs. See Note [The one-shot state monad trick] +-- in GHC.Utils.Monad deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where - do_tcv is v = Endo do_it + do_tcv is v = EndoOS do_it where do_it acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc - | otherwise = appEndo (deep_ty (varType v)) $ + | otherwise = appEndoOS (deep_ty (varType v)) $ acc `extendVarSet` v + do_bndr :: TyCoVarSet -> TyVar -> ForAllTyFlag -> TyCoVarSet do_bndr is tcv _ = extendVarSet is tcv - do_hole is hole = do_tcv is (coHoleCoVar hole) - -- See Note [CoercionHoles and coercion free variables] - -- in GHC.Core.TyCo.Rep + + do_hole :: VarSet -> CoercionHole -> EndoOS TyCoVarSet + do_hole _is hole = deep_ty (varType (coHoleCoVar hole)) + -- We don't collect the CoercionHole itself, but we /do/ + -- need to collect the free variables of its /kind/ + -- See (CHFV1) in Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep {- ********************************************************************* * * @@ -378,18 +390,18 @@ shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) -- It's OK to use nonDetEltsUFM here because we immediately -- forget the ordering by returning a set -shallow_ty :: Type -> Endo TyCoVarSet -shallow_tys :: [Type] -> Endo TyCoVarSet -shallow_co :: Coercion -> Endo TyCoVarSet -shallow_cos :: [Coercion] -> Endo TyCoVarSet +shallow_ty :: Type -> EndoOS TyCoVarSet +shallow_tys :: [Type] -> EndoOS TyCoVarSet +shallow_co :: Coercion -> EndoOS TyCoVarSet +shallow_cos :: [Coercion] -> EndoOS TyCoVarSet (shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet -shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +shallowTcvFolder :: TyCoFolder TyCoVarSet (EndoOS TyCoVarSet) shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where - do_tcv is v = Endo do_it + do_tcv is v = EndoOS do_it where do_it acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc @@ -427,13 +439,13 @@ coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) coVarsOfCo co = runTyCoVars (deep_cv_co co) coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) -deep_cv_ty :: Type -> Endo CoVarSet -deep_cv_tys :: [Type] -> Endo CoVarSet -deep_cv_co :: Coercion -> Endo CoVarSet -deep_cv_cos :: [Coercion] -> Endo CoVarSet +deep_cv_ty :: Type -> EndoOS CoVarSet +deep_cv_tys :: [Type] -> EndoOS CoVarSet +deep_cv_co :: Coercion -> EndoOS CoVarSet +deep_cv_cos :: [Coercion] -> EndoOS CoVarSet (deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet -deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet) +deepCoVarFolder :: TyCoFolder TyCoVarSet (EndoOS CoVarSet) deepCoVarFolder = TyCoFolder { tcf_view = noView , tcf_tyvar = do_tyvar, tcf_covar = do_covar , tcf_hole = do_hole, tcf_tycobinder = do_bndr } @@ -445,17 +457,18 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView -- the tyvar won't end up in the accumulator, so -- we'd look repeatedly. Blargh. - do_covar is v = Endo do_it + do_bndr is tcv _ = extendVarSet is tcv + + do_covar is v = EndoOS do_it where do_it acc | v `elemVarSet` is = acc | v `elemVarSet` acc = acc - | otherwise = appEndo (deep_cv_ty (varType v)) $ + | otherwise = appEndoOS (deep_cv_ty (varType v)) $ acc `extendVarSet` v - do_bndr is tcv _ = extendVarSet is tcv - do_hole is hole = do_covar is (coHoleCoVar hole) - -- See Note [CoercionHoles and coercion free variables] - -- in GHC.Core.TyCo.Rep + do_hole _ _ = mempty + -- See (CHFV1) in Note [CoercionHoles and coercion free variables] + -- in GHC.Core.TyCo.Rep ------- Same again, but for DCoVarSet ---------- -- But this time the free vars are shallow @@ -480,7 +493,7 @@ closeOverKinds :: TyCoVarSet -> TyCoVarSet -- add the deep free variables of its kind closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs where - do_one v acc = appEndo (deep_ty (varType v)) acc + do_one v acc = appEndoOS (deep_ty (varType v)) acc {- --------------- Alternative version 1 (using FV) ------------ closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet @@ -661,9 +674,8 @@ tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_sc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc -tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc - = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc - -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (HoleCo {}) fv_cand in_scope acc = emptyFV fv_cand in_scope acc + -- Ignore holes: see (CHFV1) in Note [CoercionHoles and coercion free variables] tyCoFVsOfCo (AxiomCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc tyCoFVsOfCo (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps}) fv_cand in_scope acc = (tyCoFVsOfCos deps `unionFV` tyCoFVsOfType t1 ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1804,17 +1804,23 @@ Other notes about HoleCo: Note [CoercionHoles and coercion free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why does a CoercionHole contain a CoVar, as well as reference to -fill in? Because we want to treat that CoVar as a free variable of -the coercion. See #14584, and Note [What prevents a -constraint from floating] in GHC.Tc.Solver, item (4): +Why does a CoercionHole contain a CoVar, as well as reference to fill in? + * It really helps for debug pretty-printing. + * It carries a type which makes `coercionKind` and `coercionRole` work + * It has a Unique, which gives the hole an identity; see calls to `ctEvEvId` + +(CHFV1) We do not treat a CoercionHole as a free variable of a coercion. + In the past we did: See #14584, and Note [What prevents a constraint from floating] + in GHC.Tc.Solver, item (4): forall k. [W] co1 :: t1 ~# t2 |> co2 [W] co2 :: k ~# * -Here co2 is a CoercionHole. But we /must/ know that it is free in -co1, because that's all that stops it floating outside the -implication. + Here co2 is a CoercionHole. But we /must/ know that it is free in + co1, because that's all that stops it floating outside the + implication. + + But nowadays this is all irrelevant because we don't float constraints. Note [CoercionHoles and CoHoleSets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -554,24 +554,21 @@ can_eq_nc_forall ev eq_rel s1 s2 ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds) -- Solve the `wanteds` in a nested context - ; ev_binds_var <- newNoTcEvBinds + -- Use the /same/ TcEvBinds var as the context; we do not expect any dict binds + -- but we do want to record any used Given coercions (in `evb_tcvs`) so that + -- they are kept alive by `neededEvVars`. Admittedly they are free in `all_co`, + -- but only if we zonk it, which `neededEvVars` does not do (see test T7196). + ; ev_binds_var <- getTcEvBindsVar ; residual_wanted <- nestImplicTcS skol_info_anon ev_binds_var tclvl $ solveSimpleWanteds wanteds ; return (all_co, isSolvedWC residual_wanted) } - -- Kick out any inerts constraints that mention unified type variables ; kickOutAfterUnification unifs ; if solved - then do { all_co <- zonkCo all_co - -- setWantedEq will add `all_co` to the `ebv_tcvs`, to record - -- that `all_co` is used. But if `all_co` contains filled - -- CoercionHoles, from the nested solve, and we may miss the - -- use of CoVars. Test T7196 showed this up - - ; setWantedEq orig_dest emptyCoHoleSet all_co + then do { setWantedEq orig_dest emptyCoHoleSet all_co -- emptyCoHoleSet: fully solved, so all_co has no holes ; stopWith ev "Polytype equality: solved" } @@ -2935,8 +2932,7 @@ lookup_eq_in_qcis :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage () -- [W] t1 ~# t2 -- and a Given quantified contraint like (forall a b. blah => a ~ b) -- Why? See Note [Looking up primitive equalities in quantified constraints] --- See also GHC.Tc.Solver.Dict --- Note [Equality superclasses in quantified constraints] +-- See also GHC.Tc.Solver.Dict Note [Equality superclasses in quantified constraints] lookup_eq_in_qcis (CtGiven {}) _ _ _ = nopStage () @@ -2952,10 +2948,18 @@ lookup_eq_in_qcis ev@(CtWanted (WantedCt { ctev_dest = dest, ctev_loc = loc })) where hole = case dest of HoleDest hole -> hole -- Equality constraints have HoleDest - _ -> pprPanic "lookup_eq_in_qcis" (ppr dest) + _ -> pprPanic "lookup_eq_in_qcis" (ppr dest) try :: SwapFlag -> SolverStage () - try swap -- First try looking for (lhs ~ rhs) + -- E.g. We are trying to solve (say) + -- [W] g : [Int] ~# b) + -- from [G] forall x. blah => b ~ [x] -- A quantified constraint + -- We can solve it like this + -- d::b~[Int] := $df @Int blah -- Apply the quantified constraint + -- g'::b~#[Int] := sc_sel d -- Binding, extract the coercion from d + -- g(co-hole) := sym g' -- Fill the original coercion hole + -- Here g' is a fresh coercion variable. + try swap | Just (cls, tys) <- unSwap swap (boxEqPred eq_rel) lhs rhs = Stage $ do { let cls_pred = mkClassPred cls tys @@ -2965,7 +2969,7 @@ lookup_eq_in_qcis ev@(CtWanted (WantedCt { ctev_dest = dest, ctev_loc = loc })) OneInst {} -> do { dict_ev <- newWantedEvVarNC loc emptyCoHoleSet cls_pred ; chooseInstance dict_ev res - ; let co_var = coHoleCoVar hole + ; co_var <- newEvVar (unSwap swap (mkEqPred eq_rel) lhs rhs) ; setEvBind (mkWantedEvBind co_var EvCanonical (mk_sc_sel cls tys dict_ev)) ; fillCoercionHole hole emptyCoHoleSet $ maybeSymCo swap (mkCoVarCo co_var) ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -392,6 +392,8 @@ data EvBindsVar -- so that we can report unused given constraints, -- in GHC.Tc.Solver.neededEvVars -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + -- Also: we garbage-collect unused bindings in `neededEvVars`, + -- so this matters for correctness too. } | CoEvBindsVar { -- See Note [Coercion evidence only] ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -234,9 +234,11 @@ import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey , listTyCon, constraintKind ) import GHC.Types.Basic -import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.List.SetOps ( getNth, findDupsEq ) + +import GHC.Utils.Misc +import GHC.Utils.EndoOS import GHC.Utils.Outputable import GHC.Utils.Panic @@ -1176,11 +1178,11 @@ exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) -exact_ty :: Type -> Endo TyCoVarSet -exact_tys :: [Type] -> Endo TyCoVarSet +exact_ty :: Type -> EndoOS TyCoVarSet +exact_tys :: [Type] -> EndoOS TyCoVarSet (exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet -exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) +exactTcvFolder :: TyCoFolder TyCoVarSet (EndoOS TyCoVarSet) exactTcvFolder = deepTcvFolder { tcf_view = coreView } -- This is the key line ===================================== compiler/GHC/Types/Unique/DSM.hs ===================================== @@ -168,7 +168,7 @@ instance MonadGetUnique USM.UniqSM where newtype UniqDSMT m result = UDSMT' (DUniqSupply -> m (result, DUniqSupply)) deriving (Functor) --- Similar to GHC.Utils.Monad.State.Strict, using Note [The one-shot state monad trick] +-- Similar to GHC.Utils.Monad, using Note [The one-shot state monad trick] -- Using the one-shot trick is necessary for performance. -- Using transfomer's strict `StateT` regressed some performance tests in 1-2%. -- The one-shot trick here fixes those regressions. ===================================== compiler/GHC/Utils/EndoOS.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | One-shot endomorphisms +-- Mostly for backwards compatibility. + +-- One-shot endomorphisms +-- Like GHC.Internal.Data.Semigroup.Internal.Endo, but uting +-- the one-shot trick from +-- Note [The one-shot state monad trick] in GHC.Utils.Monad. + +module GHC.Utils.EndoOS( EndoOS(EndoOS, appEndoOS ) ) where + +import GHC.Prelude + +import Data.Semigroup +import GHC.Exts (oneShot) + +newtype EndoOS a = EndoOS' { appEndoOS :: a -> a } + + +instance Semigroup (EndoOS a) where + f <> g = EndoOS (appEndoOS f . appEndoOS g) + +instance Monoid (EndoOS a) where + mempty = EndoOS id + +pattern EndoOS :: (a->a) -> EndoOS a +pattern EndoOS f <- EndoOS' f + where + EndoOS f = EndoOS' (oneShot f) + -- ^^^^^^ The one-shot trick! ===================================== compiler/ghc.cabal.in ===================================== @@ -997,6 +997,7 @@ Library GHC.Utils.Containers.Internal.BitUtil GHC.Utils.Containers.Internal.StrictPair GHC.Utils.Error + GHC.Utils.EndoOS GHC.Utils.Exception GHC.Utils.Fingerprint GHC.Utils.FV View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/861d46ce0292a867a25f648d8c552ea... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/861d46ce0292a867a25f648d8c552ea... You're receiving this email because of your account on gitlab.haskell.org.