Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 9ec6b757 by Andreas Klebinger at 2025-04-26T12:37:22+02:00 Try simons version of isInterestingDict - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -14,8 +14,8 @@ 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.Multiplicity +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad @@ -66,6 +66,8 @@ import GHC.Core.Unfold import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1278,7 +1280,8 @@ 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 scrut' (idType case_bndr) + interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -3061,9 +3064,10 @@ 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 (ISE emptyInScopeSet realIdUnfolding) arg + -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg @@ -3169,33 +3173,47 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool +-- interestingDict :: CoreExpr -> Type -> Bool +interestingDict :: InScopeEnv -> CoreExpr -> 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 - -- No benefit to specalizing for a ~# b I believe - -- | (isEqPred arg_ty) = False - -- | - -- 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 (Lit{}) = True - go (Case{}) = True - go (Let{}) = True - go (App{}) = True - go (Lam{}) = True +interestingDict env (Cast arg _) + = interestingDict env arg +interestingDict env arg + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , (not . isIPLikePred) (exprType arg) + = if isCTupleClass cls + then any (interestingDict env) args + else True + | otherwise + = False + + +-- interestingDict arg _arg_ty +-- -- No benefit to specalizing for a ~# b I believe +-- -- | (isEqPred arg_ty) = False +-- -- | +-- -- 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 (Lit{}) = True +-- go (Case{}) = True +-- go (Let{}) = True +-- go (App{}) = True +-- go (Lam{}) = True -- go _ = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc97... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc97... You're receiving this email because of your account on gitlab.haskell.org.