Commit 931d0a7d authored by Edward Z. Yang's avatar Edward Z. Yang

Move orphan instance/rule warnings to typechecker/desugarer.

Summary:
Instead of doing these warnings at MkIface time, we do them
when we create the instances/rules in the typechecker/desugarer.

Emitting warnings for auto-generated instances was a pain
(since the specialization monad doesn't have the capacity
to emit warnings) so instead I just deprecated -fwarn-auto-orphans.
Auto rule orphans are pretty harmless anyway: they don't cause
interface files to be eagerly loaded in.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1297
parent f64f7c36
......@@ -381,12 +381,12 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule_name = snd (unLoc name)
rule = mkRule this_mod False {- Not auto -} is_local
rule_name rule_act fn_name final_bndrs args
final_rhs
arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
; dflags <- getDynFlags
; rule <- dsMkUserRule this_mod is_local
rule_name rule_act fn_name final_bndrs args
final_rhs
; when (wopt Opt_WarnInlineRuleShadowing dflags) $
warnRuleShadowing rule_name rule_act fn_id arg_ids
......
......@@ -13,7 +13,7 @@ lower levels it is preserved with @let@/@letrec@s).
{-# LANGUAGE CPP #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
) where
#include "HsVersions.h"
......@@ -69,7 +69,7 @@ import DynFlags
import FastString
import Util
import MonadUtils
import Control.Monad(liftM)
import Control.Monad(liftM,when)
import Fingerprint(Fingerprint(..), fingerprintString)
{-
......@@ -450,7 +450,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule this_mod False {- Not auto -} is_local_id
; rule <- dsMkUserRule this_mod is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
......@@ -503,6 +503,17 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise = spec_prag_act -- Specified by user
dsMkUserRule :: Module -> Bool -> 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
dflags <- getDynFlags
when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
warnDs (ruleOrphWarn rule)
return rule
ruleOrphWarn :: CoreRule -> SDoc
ruleOrphWarn rule = ptext (sLit "Orphan rule:") <+> ppr rule
{- Note [SPECIALISE on INLINE functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -110,7 +110,6 @@ import Maybes
import ListSetOps
import Binary
import Fingerprint
import Bag
import Exception
import Control.Monad
......@@ -135,11 +134,10 @@ mkIface :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface
-> ModGuts -- Usages, deprecations, etc
-> IO (Messages,
Maybe (ModIface, -- The new one
Bool)) -- True <=> there was an old Iface, and the
-- new one is identical, so no need
-- to write it
-> IO (ModIface, -- The new one
Bool) -- True <=> there was an old Iface, and the
-- new one is identical, so no need
-- to write it
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
......@@ -198,7 +196,7 @@ mkIfaceTc :: HscEnv
-> SafeHaskellMode -- The safe haskell mode
-> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc
-> IO (Messages, Maybe (ModIface, Bool))
-> IO (ModIface, Bool)
mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
......@@ -268,7 +266,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
-> [FilePath]
-> SafeHaskellMode
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
-> IO (ModIface, Bool)
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
......@@ -354,38 +352,17 @@ mkIface_ hsc_env maybe_old_fingerprint
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
-- Warn about orphans
-- See Note [Orphans and auto-generated rules]
let warn_orphs = wopt Opt_WarnOrphans dflags
warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
orph_warnings --- Laziness means no work done unless -fwarn-orphans
| warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn dflags unqual d
| (d,i) <- insts `zip` iface_insts
, isOrphan (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
| r <- iface_rules
, isOrphan (ifRuleOrph r)
, if ifRuleAuto r then warn_auto_orphs
else warn_orphs ]
if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
else do
-- Debug printing
dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
-- Debug printing
dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
-- bug #1617: on reload we weren't updating the PrintUnqualified
-- correctly. This stems from the fact that the interface had
-- not changed, so addFingerprints returns the old ModIface
-- with the old GlobalRdrEnv (mi_globals).
let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
-- bug #1617: on reload we weren't updating the PrintUnqualified
-- correctly. This stems from the fact that the interface had
-- not changed, so addFingerprints returns the old ModIface
-- with the old GlobalRdrEnv (mi_globals).
let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
return (errs_and_warns, Just (final_iface, no_change_at_all))
return (final_iface, no_change_at_all)
where
dflags = hsc_dflags hsc_env
......@@ -725,25 +702,6 @@ mkIfaceAnnCache anns
env = mkOccEnv_C (flip (++)) (map pair anns)
{-
Note [Orphans and auto-generated rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we specialise an INLINEABLE function, or when we have
-fspecialise-aggressively, we auto-generate RULES that are orphans.
We don't want to warn about these, at least not by default, or we'd
generate a lot of warnings. Hence -fwarn-auto-orphans.
Indeed, we don't even treat the module as an oprhan module if it has
auto-generated *rule* orphans. Orphan modules are read every time we
compile, so they are pretty obtrusive and slow down every compilation,
even non-optimised ones. (Reason: for type class instances it's a
type correctness issue.) But specialisation rules are strictly for
*optimisation* only so it's fine not to read the interface.
What this means is that a SPEC rules from auto-specialisation in
module M will be used in other modules only if M.hi has been read for
some other reason, which is actually pretty likely.
************************************************************************
* *
The ABI of an IfaceDecl
......@@ -945,27 +903,6 @@ oldMD5 dflags bh = do
return $! readHexFingerprint hash_str
-}
instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn dflags unqual inst
= mkWarnMsg dflags (getSrcSpan inst) unqual $
hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
$$ text "To avoid this"
$$ nest 4 (vcat possibilities)
where
possibilities =
text "move the instance declaration to the module of the class or of the type, or" :
text "wrap the type with a newtype and declare the instance on the new type." :
[]
ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn dflags unqual mod rule
= mkWarnMsg dflags silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
-- We don't have a decent SrcSpan for a Rule, not even the CoreRule
-- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
----------------------
-- mkOrphMap partitions instance decls or rules into
-- (a) an OccEnv for ones that are not orphans,
......
......@@ -2876,7 +2876,8 @@ fWarningFlags = [
Opt_WarnAlternativeLayoutRuleTransitional,
flagSpec' "warn-amp" Opt_WarnAMP
(\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"),
flagSpec "warn-auto-orphans" Opt_WarnAutoOrphans,
flagSpec' "warn-auto-orphans" Opt_WarnAutoOrphans
(\_ -> deprecate "it has no effect"),
flagSpec "warn-deferred-type-errors" Opt_WarnDeferredTypeErrors,
flagSpec "warn-deprecations" Opt_WarnWarningsDeprecations,
flagSpec "warn-deprecated-flags" Opt_WarnDeprecatedFlags,
......
......@@ -460,7 +460,7 @@ makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
-> IO (ModIface,Bool)
makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
safe_mode <- hscGetSafeMode tc_result
ioMsgMaybe $ do
liftIO $ do
mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
details tc_result
......@@ -1216,7 +1216,7 @@ hscSimpleIface' tc_result mb_old_iface = do
safe_mode <- hscGetSafeMode tc_result
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
ioMsgMaybe $
liftIO $
mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
-- And the answer is ...
liftIO $ dumpIfaceStats hsc_env
......@@ -1244,7 +1244,7 @@ hscNormalIface' simpl_result mb_old_iface = do
-- until after code output
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
ioMsgMaybe $
liftIO $
mkIface hsc_env mb_old_iface details simpl_result
liftIO $ dumpIfaceStats hsc_env
......
......@@ -1324,6 +1324,26 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } }
{-
Note [Orphans and auto-generated rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we specialise an INLINEABLE function, or when we have
-fspecialise-aggressively, we auto-generate RULES that are orphans.
We don't want to warn about these, or we'd generate a lot of warnings.
Thus, we only warn about user-specified orphan rules.
Indeed, we don't even treat the module as an orphan module if it has
auto-generated *rule* orphans. Orphan modules are read every time we
compile, so they are pretty obtrusive and slow down every compilation,
even non-optimised ones. (Reason: for type class instances it's a
type correctness issue.) But specialisation rules are strictly for
*optimisation* only so it's fine not to read the interface.
What this means is that a SPEC rules from auto-specialisation in
module M will be used in other modules only if M.hi has been read for
some other reason, which is actually pretty likely.
-}
bindAuxiliaryDicts
:: SpecEnv
-> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions
......
......@@ -441,7 +441,21 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
-- Not sure if this is really the right place to do so,
-- but it'll do fine
; oflag <- getOverlapFlag overlap_mode
; return (mkLocalInstance dfun oflag tvs' clas tys') }
; let inst = mkLocalInstance dfun oflag tvs' clas tys'
; dflags <- getDynFlags
; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
; return inst }
instOrphWarn :: ClsInst -> SDoc
instOrphWarn inst
= hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
$$ text "To avoid this"
$$ nest 4 (vcat possibilities)
where
possibilities =
text "move the instance declaration to the module of the class or of the type, or" :
text "wrap the type with a newtype and declare the instance on the new type." :
[]
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances
......
......@@ -14,7 +14,6 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
MetaTyCons, genGenericMetaTyCons,
gen_Generic_binds, get_gen1_constrained_tys) where
import DynFlags
import HsSyn
import Type
import Kind ( isKind )
......@@ -33,15 +32,14 @@ import BasicTypes
import TysPrim
import TysWiredIn
import PrelNames
import InstEnv
import TcEnv
import MkId
import TcRnMonad
import HscTypes
import ErrUtils( Validity(..), andValid )
import BuildTyCl
import SrcLoc
import Bag
import Inst
import VarSet (elemVarSet)
import Outputable
import FastString
......@@ -113,8 +111,7 @@ genGenericMetaTyCons tc =
-- both the tycon declarations and related instances
metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
metaTyConsToDerivStuff tc metaDts =
do dflags <- getDynFlags
dClas <- tcLookupClass datatypeClassName
do dClas <- tcLookupClass datatypeClassName
d_dfun_name <- newDFunName' dClas tc
cClas <- tcLookupClass constructorClassName
c_dfun_names <- sequence [ (conTy,) <$> newDFunName' cClas tc
......@@ -129,16 +126,18 @@ metaTyConsToDerivStuff tc metaDts =
let
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
mk_inst clas tc dfun_name
= mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
OverlapFlag { overlapMode = (NoOverlap "")
, isSafeOverlap = safeLanguageOn dflags }
[] clas tys
= newClsInst (Just (NoOverlap "")) dfun_name [] [] clas tys
where
tys = [mkTyConTy tc]
let d_metaTycon = metaD metaDts
d_inst <- mk_inst dClas d_metaTycon d_dfun_name
c_insts <- sequence [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
s_insts <- mapM (mapM (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
let
-- Datatype
d_metaTycon = metaD metaDts
d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = InstBindings { ib_binds = dBinds
, ib_tyvars = []
, ib_pragmas = []
......@@ -147,7 +146,6 @@ metaTyConsToDerivStuff tc metaDts =
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
c_insts = [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
c_binds = [ InstBindings { ib_binds = c
, ib_tyvars = []
, ib_pragmas = []
......@@ -158,7 +156,6 @@ metaTyConsToDerivStuff tc metaDts =
| (is,bs) <- myZip1 c_insts c_binds ]
-- Selector
s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
s_binds = [ [ InstBindings { ib_binds = s
, ib_tyvars = []
, ib_pragmas = []
......
......@@ -203,7 +203,9 @@ instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
mkLocalInstance :: DFunId -> OverlapFlag
-> [TyVar] -> Class -> [Type]
-> ClsInst
-- Used for local instances, where we can safely pull on the DFunId
-- Used for local instances, where we can safely pull on the DFunId.
-- Consider using newClsInst instead; this will also warn if
-- the instance is an orphan.
mkLocalInstance dfun oflag tvs cls tys
= ClsInst { is_flag = oflag, is_dfun = dfun
, is_tvs = tvs
......
......@@ -40,7 +40,7 @@ standard “packages” of warnings:
code. The warnings that are *not* enabled by ``-Wall`` are
``-fwarn-incomplete-uni-patterns``,
``-fwarn-incomplete-record-updates``,
``-fwarn-monomorphism-restriction``, ``-fwarn-auto-orphans``,
``-fwarn-monomorphism-restriction``,
``-fwarn-implicit-prelude``, ``-fwarn-missing-local-sigs``,
``-fwarn-missing-exported-sigs``, ``-fwarn-missing-import-lists``
and ``-fwarn-identities``.
......@@ -563,10 +563,9 @@ command line.
f x = do { _ignore <- this; _ignore <- that; return (the other) }
``-fwarn-orphans, -fwarn-auto-orphans``
``-fwarn-orphans``
.. index::
single: -fwarn-orphans
single: -fwarn-auto-orphans
single: orphan instances, warning
single: orphan rules, warning
......@@ -584,10 +583,7 @@ command line.
otherwise be of any use. See :ref:`orphan-modules` for details.
The flag ``-fwarn-orphans`` warns about user-written orphan rules or
instances. The flag ``-fwarn-auto-orphans`` warns about
automatically-generated orphan rules, notably as a result of
specialising functions, for type classes (``Specialise``) or
argument values (``-fspec-constr``).
instances.
``-fwarn-overlapping-patterns``
.. index::
......
T4912.hs:10:10: warning:
Orphan instance: instance [safe] Foo TheirData
T4912.hs:10:1: warning:
Orphan instance: instance Foo TheirData
To avoid this
move the instance declaration to the module of the class or of the type, or
wrap the type with a newtype and declare the instance on the new type.
T4912.hs:13:10: warning:
Orphan instance: instance [safe] Bar OurData
T4912.hs:13:1: warning:
Orphan instance: instance Bar OurData
To avoid this
move the instance declaration to the module of the class or of the type, or
wrap the type with a newtype and declare the instance on the new type.
[1 of 2] Compiling T9178DataType ( T9178DataType.hs, T9178DataType.o )
[2 of 2] Compiling T9178 ( T9178.hs, T9178.o )
T9178.hs:8:10: warning:
Orphan instance: instance [safe] Show T9178_Type
T9178.hs:8:1: warning:
Orphan instance: instance Show T9178_Type
To avoid this
move the instance declaration to the module of the class or of the type, or
wrap the type with a newtype and declare the instance on the new type.
......@@ -155,12 +155,12 @@ warningsOptions =
, flagType = DynamicFlag
, flagReverse = "-fno-warn-name-shadowing"
}
, flag { flagName = "-fwarn-orphans, -fwarn-auto-orphans"
, flag { flagName = "-fwarn-orphans"
, flagDescription =
"warn when the module contains :ref:`orphan instance declarations "++
"or rewrite rules <orphan-modules>`"
, flagType = DynamicFlag
, flagReverse = "-fno-warn-orphans, -fno-warn-auto-orphans"
, flagReverse = "-fno-warn-orphans"
}
, flag { flagName = "-fwarn-overlapping-patterns"
, flagDescription = "warn about overlapping patterns"
......
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