summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sgraf1337@gmail.com>2019-06-16 11:52:43 +0200
committerSebastian Graf <sgraf1337@gmail.com>2019-06-16 11:52:50 +0200
commit99478003846d35dd8c4401be90ce91f8a825fd59 (patch)
tree483bd1d6ee6a9466aa1261a6e53e048a37e66288
parent2f0bbff230da8a37a7e31335750a227a1c9ca7f0 (diff)
downloadhaskell-wip/move-warnDs.tar.gz
Move 'Useless SPECIALISE pragma' warnings to TcWarningswip/move-warnDs
-rw-r--r--compiler/deSugar/DsBinds.hs17
-rw-r--r--compiler/typecheck/TcHsSyn.hs4
-rw-r--r--compiler/typecheck/TcWarnings.hs29
3 files changed, 32 insertions, 18 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index a87a4bbcbb..b7a77a8bf0 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -653,22 +653,6 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
- | isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
- do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
- <+> quotes (ppr poly_id))
- ; return Nothing } -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
-
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
- do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
- <+> quotes (ppr poly_id))
- ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
-
- | otherwise
= putSrcSpanDs loc $
do { uniq <- newUnique
; let poly_name = idName poly_id
@@ -746,6 +730,7 @@ dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
-- See Note [Activation pragmas for SPECIALISE]
-- no_act_spec is True if the user didn't write an explicit
-- phase specification in the SPECIALISE pragma
+ -- Keep this in sync with 'TcWarnings.warnUnusedSpecialisePragma'
no_act_spec = case inlinePragmaSpec spec_inl of
NoInline -> isNeverActive spec_prag_act
_ -> isAlwaysActive spec_prag_act
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index ded91a6b78..efda5a7f69 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -682,7 +682,9 @@ zonkLTcSpecPrags env ps
where
zonk_prag (dL->L loc (SpecPrag id co_fn inl))
= do { (_, co_fn') <- zonkCoFn env co_fn
- ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+ ; let prag = cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)
+ ; warnUselessSpecialisePragma prag
+ ; return prag }
{-
************************************************************************
diff --git a/compiler/typecheck/TcWarnings.hs b/compiler/typecheck/TcWarnings.hs
index f0d1a21acc..2c89ead806 100644
--- a/compiler/typecheck/TcWarnings.hs
+++ b/compiler/typecheck/TcWarnings.hs
@@ -9,7 +9,10 @@ module TcWarnings (
warnAboutEmptyEnumerations,
-- * Discarded do bindings
- warnDiscardedDoBindings
+ warnDiscardedDoBindings,
+
+ -- * Useless pragmas
+ warnUselessSpecialisePragma
) where
import GhcPrelude
@@ -274,3 +277,27 @@ badMonadBind rhs elt_ty
, hang (text "Suppress this warning by saying")
2 (quotes $ text "_ <-" <+> ppr rhs)
]
+
+warnUselessSpecialisePragma :: LTcSpecPrag -> TcM ()
+warnUselessSpecialisePragma (dL->L loc (SpecPrag id _ spec_inl))
+ | Just _ <- isClassOpId_maybe id
+ = setSrcSpan loc (warn_useless "class method selector")
+ | no_act_spec && isNeverActive id_rule_act
+ -- Function is NOINLINE, and the specialisation inherits that
+ -- See Note [Activation pragmas for SPECIALISE] in DsBinds
+ = setSrcSpan loc (warn_useless "NOINLINE function")
+ | otherwise
+ = return ()
+ where
+ warn_useless what = warnTc NoReason True $ hsep
+ [ text "Ignoring useless SPECIALISE pragma for"
+ , ppr what
+ , quotes (ppr id)
+ ]
+ -- See Note [Activation pragmas for SPECIALISE] in DsBinds
+ -- no_act_spec is True if the user didn't write an explicit
+ -- phase specification in the SPECIALISE pragma
+ no_act_spec = case inlinePragmaSpec spec_inl of
+ NoInline -> isNeverActive (inlinePragmaActivation spec_inl)
+ _ -> isAlwaysActive (inlinePragmaActivation spec_inl)
+ id_rule_act = inlinePragmaActivation (idInlinePragma id)