Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: be412c3e by Andreas Klebinger at 2025-05-19T13:59:09+02:00 Specialse: Specialise on Dictionaries with Opaque types. Surfaced by #19747 I realized that sometimes we end up with types like `SomeTyFam Foo` which represent a concrete deterministic dictionary but in the specializer we can't infer this just from the Type. So when deciding if a dictionary should be specialized on we now look at the argument term *and* types. `Note [Interesting dictionary arguments]` has all the details. - - - - - 15 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/simplCore/should_compile/SpecTyFam.hs - + testsuite/tests/simplCore/should_compile/SpecTyFam.stderr - + testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -14,9 +16,9 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -import GHC.Core.Multiplicity -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate +import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core @@ -26,16 +28,16 @@ import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable - , mkCast, exprType + , mkCast, exprType, exprIsHNF , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) --- import GHC.Core.Ppr( pprIds ) +import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( maybeToList, isJust ) +import GHC.Data.Maybe ( maybeToList, isJust, expectJust ) import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -64,8 +66,12 @@ import GHC.Unit.Module.ModGuts import GHC.Core.Unfold import Data.List( partition ) -import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.List.NonEmpty as NE( nonEmpty, NonEmpty(..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) + +import Control.Monad {- ************************************************************************ @@ -1279,9 +1285,9 @@ specCase :: SpecEnv , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] - interestingDict scrut' (idType case_bndr) + interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') - = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| 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') @@ -1317,7 +1323,8 @@ specCase env scrut' case_bndr [Alt con args 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) + (env_rhs, bndrs'::[CoreBndr]) = substBndrs env (case_bndr:args) + (case_bndr':|args') = expectJust (NE.nonEmpty bndrs' :: Maybe (NonEmpty CoreBndr)) sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM @@ -1332,7 +1339,6 @@ specCase env scrut' case_bndr [Alt con args rhs] 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 @@ -1644,9 +1650,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- switch off specialisation for inline functions = -- pprTrace "specCalls: some" (vcat - -- [ text "function" <+> ppr fn - -- , text "calls:" <+> ppr calls_for_me - -- , text "subst" <+> ppr (se_subst env) ]) $ + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) $ foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions @@ -1694,21 +1700,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args --- ; pprTrace "spec_call" (vcat --- [ text "fun: " <+> ppr fn --- , text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs1:" <+> ppr spec_bndrs1 --- , text "leftover_bndrs:" <+> pprIds leftover_bndrs --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_bndrs" <+> ppr rhs_bndrs --- , text "rhs_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + ; when False $ pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "rule_bndrs:" <+> ppr rule_bndrs + , text "lhs_args: " <+> ppr rule_lhs_args + , text "spec_bndrs1:" <+> ppr spec_bndrs1 + , text "leftover_bndrs:" <+> pprIds leftover_bndrs + , text "spec_args: " <+> ppr spec_args + , text "dx_binds: " <+> ppr dx_binds + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body + , text "rhs_env2: " <+> ppr (se_subst rhs_env2) + , ppr dx_binds ]) $ + return () ; let all_rules = rules_acc ++ existing_rules -- all_rules: we look both in the rules_acc (generated by this invocation @@ -3102,30 +3108,15 @@ mkCallUDs' env f args -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon pred af) + mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict arg (scaledThing pred) + , interestingDict env arg + -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg -{- -Note [Ticks on applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticks such as source location annotations can sometimes make their way -onto applications (see e.g. #21697). So if we see something like - - App (Tick _ f) e - -we need to descend below the tick to find what the real function being -applied is. - -The resulting RULE also has to be able to match this annotated use -site, so we only look through ticks that RULE matching looks through -(see Note [Tick annotations in RULE matching] in GHC.Core.Rules). --} - wantCallsFor :: SpecEnv -> Id -> Bool -- See Note [wantCallsFor] wantCallsFor _env f @@ -3145,8 +3136,60 @@ wantCallsFor _env f WorkerLikeId {} -> True RepPolyId {} -> True -{- Note [wantCallsFor] -~~~~~~~~~~~~~~~~~~~~~~ +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- This is a subtle and important function +-- See Note [Interesting dictionary arguments] +interestingDict env (Var v) -- See (ID3) and (ID5) + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v) + -- might fail for loop breaker dicts but that seems fine. + = interestingDict env rhs + +interestingDict env arg -- Main Plan: use exprIsConApp_maybe + | Cast inner_arg _ <- arg -- See (ID5) + = if | isConstraintKind $ typeKind $ exprType inner_arg + -- If coercions were always homo-kinded, we'd know + -- that this would be the only case + -> interestingDict env inner_arg + + -- Check for an implicit parameter at the top + | Just (cls,_) <- getClassPredTys_maybe arg_ty + , isIPClass cls -- See (ID4) + -> False + + -- Otherwise we are unwrapping a unary type class + | otherwise + -> exprIsHNF arg -- See (ID7) + + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , not_ip_like -- See (ID4) + = if null (classMethods cls) -- See (ID6) + then any (interestingDict env) args + else True + + | otherwise + = not (exprIsTrivial arg) && not_ip_like -- See (ID8) + where + arg_ty = exprType arg + not_ip_like = not (couldBeIPLike arg_ty) + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding + +{- Note [Ticks on applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticks such as source location annotations can sometimes make their way +onto applications (see e.g. #21697). So if we see something like + + App (Tick _ f) e + +we need to descend below the tick to find what the real function being +applied is. + +The resulting RULE also has to be able to match this annotated use +site, so we only look through ticks that RULE matching looks through +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules). + +Note [wantCallsFor] +~~~~~~~~~~~~~~~~~~~ `wantCallsFor env f` says whether the Specialiser should collect calls for function `f`; other thing being equal, the fewer calls we collect the better. It is False for things we can't specialise: @@ -3172,44 +3215,91 @@ collect usage info for imported overloaded functions. Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In `mkCallUDs` we only use `SpecDict` for dictionaries of which -`interestingDict` holds. Otherwise we use `UnspecArg`. Two reasons: - -* Consider this - \a.\d:Eq a. let f = ... in ...(f d)... - There really is not much point in specialising f wrt the dictionary d, - because the code for the specialised f is not improved at all, because - d is lambda-bound. We simply get junk specialisations. - -* Consider this (#25703): - f :: (Eq a, Show b) => a -> b -> INt - goo :: forall x. (Eq x) => x -> blah - goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)... - If we built a `ci_key` with a (SpecDict d) for `d`, we would end up - discarding the call at the `\d`. But if we use `UnspecArg` for that - uninteresting `d`, we'll get a `ci_key` of - f @x @Int UnspecArg (SpecDict $fShowInt) - and /that/ can float out to f's definition and specialise nicely. - Hooray. (NB: the call can float only if `-fpolymorphic-specialisation` - is on; otherwise it'll be trapped by the `\@x -> ...`.)( - -What is "interesting"? (See `interestingDict`.) Just that it has *some* -structure. But what about variables? We look in the variable's /unfolding/. -And that means that we must be careful to ensure that dictionaries /have/ -unfoldings, - -* cloneBndrSM discards non-Stable unfoldings -* specBind updates the unfolding after specialisation - See Note [Update unfolding after specialisation] -* bindAuxiliaryDict adds an unfolding for an aux dict - see Note [Specialisation modulo dictionary selectors] -* specCase adds unfoldings for the new bindings it creates - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables didn't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see +if the argument is a dictionary constructor applied to some arguments, in which +case we can clearly specialise. But there are wrinkles: + +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the + argument is + (% d1, d2 %) |> co + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family. + Then its type (F Int a) looks very un-informative, but the term is super + helpful. See #19747 (where missing this point caused a 70x slow down) + and #7785. + +(ID2) Note that the Main Plan works fine for an argument that is a DFun call, + e.g. $fOrdList $dOrdInt + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good! + +(ID3) For variables, we look in the variable's /unfolding/. And that means + that we must be careful to ensure that dictionaries /have/ unfoldings: + * cloneBndrSM discards non-Stable unfoldings + * specBind updates the unfolding after specialisation + See Note [Update unfolding after specialisation] + * bindAuxiliaryDict adds an unfolding for an aux dict + see Note [Specialisation modulo dictionary selectors] + * specCase adds unfoldings for the new bindings it creates + + We accidentally lost accurate tracking of local variables for a long + time, because cloned variables didn't have unfoldings. But makes a + massive difference in a few cases, eg #5113. For nofib as a + whole it's only a small win: 2.2% improvement in allocation for ansi, + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. + +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains + an implicit parameter, because implicit parameters are emphatically not singleton + types. See #25999: + useImplicit :: (?i :: Int) => Int + useImplicit = ?i + 1 + + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit) + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values. + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`. + +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type + constructor at the top of both sides. But see the example in (ID1), where that + is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look + through unfoldings (because there might be a cast inside), hence dealing with + expandable unfoldings in `interestingDict` directly. + +(ID6) The Main Plan says that it's worth specialising if the argument is an application + of a dictionary contructor. But what if the dictionary has no methods? Then we + gain nothing by specialising, unless the /superclasses/ are interesting. A case + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class + with N superclasses and no methods. + +(ID7) A unary (single-method) class is currently represented by (meth |> co). We + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a + new story for unary classes, see #23109, and this special case will become + irrelevant.) + +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a + non-trivial argument as interesting. In T19695 we have this: + askParams :: Monad m => blah + mhelper :: MonadIO m => blah + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d)).... + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is + specialised at `Handler` we'll get this call in the specialised `$smhelper`: + askParams @Handler ($p1 $fMonadIOHandler) + and we /definitely/ want to specialise that, even though the argument isn't + visibly a dictionary application. In fact the specialiser fires the superclass + selector rule (see Note [Fire rules in the specialiser]), so we get + askParams @Handler ($cp1MonadIO $fMonadIOIO) + but it /still/ doesn't look like a dictionary application. + + Conclusion: we optimistically assume that any non-trivial argument is worth + specialising on. + + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look + under type-family casts (ID1) and constraint tuples (ID6). Note [Update unfolding after specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3237,6 +3327,7 @@ Consider (#21848) Now `f` turns into: f @a @b (dd :: D a) (ds :: Show b) a b + = let dc :: D a = %p1 dd -- Superclass selection in meth @a dc .... meth @a dc .... @@ -3252,27 +3343,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool --- A dictionary argument is interesting if it has *some* structure, --- see Note [Interesting dictionary arguments] --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case --- To make this work, we need to ensure that dictionaries have --- unfoldings in them. -interestingDict arg arg_ty - | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] - | otherwise = go arg - where - go (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - go (Type _) = False - go (Coercion _) = False - go (App fn (Type _)) = go fn - go (App fn (Coercion _)) = go fn - go (Tick _ a) = go a - go (Cast e _) = go e - go _ = True - thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) (MkUD {ud_binds = db2, ud_calls = calls2}) ===================================== compiler/GHC/Core/Predicate.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Predicate ( classMethodTy, classMethodInstTy, -- Implicit parameters - isIPLikePred, mentionsIP, isIPTyCon, isIPClass, + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, isCallStackTy, isCallStackPred, isCallStackPredTy, isExceptionContextPred, isExceptionContextTy, isIPPred_maybe, @@ -125,9 +125,12 @@ isDictTy ty = isClassPred pred where (_, pred) = splitInvisPiTys ty +-- | Is the type *guaranteed* to determine the value? +-- +-- Might say No even if the type does determine the value. (See the Note) typeDeterminesValue :: Type -> Bool -- See Note [Type determines value] -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty) getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of @@ -170,6 +173,10 @@ So we treat implicit params just like ordinary arguments for the purposes of specialisation. Note that we still want to specialise functions with implicit params if they have *other* dicts which are class params; see #17930. + +It's also not always possible to infer that a type determines the value +if type families are in play. See #19747 for one such example. + -} -- --------------------- Equality predicates --------------------------------- @@ -410,44 +417,44 @@ isCallStackTy ty | otherwise = False --- --------------------- isIPLike and mentionsIP -------------------------- +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- -- See Note [Local implicit parameters] -isIPLikePred :: Type -> Bool +couldBeIPLike :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters] -isIPLikePred pred = - mentions_ip_pred initIPRecTc (const True) (const True) pred - -mentionsIP :: (Type -> Bool) -- ^ predicate on the string - -> (Type -> Bool) -- ^ predicate on the type - -> Class - -> [Type] -> Bool --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if: +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred + +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string + -> (Type -> Bool) -- ^ predicate on the type + -> Class + -> [Type] -> Bool +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: -- -- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ -- are both @True@, -- - or any superclass of @cls tys@ has this property. -- -- See Note [Local implicit parameters] -mentionsIP = mentions_ip initIPRecTc +mightMentionIP = might_mention_ip initIPRecTc -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool -mentions_ip rec_clss str_cond ty_cond cls tys +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool +might_mention_ip rec_clss str_cond ty_cond cls tys | Just (str_ty, ty) <- isIPPred_maybe cls tys = str_cond str_ty && ty_cond ty | otherwise - = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) | sc_sel_id <- classSCSelIds cls ] -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool -mentions_ip_pred rec_clss str_cond ty_cond ty +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool +might_mention_ip1 rec_clss str_cond ty_cond ty | Just (cls, tys) <- getClassPredTys_maybe ty , let tc = classTyCon cls , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss else checkRecTc rec_clss tc - = mentions_ip rec_clss' str_cond ty_cond cls tys + = might_mention_ip rec_clss' str_cond ty_cond cls tys | otherwise = False -- Includes things like (D []) where D is -- a Constraint-ranged family; #7785 @@ -460,7 +467,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict. -The function isIPLikePred tells if this predicate, or any of its +The function couldBeIPLike tells if this predicate, or any of its superclasses, is an implicit parameter. Why are implicit parameters special? Unlike normal classes, we can @@ -468,7 +475,7 @@ have local instances for implicit parameters, in the form of let ?x = True in ... So in various places we must be careful not to assume that any value of the right type will do; we must carefully look for the innermost binding. -So isIPLikePred checks whether this is an implicit parameter, or has +So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter. Several wrinkles @@ -509,16 +516,16 @@ Small worries (Sept 20): think nothing does. * I'm a little concerned about type variables; such a variable might be instantiated to an implicit parameter. I don't think this - matters in the cases for which isIPLikePred is used, and it's pretty + matters in the cases for which couldBeIPLike is used, and it's pretty obscure anyway. * The superclass hunt stops when it encounters the same class again, but in principle we could have the same class, differently instantiated, and the second time it could have an implicit parameter I'm going to treat these as problems for another day. They are all exotic. -Note [Using typesAreApart when calling mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call 'mentionsIP' in two situations: +Note [Using typesAreApart when calling mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call 'mightMentionIP' in two situations: (1) to check that a predicate does not contain any implicit parameters IP str ty, for a fixed literal str and any type ty, ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -1928,7 +1928,7 @@ growThetaTyVars theta tcvs | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPLikePred theta + (ips, non_ips) = partition couldBeIPLike theta -- See Note [Inheriting implicit parameters] mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i -- programs should typecheck regardless of whether we take this step or -- not. See Note [Shortcut solving] - , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) + , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627) , not (xopt LangExt.IncoherentInstances dflags) -- If IncoherentInstances is on then we cannot rely on coherence of proofs ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -2043,10 +2043,10 @@ solveOneFromTheOther ct_i ct_w is_wsc_orig_w = isWantedSuperclassOrigin orig_w different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of implicit parameters] + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters] -- in GHC.Tc.Solver.Dict same_level_strategy -- Both Given ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -403,8 +403,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? does_not_mention_ip_for :: Type -> DictCt -> Bool does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys - -- See Note [Using typesAreApart when calling mentionsIP] + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys + -- See Note [Using typesAreApart when calling mightMentionIP] -- in GHC.Core.Predicate updInertIrreds :: IrredCt -> TcS () @@ -544,7 +544,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName ; let contains_callstack_or_exceptionCtx = - mentionsIP + mightMentionIP (const True) -- NB: the name of the call-stack IP is irrelevant -- e.g (?foo :: CallStack) counts! @@ -562,9 +562,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) -- Return a predicate that decides whether a type is CallStack -- or ExceptionContext, accounting for e.g. type family reduction, as - -- per Note [Using typesAreApart when calling mentionsIP]. + -- per Note [Using typesAreApart when calling mightMentionIP]. -- - -- See Note [Using isCallStackTy in mentionsIP]. + -- See Note [Using isCallStackTy in mightMentionIP]. is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) is_tyConTy is_eq tc_name = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name @@ -592,14 +592,14 @@ in a different context! See also Note [Shadowing of implicit parameters], which deals with a similar problem with Given implicit parameter constraints. -Note [Using isCallStackTy in mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Using isCallStackTy in mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To implement Note [Don't add HasCallStack constraints to the solved set], we need to check whether a constraint contains a HasCallStack or HasExceptionContext constraint. We do this using the 'mentionsIP' function, but as per -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do: +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do: - mentionsIP + mightMentionIP (const True) -- (ignore the implicit parameter string) (isCallStackTy <||> isExceptionContextTy) ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType ( mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - isClassPred, isEqPred, isIPLikePred, isEqClassPred, + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, isEqualityClass, mkClassPred, tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, @@ -1819,7 +1819,7 @@ pickCapturedPreds pickCapturedPreds qtvs theta = filter captured theta where - captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) -- Superclasses ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +module Main(main) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# NOINLINE foo #-} +foo :: Int -> (String,Int) +-- We want specMe to be specialized, but not inlined +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.stdout ===================================== @@ -0,0 +1 @@ +500500 ===================================== testsuite/tests/perf/should_run/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -423,3 +423,12 @@ test('ByteCodeAsm', ], compile_and_run, ['-package ghc']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +# See also #19747 +test('SpecTyFamRun', [ grep_errmsg(r'foo') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm']) + , collect_stats('bytes allocated', 5)], + multimod_compile_and_run, + ['SpecTyFamRun', '-O2']) ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} + +module SpecTyFam(main, foo) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# OPAQUE foo #-} +foo :: Int -> (String,Int) +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.stderr ===================================== @@ -0,0 +1,78 @@ +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1} + +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1} +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n) +[LclIdX, + Arity=4, + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10 + Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}] +specMe + = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) } + + + +[2 of 2] Compiling SpecTyFam ( SpecTyFam.hs, SpecTyFam.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1} + +Rec { +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0} +$dCTuple2 :: (Show Bool, Num Int) +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt) + +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1} +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #) +[LclId, Arity=2] +$s$wspecMe + = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> + let { + $dNum :: Num Int + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] + $dNum = GHC.Internal.Num.$fNumInt } in + case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) } + +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0} +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int) +[LclId, + Arity=2, + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) + Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}] +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) } +end Rec } + +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0} +foo [InlPrag=OPAQUE] :: Int -> (String, Int) +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}] +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x + +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0} +main :: State# RealWorld -> (# State# RealWorld, () #) +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}] +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +main :: IO () +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ()) + + +------ Local rules for imported ids -------- +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe + + ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImplicitParams #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -548,3 +548,9 @@ test('T25965', normal, compile, ['-O']) test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings']) +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +test('SpecTyFam', [ grep_errmsg(r'\$wspecMe') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm'])], + multimod_compile, + ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be412c3ea2868c38e5c0198e19b89df97b88b0ae -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be412c3ea2868c38e5c0198e19b89df97b88b0ae You're receiving this email because of your account on gitlab.haskell.org.