diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Opt/SpecConstr.hs | 55 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 61 | ||||
| -rw-r--r-- | compiler/GHC/Core/Predicate.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 146 |
4 files changed, 172 insertions, 109 deletions
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 173d546b73..d3cf764be0 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -28,13 +28,14 @@ import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold -import GHC.Core.FVs ( exprsFreeVarsList ) +import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules +import GHC.Core.Predicate ( typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity @@ -1811,6 +1812,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) -- return () -- And build the results + ; (qvars', pats') <- generaliseDictPats qvars pats ; let spec_body_ty = exprType spec_body (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1) = calcSpecInfo fn call_pat extra_bndrs @@ -1848,7 +1850,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) inline_act = idInlineActivation fn this_mod = sc_module $ sc_opts env rule = mkRule this_mod True {- Auto -} True {- Local -} - rule_name inline_act fn_name qvars pats rule_rhs + rule_name inline_act + fn_name qvars' pats' rule_rhs -- See Note [Transfer activation] -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn)) @@ -1870,6 +1873,27 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) , os_id = spec_id , os_rhs = spec_rhs }) } +generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats + -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats +-- See Note [generaliseDictPats] +generaliseDictPats qvars pats + = do { (extra_qvars, pats') <- mapAccumLM go [] pats + ; case extra_qvars of + [] -> return (qvars, pats) + _ -> return (qvars ++ extra_qvars, pats') } + where + qvar_set = mkVarSet qvars + go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr) + go extra_qvs pat + | not (isTyCoArg pat) + , let pat_ty = exprType pat + , typeDeterminesValue pat_ty + , exprFreeVars pat `disjointVarSet` qvar_set + = do { id <- mkSysLocalOrCoVarM (fsLit "dict") Many pat_ty + ; return (id:extra_qvs, Var id) } + | otherwise + = return (extra_qvs, pat) + -- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr mkSeqs seqees res_ty rhs = @@ -1910,6 +1934,33 @@ Now we get: $sf void @t = $se RULE: f True = $sf void# And now we can substitute `f True` with `$sf void#` with everything working out nicely! + +Note [generaliseDictPats] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two rules (#21831, item 2): + RULE "SPEC:foo" forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1 + RULE "SC:foo" forall a. foo @Int @a $fNumInteger = $sfoo2 @a +The former comes from the type class specialiser, the latter from SpecConstr. +Note that $fNumInteger is a top-level binding for Num Integer. + +The trouble is that neither is more general than the other. In a call + (foo @Int @Integer $fNumInteger d) +it isn't clear which rule to fire. + +The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger, +but actually /could/ fire regardless. That is, it could be + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +Now, it is clear that SPEC:foo is more specific. But GHC can't tell +that, because SpecConstr doesn't know that dictionary arguments are +singleton types! So generaliseDictPats teaches it this fact. It +spots such patterns (using typeDeterminesValue), and quantifies over +the dictionary. Now we get + + RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a + +And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new +"SC:foo" to match the (prefix of) "SPEC:foo". -} calcSpecInfo :: Id -- The original function diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 74a903fbc8..9d948765aa 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -13,7 +13,6 @@ module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) @@ -34,15 +33,13 @@ import GHC.Core.Utils ( exprIsTrivial , stripTicksTop ) import GHC.Core.FVs import GHC.Core.TyCo.Rep (TyCoBinder (..)) -import GHC.Core.Opt.Arity ( collectBindersPushingCo - , etaExpandToJoinPointRule ) +import GHC.Core.Opt.Arity( collectBindersPushingCo ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Data.Maybe ( maybeToList, isJust ) import GHC.Data.Bag import GHC.Data.OrdList -import GHC.Data.FastString import GHC.Data.List.SetOps import GHC.Types.Basic @@ -1577,7 +1574,7 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) (spec_bndrs, spec_rhs, spec_fn_ty) | add_void_arg = ( voidPrimId : spec_bndrs1 - , Lam voidArgId spec_rhs1 + , Lam voidArgId spec_rhs1 , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) @@ -1598,28 +1595,9 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs | otherwise = -- Specialising local fn text "SPEC" - rule_name = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (mapMaybe ppr_call_key_ty call_args) - -- This name ends up in interface files, so use occNameString. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - - rule_wout_eta = mkRule - this_mod - True {- Auto generated -} - is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - rule_bndrs - rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) - - spec_rule - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta - Nothing -> rule_wout_eta + spec_rule = mkSpecRule dflags this_mod True inl_act + herald fn rule_bndrs rule_lhs_args + (mkVarApps (Var spec_fn) spec_bndrs) -- Add the { d1' = dx1; d2' = dx2 } usage stuff -- See Note [Specialising Calls] @@ -1675,7 +1653,6 @@ specLookupRule env fn args rules in_scope = Core.substInScope (se_subst env) ropts = initRuleOpts dflags - {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DFuns have a special sort of unfolding (DFunUnfolding), and these are @@ -2630,12 +2607,6 @@ pprCallInfo :: Id -> CallInfo -> SDoc pprCallInfo fn (CI { ci_key = key }) = ppr fn <+> ppr key -ppr_call_key_ty :: SpecArg -> Maybe SDoc -ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty -ppr_call_key_ty UnspecType = Just $ char '_' -ppr_call_key_ty (SpecDict _) = Nothing -ppr_call_key_ty UnspecArg = Nothing - instance Outputable CallInfo where ppr (CI { ci_key = key, ci_fvs = _fvs }) = text "CI" <> braces (sep (map ppr key)) @@ -2767,20 +2738,8 @@ wantCallsFor _env _f = True -- all in one place. So we simply collect usage info for imported -- overloaded functions. -{- Note [Type determines value] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only specialise on non-impicit-parameter predicates, because these -are the ones whose *type* determines their *value*. In particular, -with implicit params, the type args *don't* say what the value of the -implicit param is! See #7101. - -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. - -Note [Interesting dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this \a.\d:Eq a. let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d, @@ -2845,10 +2804,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -typeDeterminesValue :: Type -> Bool --- See Note [Type determines value] -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) - interestingDict :: CoreExpr -> Type -> Bool -- A dictionary argument is interesting if it has *some* structure, -- see Note [Interesting dictionary arguments] diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs index 9dd1a7b815..b3fde40055 100644 --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -19,7 +19,7 @@ module GHC.Core.Predicate ( mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- Class predicates - mkClassPred, isDictTy, + mkClassPred, isDictTy, typeDeterminesValue, isClassPred, isEqPredClass, isCTupleClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy, @@ -102,6 +102,10 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys isDictTy :: Type -> Bool isDictTy = isClassPred +typeDeterminesValue :: Type -> Bool +-- See Note [Type determines value] +typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) + getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys) @@ -132,6 +136,19 @@ classMethodInstTy sel_id arg_tys = funResultTy $ piResultTys (varType sel_id) arg_tys +{- Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-impicit-parameter predicates, because these +are the ones whose *type* determines their *value*. In particular, +with implicit params, the type args *don't* say what the value of the +implicit param is! See #7101. + +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. +-} + -- --------------------- Equality predicates --------------------------------- -- | A choice of equality relation. This is separate from the type 'Role' diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index eba63f590a..e2d6487267 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -8,7 +8,10 @@ -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( - -- ** Constructing + -- ** Looking up rules + lookupRule, + + -- ** RuleBase, RuleEnv emptyRuleBase, mkRuleBase, extendRuleBaseList, pprRuleBase, extendRuleEnv, @@ -22,7 +25,9 @@ module GHC.Core.Rules ( -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames + -- * Making rules + mkRule, mkSpecRule, roughTopNames + ) where import GHC.Prelude @@ -30,6 +35,9 @@ import GHC.Prelude import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env +import GHC.Driver.Session( DynFlags ) +import GHC.Driver.Ppr( showSDoc ) + import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) @@ -43,9 +51,11 @@ import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type ( Type, TCvSubst, extendTvSubst, extendCvSubst , mkEmptyTCvSubst, substTy, getTyVar_maybe ) +import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) +import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -58,6 +68,7 @@ import GHC.Types.Var.Set import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.Name.Occurrence( occNameFS ) import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -152,33 +163,18 @@ Note [Overall plumbing for rules] * * ************************************************************************ -A @CoreRule@ holds details of one rule for an @Id@, which +A CoreRule holds details of one rule for an Id, which includes its specialisations. -For example, if a rule for @f@ contains the mapping: -\begin{verbatim} - forall a b d. [Type (List a), Type b, Var d] ===> f' a b -\end{verbatim} +For example, if a rule for f is + RULE "f" forall @a @b d. f @(List a) @b d = f' a b + then when we find an application of f to matching types, we simply replace it by the matching RHS: -\begin{verbatim} f (List Int) Bool dict ===> f' Int Bool -\end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the Rule contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a - -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) - -where pi' :: Lift Int# is the specialised version of pi. -} mkRule :: Module -> Bool -> Bool -> RuleName -> Activation @@ -207,6 +203,40 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs orph = chooseOrphanAnchor local_lhs_names -------------- +mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc + -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- Make a specialisation rule, for Specialise or SpecConstr +mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs + = case isJoinId_maybe fn of + Just join_arity -> etaExpandToJoinPointRule join_arity rule + Nothing -> rule + where + rule = mkRule this_mod is_auto is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + bndrs args rhs + + is_local = isLocalId fn + rule_name = mkSpecRuleName dflags herald fn args + +mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString +mkSpecRuleName dflags herald fn args + = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + -- This name ends up in interface files, so use occNameFS. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + <+> hsep (mapMaybe ppr_call_key_ty args) + where + ppr_call_key_ty :: CoreExpr -> Maybe SDoc + ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of + Just {} -> Just (text "@_") + Nothing -> Just $ char '@' <> pprParendType ty + ppr_call_key_ty _ = Nothing + + +-------------- roughTopNames :: [CoreExpr] -> [Maybe Name] -- ^ Find the \"top\" free names of several expressions. -- Such names are either: @@ -446,16 +476,9 @@ findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) (fn,args) = target isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool --- This tests if one rule is more specific than another --- We take the view that a BuiltinRule is less specific than --- anything else, because we want user-define rules to "win" --- In particular, class ops have a built-in rule, but we --- any user-specific rules to win --- eg (#4397) --- truncate :: (RealFrac a, Integral b) => a -> b --- {-# RULES "truncate/Double->Int" truncate = double2Int #-} --- double2Int :: Double -> Int --- We want the specific RULE to beat the built-in class-op rule +-- The call (rule1 `isMoreSpecific` rule2) +-- sees if rule2 can be instantiated to look like rule1 +-- See Note [isMoreSpecific] isMoreSpecific _ (BuiltinRule {}) _ = False isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) @@ -470,7 +493,24 @@ isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{- Note [Extra args in the target] +{- Note [isMoreSpecific] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call (rule1 `isMoreSpecific` rule2) +sees if rule2 can be instantiated to look like rule1. + +Wrinkle: + +* We take the view that a BuiltinRule is less specific than + anything else, because we want user-defined rules to "win" + In particular, class ops have a built-in rule, but we + prefer any user-specific rules to win: + eg (#4397) + truncate :: (RealFrac a, Integral b) => a -> b + {-# RULES "truncate/Double->Int" truncate = double2Int #-} + double2Int :: Double -> Int + We want the specific RULE to beat the built-in class-op rule + +Note [Extra args in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)), /but/ the rule firing has only consumed as many of the input args @@ -610,6 +650,27 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] +---------------------- +match_exprs :: RuleMatchEnv -> RuleSubst + -> [CoreExpr] -- Templates + -> [CoreExpr] -- Targets + -> Maybe RuleSubst +-- If the targets are longer than templates, succeed, simply ignoring +-- the leftover targets. This matters in the call in matchN. +-- +-- Precondition: corresponding elements of es1 and es2 have the same +-- type, assuming earlier elements match. +-- Example: f :: forall v. v -> blah +-- match_exprs [Type a, y::a] [Type Int, 3] +-- Then, after matching Type a against Type Int, +-- the type of (y::a) matches that of (3::Int) +match_exprs _ subst [] _ + = Just subst +match_exprs renv subst (e1:es1) (e2:es2) + = do { subst' <- match renv subst e1 e2 MRefl + ; match_exprs renv subst' es1 es2 } +match_exprs _ _ _ _ = Nothing + {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -743,27 +804,6 @@ emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = [] } ----------------------- -match_exprs :: RuleMatchEnv -> RuleSubst - -> [CoreExpr] -- Templates - -> [CoreExpr] -- Targets - -> Maybe RuleSubst --- If the targets are longer than templates, succeed, simply ignoring --- the leftover targets. This matters in the call in matchN. --- --- Precondition: corresponding elements of es1 and es2 have the same --- type, assumuing earlier elements match --- Example: f :: forall v. v -> blah --- match_exprs [Type a, y::a] [Type Int, 3] --- Then, after matching Type a against Type Int, --- the type of (y::a) matches that of (3::Int) -match_exprs _ subst [] _ - = Just subst -match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl - ; match_exprs renv subst' es1 es2 } -match_exprs _ _ _ _ = Nothing - {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |