Commit 2952a133 authored by Alexis Williams's avatar Alexis Williams

Fix certain SPEC rules being marked as non-autogen

parent 972b564e
......@@ -404,7 +404,7 @@ dsRule (L loc (HsRule { rd_name = name
arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
exprsSomeFreeVarsList isId args
; rule <- dsMkUserRule this_mod is_local
; rule <- dsMkUserRule this_mod is_local UserWritten
rule_name rule_act fn_name final_bndrs args
final_rhs
; when (wopt Opt_WarnInlineRuleShadowing dflags) $
......
......@@ -705,7 +705,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
`setIdUnfolding` spec_unf
arity_decrease = count isValArg args - count isId spec_bndrs
; rule <- dsMkUserRule this_mod is_local_id
; rule <- dsMkUserRule this_mod is_local_id GHCGenerated
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
......@@ -757,11 +757,10 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
| otherwise = spec_prag_act -- Specified by user
dsMkUserRule :: Module -> Bool -> RuleName -> Activation
dsMkUserRule :: Module -> Bool -> RuleOrigin -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
let rule = mkRule this_mod False is_local name act fn bndrs args rhs
dsMkUserRule this_mod is_local origin name act fn bndrs args rhs = do
let rule = mkRule this_mod origin is_local name act fn bndrs args rhs
dflags <- getDynFlags
when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
......
......@@ -23,7 +23,7 @@ module Rules (
-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
lookupRule, mkRule, roughTopNames
lookupRule, mkRule, RuleOrigin(..), roughTopNames
) where
#include "HsVersions.h"
......@@ -170,11 +170,14 @@ might have a specialisation
where pi' :: Lift Int# is the specialised version of pi.
-}
mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
data RuleOrigin = UserWritten | GHCGenerated
deriving (Show, Eq)
mkRule :: Module -> RuleOrigin -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'CoreSyn.CoreRule'
mkRule this_mod is_auto is_local name act fn bndrs args rhs
mkRule this_mod origin is_local name act fn bndrs args rhs
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = rhs,
......@@ -183,6 +186,8 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs
ru_orphan = orph,
ru_auto = is_auto, ru_local = is_local }
where
is_auto = origin == GHCGenerated
-- Compute orphanhood. See Note [Orphans] in InstEnv
-- A rule is an orphan only if none of the variables
-- mentioned on its left-hand side are locally defined
......@@ -511,10 +516,12 @@ matchRule dflags rule_env _is_active fn args _rough_args
matchRule dflags in_scope is_active fn args rough_args
(Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops
, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })
, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs
, ru_auto = rule_auto })
| not (is_active act) = Left Nothing
| ruleCantMatch tpl_tops rough_args = Left Nothing
| not (null nonAffineArgs) = Left (Just affineWarning)
| not rule_auto
, not (null nonAffineArgs) = Left (Just affineWarning)
| otherwise = case matchN in_scope rule_name tpl_vars tpl_args args rhs of
Just match -> Right match
Nothing -> Left Nothing
......
......@@ -1735,7 +1735,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
this_mod = sc_module spec_env
rule = mkRule this_mod True {- Auto -} True {- Local -}
rule = mkRule this_mod GHCGenerated True {- Local -}
rule_name inline_act fn_name qvars pats rule_rhs
-- See Note [Transfer activation]
; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
......
......@@ -1469,7 +1469,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
rule_wout_eta = mkRule
this_mod
True {- Auto generated -}
GHCGenerated
is_local
rule_name
inl_act -- Note [Auto-specialisation and RULES]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment