diff options
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 17 | ||||
| -rw-r--r-- | compiler/iface/MkIface.hs | 93 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 3 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 6 | ||||
| -rw-r--r-- | compiler/specialise/Specialise.hs | 20 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.hs | 16 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.hs | 23 | ||||
| -rw-r--r-- | compiler/types/InstEnv.hs | 4 | ||||
| -rw-r--r-- | docs/users_guide/using-warnings.rst | 10 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T4912.stderr | 8 | ||||
| -rw-r--r-- | testsuite/tests/warnings/should_compile/T9178.stderr | 4 | ||||
| -rw-r--r-- | utils/mkUserGuidePart/Options/Warnings.hs | 4 |
13 files changed, 96 insertions, 118 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 1508922423..dceebc1fcd 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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 diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 28e866d8e9..b8df7b801c 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 99544c4e4f..43e57cdf43 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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, diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0978c1132c..4d5d727d6b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f783a9a9bc..1a35af1738 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index e3501dfd38..8e76492cc5 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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 diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index f4caf2b74a..53fd19f774 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -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 diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 9a2b988b9f..3514393baa 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -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 = [] diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index b8a3e6aa3f..56df3a52ba 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -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 diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 0b3faa4105..c3271d0111 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -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:: diff --git a/testsuite/tests/typecheck/should_compile/T4912.stderr b/testsuite/tests/typecheck/should_compile/T4912.stderr index 855d365db5..02ff1ad40e 100644 --- a/testsuite/tests/typecheck/should_compile/T4912.stderr +++ b/testsuite/tests/typecheck/should_compile/T4912.stderr @@ -1,12 +1,12 @@ -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. diff --git a/testsuite/tests/warnings/should_compile/T9178.stderr b/testsuite/tests/warnings/should_compile/T9178.stderr index c1e99bc516..d22f428763 100644 --- a/testsuite/tests/warnings/should_compile/T9178.stderr +++ b/testsuite/tests/warnings/should_compile/T9178.stderr @@ -1,8 +1,8 @@ [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. diff --git a/utils/mkUserGuidePart/Options/Warnings.hs b/utils/mkUserGuidePart/Options/Warnings.hs index a79c3a8920..688a7e691b 100644 --- a/utils/mkUserGuidePart/Options/Warnings.hs +++ b/utils/mkUserGuidePart/Options/Warnings.hs @@ -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" |