From 84ed91abfe3f9df43d5b33e404138e43a574beb8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 21 Feb 2003 13:28:01 +0000 Subject: [PATCH] [project @ 2003-02-21 13:27:53 by simonpj] ------------------------------------- Improve the "unused binding" warnings ------------------------------------- We've had a succession of hacks for reporting warnings for unused bindings. Consider module M( f ) where f x = x g x = g x + h x h x = x Here, g mentions itself and h, but is not itself mentioned. So really both g and h are dead code. We've been getting this wrong for ages, and every hack so far has failed on some simple programs. This commit does a much better job. The renamer applied to a bunch of bindings returns a NameSet.DefUses, which is a dependency-ordered lists of def/use pairs. It's documented in NameSet. Given this, we can work out precisely what is not used, in a nice tidy way. It's less convenient in the case of type and class declarations, because the strongly-connected-component analysis can span module boundaries. So things are pretty much as they were for these. As usual, there was a lot of chuffing around tidying things up. I havn't tested it at all thoroughly yet. Various unrelated import-decl-pruning has been done too. --- ghc/compiler/basicTypes/NameSet.lhs | 80 ++++++++++++++++- ghc/compiler/hsSyn/HsBinds.lhs | 7 +- ghc/compiler/prelude/TysWiredIn.lhs | 2 +- ghc/compiler/rename/RnBinds.lhs | 146 ++++++++++++++------------------ ghc/compiler/rename/RnEnv.lhs | 28 +++--- ghc/compiler/rename/RnExpr.lhs | 22 ++--- ghc/compiler/rename/RnHiFiles.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 1 - ghc/compiler/rename/RnNames.lhs | 61 +++++++------ ghc/compiler/rename/RnSource.hi-boot-5 | 4 +- ghc/compiler/rename/RnSource.hi-boot-6 | 4 +- ghc/compiler/rename/RnSource.lhs | 66 ++++++++------- ghc/compiler/rename/RnTypes.lhs | 6 +- ghc/compiler/typecheck/Inst.lhs | 5 +- ghc/compiler/typecheck/TcClassDcl.lhs | 7 +- ghc/compiler/typecheck/TcDeriv.lhs | 10 +-- ghc/compiler/typecheck/TcEnv.lhs | 5 +- ghc/compiler/typecheck/TcExpr.lhs | 7 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 4 +- ghc/compiler/typecheck/TcInstDcls.lhs | 1 - ghc/compiler/typecheck/TcMonoType.lhs | 8 +- ghc/compiler/typecheck/TcRnDriver.lhs | 53 ++++++------ ghc/compiler/typecheck/TcRnTypes.lhs | 13 ++- ghc/compiler/typecheck/TcTyDecls.lhs | 3 +- ghc/compiler/typecheck/TcUnify.lhs | 10 +-- 25 files changed, 310 insertions(+), 247 deletions(-) diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index 8aaaf4e..e75d3cd 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -14,7 +14,12 @@ module NameSet ( -- Free variables FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs + mkFVs, addOneFV, unitFV, delFV, delFVs, + + -- Defs and uses + Defs, Uses, DefUse, DefUses, + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses ) where #include "HsVersions.h" @@ -104,3 +109,76 @@ delFV n s = delFromNameSet s n delFVs ns s = delListFromNameSet s ns \end{code} + +%************************************************************************ +%* * + Defs and uses +%* * +%************************************************************************ + +\begin{code} +type Defs = NameSet +type Uses = NameSet + +type DefUse = (Maybe Defs, Uses) +type DefUses = [DefUse] + -- In dependency order: earlier Defs scope over later Uses + -- For items (Just ds, us), the use of any member + -- of the ds implies that all the us are used too + -- + -- Also, us may mention ds + -- + -- Nothing => Nothing defined in this group, but + -- nevertheless all the uses are essential. + -- Used for instance declarations, for example + +emptyDUs :: DefUses +emptyDUs = [] + +usesOnly :: Uses -> DefUses +usesOnly uses = [(Nothing, uses)] + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = (++) + +allUses :: DefUses -> Uses -> Uses +-- Collect all uses, removing defs +allUses dus uses + = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- Given some DefUses and some Uses, +-- find all the uses, transitively. +-- The result is a superset of the input uses; +-- and includes things defined in the input DefUses +-- (if they are used, of course) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSets` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses + = rhs_uses `unionNameSets` uses + | otherwise -- No def is used + = uses + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, u1) d2 = d2 + get (Just d1, u1) d2 = d1 `unionNameSets` d2 + +duUses :: DefUses -> Uses +-- Defs are not eliminated +duUses dus = foldr get emptyNameSet dus + where + get (d1, u1) u2 = u1 `unionNameSets` u2 +\end{code} \ No newline at end of file diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a3d127d..7437f09 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -277,9 +277,10 @@ okBindSig :: NameSet -> Sig Name -> Bool okBindSig ns (ClassOpSig _ _ _ _) = False okBindSig ns sig = sigForThisGroup ns sig -okClsDclSig :: NameSet -> Sig Name -> Bool -okClsDclSig ns (Sig _ _ _) = False -okClsDclSig ns sig = sigForThisGroup ns sig +okClsDclSig :: Sig Name -> Bool +okClsDclSig (Sig _ _ _) = False +okClsDclSig (SpecInstSig _ _) = False +okClsDclSig sig = True -- All others OK okInstDclSig :: NameSet -> Sig Name -> Bool okInstDclSig ns (Sig _ _ _) = False diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 8855085..268e44e 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -97,7 +97,7 @@ import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 8710416..cd3d575 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -25,7 +25,8 @@ import TcRnMonad import RnTypes ( rnHsSigType, rnHsType, rnPat ) import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, - lookupSigOccRn, bindPatSigTyVars, bindLocalFixities, + lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, + bindLocalFixities, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) import CmdLineOpts ( DynFlag(..) ) @@ -33,7 +34,7 @@ import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) import List ( unzip4 ) import Outputable \end{code} @@ -150,35 +151,18 @@ contains bindings for the binders of this particular binding. \begin{code} rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> RnM (RenamedHsBinds, FreeVars) + -> RnM (RenamedHsBinds, DefUses) --- Assumes the binders of the binding are in scope already --- Very like rnMonoBinds, but checks for missing signatures too +-- The binders of the binding are in scope already; +-- the top level scope resoluttion does that rnTopMonoBinds mbinds sigs - = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ + = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> -- Hmm; by analogy with Ids, this doesn't look right + -- Top-level bound type vars should really scope over + -- everything, but we only scope them over the other bindings - renameSigs sigs `thenM` \ siglist -> - rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) -> - checkSigs okBindSig binders siglist `thenM_` - - -- Warn about missing signatures, but not in interface mode - -- (This is important when renaming bindings from 'deriving' clauses.) - getModeRn `thenM` \ mode -> - doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> - (if warn_missing_sigs && not (isInterfaceMode mode) then - let - type_sig_vars = [n | Sig n _ _ <- siglist] - un_sigd_binders = filter (not . (`elem` type_sig_vars)) - (nameSetToList binders) - in - mappM_ missingSigWarn un_sigd_binders - else - returnM () - ) `thenM_` - - returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist) + rnMonoBinds TopLevel mbinds sigs \end{code} @@ -198,27 +182,28 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, and extend the -- current scope, inventing new names for the new binders -- This also checks that the names form a set - bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders -> - bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ + bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ -> + bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds) $ -- Then install local fixity declarations -- Notice that they scope over thing_inside too bindLocalFixities [sig | FixSig sig <- sigs ] $ -- Do the business - rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) -> + rnMonoBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) -> -- Now do the "thing inside" thing_inside binds `thenM` \ (result,result_fvs) -> -- Final error checking let - all_fvs = result_fvs `plusFV` bind_fvs - unused_binders = filter (not . (`elemNameSet` all_fvs)) new_mbinders + bndrs = duDefs bind_dus + all_uses = findUses bind_dus result_fvs + unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses) in - warnUnusedLocalBinds unused_binders `thenM_` + warnUnusedLocalBinds unused_bndrs `thenM_` - returnM (result, delListFromNameSet all_fvs new_mbinders) + returnM (result, all_uses `minusNameSet` bndrs) where mbinders_w_srclocs = collectLocatedMonoBinders mbinds doc = text "In the binding group for:" @@ -226,64 +211,69 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds \end{code} -\begin{code} -rnMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> RnM (RenamedHsBinds, FreeVars) - --- Assumes the binders of the binding are in scope already - -rnMonoBinds mbinds sigs - = renameSigs sigs `thenM` \ siglist -> - rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) -> - checkSigs okBindSig binders siglist `thenM_` - returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist) -\end{code} - %************************************************************************ %* * \subsubsection{ MonoBinds -- the main work is done here} %* * %************************************************************************ -@rn_mono_binds@ is used by {\em both} top-level and nested bindings. +@rnMonoBinds@ is used by {\em both} top-level and nested bindings. It assumes that all variables bound in this group are already in scope. This is done {\em either} by pass 3 (for the top-level bindings), {\em or} by @rnMonoBinds@ (for the nested ones). \begin{code} -rn_mono_binds :: [RenamedSig] -- Signatures attached to this group - -> RdrNameMonoBinds - -> RnM (NameSet, -- Binders - RenamedHsBinds, -- Dependency analysed - FreeVars) -- Free variables - -rn_mono_binds siglist mbinds - = -- Rename the bindings, returning a MonoBindsInfo +rnMonoBinds :: TopLevelFlag + -> RdrNameMonoBinds + -> [RdrNameSig] + -> RnM (RenamedHsBinds, DefUses) + +-- Assumes the binders of the binding are in scope already + +rnMonoBinds top_lvl mbinds sigs + = renameSigs sigs `thenM` \ siglist -> + + -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> + flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> -- Do the SCC analysis let scc_result = rnSCC mbinds_info - (binds_s, rhs_fvs_s) = unzip (map reconstructCycle scc_result) + (binds_s, bind_dus_s) = unzip (map reconstructCycle scc_result) + bind_dus = mkDUs bind_dus_s final_binds = foldr ThenBinds EmptyBinds binds_s - - -- Deal with bound and free-var calculation - -- Caller removes binders from free-var set - rhs_fvs = plusFVs rhs_fvs_s - bndrs = plusFVs [defs | (defs,_,_,_) <- mbinds_info] + binders = duDefs bind_dus in - returnM (bndrs, final_binds, rhs_fvs) + + -- Check for duplicate or mis-placed signatures + checkSigs (okBindSig binders) siglist `thenM_` + + -- Warn about missing signatures, + -- but only at top level, and not in interface mode + -- (The latter is important when renaming bindings from 'deriving' clauses.) + getModeRn `thenM` \ mode -> + doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> + (if isTopLevel top_lvl && + warn_missing_sigs && + not (isInterfaceMode mode) + then let + type_sig_vars = [n | Sig n _ _ <- siglist] + un_sigd_binders = filter (not . (`elem` type_sig_vars)) + (nameSetToList binders) + in + mappM_ missingSigWarn un_sigd_binders + else + returnM () + ) `thenM_` + + returnM (final_binds, bind_dus `plusDU` usesOnly (hsSigsFVs siglist)) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks unique ``vertex tags'' on its output; minor plumbing required. -Sigh --- need to pass along the signatures for the group of bindings, -in case any of them \fbox{\ ???\ } - \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds @@ -406,9 +396,6 @@ a function binding, and has itself been dependency-analysed and renamed. \begin{code} - -type Defs = NameSet -type Uses = NameSet type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig]) -- Signatures, if any, for this vertex @@ -433,16 +420,12 @@ mkEdges nodes defs `intersectsNameSet` uses ] -reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, Uses) +reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses)) reconstructCycle (AcyclicSCC (defs, uses, binds, sigs)) - = (MonoBind binds sigs NonRecursive, uses) + = (MonoBind binds sigs NonRecursive, (defs, uses)) reconstructCycle (CyclicSCC cycle) = (MonoBind this_gp_binds this_gp_sigs Recursive, - unionManyNameSets uses_s `minusNameSet` unionManyNameSets defs_s) - -- The uses of the cycle are the things used in any RHS - -- minus the binders of the group. Knocking them out - -- right here improves the error reporting for usused - -- bindings; e.g. f x = f x -- Otherwise unused + (unionManyNameSets defs_s, unionManyNameSets uses_s)) where (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle this_gp_binds = foldr1 AndMonoBinds binds_s @@ -467,17 +450,16 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -checkSigs :: (NameSet -> RenamedSig -> Bool) -- OK-sig predicbate - -> NameSet -- Binders of this group +checkSigs :: (RenamedSig -> Bool) -- OK-sig predicbate -> [RenamedSig] -> RnM () -checkSigs ok_sig bndrs sigs +checkSigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - -- Well, I can't see the check for (b)... ToDo! + -- Well, I can't see the check for (a)... ToDo! = mappM_ unknownSigErr bad_sigs where - bad_sigs = filter (not . ok_sig bndrs) sigs + bad_sigs = filter (not . ok_sig) sigs -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index f6ee366..270f509 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -33,8 +33,7 @@ import Name ( Name, getName, nameIsLocalOrFrom, isWiredInName, mkInternalName, mkExternalName, mkIPName, nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) import NameSet -import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour, - reportIfUnused ) +import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) import Module ( Module, ModuleName, moduleName, mkHomeModule, lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) import PrelNames ( mkUnboundName, intTyConName, @@ -318,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name getGblEnv `thenM` \ gbl_env -> let avail_env = imp_env (tcg_imports gbl_env) + occ = rdrNameOcc rdr_name in - case lookupAvailEnv avail_env cls_name of + case lookupAvailEnv_maybe avail_env cls_name of Nothing -> -- If the class itself isn't in scope, then cls_name will -- be unboundName, and there'll already be an error for @@ -343,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name -- NB: qualified names are rejected by the parser lookupOrigName rdr_name - where - occ = rdrNameOcc rdr_name lookupSysBndr :: RdrName -> RnM Name -- Used for the 'system binders' in a data type or class declaration @@ -770,7 +768,7 @@ bindLocalsRn doc rdr_names enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc rdr_names enclosed_scope +bindLocalsFV doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> returnM (thing, delListFromNameSet fvs names) @@ -793,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replaceTyVarName tyvar_names names) -bindPatSigTyVars :: [RdrNameHsType] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) +bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope -bindPatSigTyVars tys enclosed_scope +bindPatSigTyVars tys thing_inside = getLocalRdrEnv `thenM` \ name_env -> getSrcLocM `thenM` \ loc -> let @@ -814,10 +810,15 @@ bindPatSigTyVars tys enclosed_scope located_tyvars = [(tv, loc) | tv <- forall_tyvars] doc_sig = text "In a pattern type-signature" in - bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> - enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs names) + bindLocatedLocalsRn doc_sig located_tyvars thing_inside +bindPatSigTyVarsFV :: [RdrNameHsType] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc @@ -896,7 +897,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs else Just parent, gre_prov = mk_provenance name, gre_deprec = lookupDeprec deprecs name} - \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 9b02b79..5e18d67 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -69,7 +69,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) = addSrcLoc (getMatchLoc match) $ -- Deal with the rhs type signature - bindPatSigTyVars rhs_sig_tys $ + bindPatSigTyVarsFV rhs_sig_tys $ doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> (case maybe_rhs_sig of Nothing -> returnM (Nothing, emptyFVs) @@ -84,7 +84,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) - -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs + -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where rhs_sig_tys = case maybe_rhs_sig of Nothing -> [] @@ -455,10 +455,10 @@ rnBracket (DecBr group) updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $ - rnSrcDecls group `thenM` \ (tcg_env, group', fvs) -> + rnSrcDecls group `thenM` \ (tcg_env, group', dus) -> -- Discard the tcg_env; it contains only extra info about fixity - returnM (DecBr group', fvs) + returnM (DecBr group', duUses dus `minusNameSet` duDefs dus) \end{code} %************************************************************************ @@ -515,7 +515,9 @@ rnNormalStmts ctxt (LetStmt binds : stmts) ok _ _ = True rnNormalStmts ctxt (ParStmt stmtss : stmts) - = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) -> + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + checkM opt_GlasgowExts parStmtErr `thenM_` + mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) -> let bndrss = map collectStmtsBinders stmtss' in @@ -549,8 +551,6 @@ rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts) %************************************************************************ \begin{code} -type Defs = NameSet -type Uses = NameSet -- Same as FreeVars really type FwdRefs = NameSet type Segment = (Defs, Uses, -- May include defs @@ -620,9 +620,9 @@ rn_mdo_stmt (BindStmt pat expr src_loc) [BindStmt pat' expr' src_loc]) rn_mdo_stmt (LetStmt binds) - = rnBinds binds `thenM` \ (binds', fv_binds) -> - returnM (mkNameSet (collectHsBinders binds'), - fv_binds, emptyNameSet, [LetStmt binds']) + = rnBinds binds `thenM` \ (binds', du_binds) -> + returnM (duDefs du_binds, duUses du_binds, + emptyNameSet, [LetStmt binds']) rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo = pprPanic "rn_mdo_stmt" (ppr stmt) @@ -923,6 +923,8 @@ checkTH e what -- Raise an error in a stage-1 compiler nest 2 (ppr e)]) #endif +parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts")) + badIpBinds binds = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4 (ppr binds) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index c6ddc2c..e5fbb17 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -15,7 +15,7 @@ module RnHiFiles ( import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( opt_IgnoreIfacePragmas, verbosity ) +import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Parser ( parseIface ) import HscTypes ( ModIface(..), emptyModIface, ExternalPackageState(..), noDependencies, @@ -52,7 +52,7 @@ import Module ( Module, ModuleName, ModLocation(ml_hi_file), extendModuleEnv, lookupModuleEnvByName ) import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) -import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, +import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2, mkDataConWrapperOcc, mkDataConWorkerOcc ) import TyCon ( DataConDetails(..) ) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 5a4bd8e..c0d97db 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -41,7 +41,6 @@ import NameSet import Module ( Module, isHomeModule ) import PrelNames ( hasKey, fractionalClassKey, numClassKey, integerTyConName, doubleTyConName ) -import FiniteMap import Outputable import Bag import Maybe( fromJust ) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 04fc4b4..6eac67c 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -44,8 +44,8 @@ import OccName ( varName ) import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, lookupRdrEnv, rdrEnvToList, emptyRdrEnv, foldRdrEnv, rdrEnvElts, mkRdrUnqual, isQual, mkUnqual ) import Outputable -import Maybe ( isJust, isNothing, catMaybes, fromMaybe ) -import Maybes ( orElse, expectJust ) +import Maybe ( isJust, isNothing, catMaybes ) +import Maybes ( orElse ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition, insert ) @@ -554,14 +554,12 @@ exports_from_avail Nothing rdr_env -- keeping only things that are (a) qualified, -- (b) locally defined, (c) a 'main' name -- Then we look up in the entity-avail-env - return [ avail + return [ lookupAvailEnv entity_avail_env name | (rdr_name, gres) <- rdrEnvToList rdr_env, isQual rdr_name, -- Avoid duplicates GRE { gre_name = name, gre_parent = Nothing, -- Main things only - gre_prov = LocalDef } <- gres, - let avail = expectJust "exportsFromAvail" - (lookupAvailEnv entity_avail_env name) + gre_prov = LocalDef } <- gres ] } @@ -614,8 +612,7 @@ exports_from_avail (Just export_items) rdr_env -- Get the AvailInfo for the parent of the specified name let parent = gre_parent gre `orElse` gre_name gre - avail = expectJust "exportsFromAvail2" - (lookupAvailEnv entity_avail_env parent) + avail = lookupAvailEnv entity_avail_env parent in -- Filter out the bits we want case filterAvail ie avail of { @@ -697,28 +694,15 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") %********************************************************* \begin{code} -reportUnusedNames :: TcGblEnv - -> NameSet -- Used in this module - -> TcRn m () -reportUnusedNames gbl_env used_names - = warnUnusedModules unused_imp_mods `thenM_` - warnUnusedTopBinds bad_locals `thenM_` - warnUnusedImports bad_imports `thenM_` +reportUnusedNames :: TcGblEnv -> DefUses -> TcRn m () +reportUnusedNames gbl_env dus + = warnUnusedModules unused_imp_mods `thenM_` + warnUnusedTopBinds bad_locals `thenM_` + warnUnusedImports bad_imports `thenM_` printMinimalImports minimal_imports where - direct_import_mods :: [ModuleName] - direct_import_mods = map (moduleName . fst) - (moduleEnvElts (imp_mods (tcg_imports gbl_env))) - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names :: NameSet - really_used_names = used_names `unionNameSets` - mkNameSet [ parent - | GRE{ gre_name = name, - gre_parent = Just parent } - <- defined_names, - name `elemNameSet` used_names] + used_names :: NameSet + used_names = findUses dus emptyNameSet -- Collect the defined names from the in-scope environment -- Look for the qualified ones only, else get duplicates @@ -728,8 +712,17 @@ reportUnusedNames gbl_env used_names | otherwise = acc defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (defined_and_used, defined_but_not_used) = partition used defined_names - used gre = gre_name gre `elemNameSet` really_used_names + (defined_and_used, defined_but_not_used) = partition is_used defined_names + + is_used gre = n `elemNameSet` used_names || any (`elemNameSet` used_names) kids + -- The 'kids' part is because a use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + where + n = gre_name gre + kids = case lookupAvailEnv_maybe avail_env n of + Just (AvailTC n ns) -> ns + other -> [] -- Ids, class ops and datacons + -- (The latter two give Nothing) -- Filter out the ones that are -- (a) defined in this module, and @@ -737,7 +730,6 @@ reportUnusedNames gbl_env used_names -- The latter have an Internal Name, so we can filter them out easily bad_locals :: [GlobalRdrElt] bad_locals = filter is_bad defined_but_not_used - is_bad :: GlobalRdrElt -> Bool is_bad gre = isLocalGRE gre && isExternalName (gre_name gre) @@ -790,6 +782,13 @@ reportUnusedNames gbl_env used_names -- Add an empty collection of imports for a module -- from which we have sucked only instance decls + imports = tcg_imports gbl_env + avail_env = imp_env imports + + direct_import_mods :: [ModuleName] + direct_import_mods = map (moduleName . fst) + (moduleEnvElts (imp_mods imports)) + -- unused_imp_mods are the directly-imported modules -- that are not mentioned in minimal_imports1 -- [Note: not 'minimal_imports', because that includes direcly-imported diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index d9af807..bf1e97d 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -7,9 +7,9 @@ __export RnSource rnBindsAndThen rnBinds rnSrcDecls; -> TcRnTypes.RnM (b, NameSet.FreeVars) ; 1 rnBinds :: RdrHsSyn.RdrNameHsBinds - -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ; + -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ; 1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) ; + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.DefUses) ; diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 index 07779ea..0472eaa 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-6 +++ b/ghc/compiler/rename/RnSource.hi-boot-6 @@ -6,8 +6,8 @@ rnBindsAndThen :: forall b . RdrHsSyn.RdrNameHsBinds -> TcRnTypes.RnM (b, NameSet.FreeVars) ; rnBinds :: RdrHsSyn.RdrNameHsBinds - -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ; + -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ; rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.DefUses) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 945dcf5..d94ab3a 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -28,7 +28,7 @@ import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, rnMonoBindsAndThen, renameSigs, checkSigs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, newLocalsRn, lookupGlobalOccRn, - bindLocalsFVRn, bindPatSigTyVars, + bindLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, checkDupOrQualNames, checkDupNames, mapFvRn, @@ -37,7 +37,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, ) import TcRnMonad -import BasicTypes ( FixitySig(..) ) +import BasicTypes ( FixitySig(..), TopLevelFlag(..) ) import HscTypes ( ExternalPackageState(..), FixityEnv, Deprecations(..), plusDeprecs ) import Module ( moduleEnvElts ) @@ -75,7 +75,7 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars) +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, DefUses) rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_tyclds = tycl_decls, @@ -99,13 +99,21 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, $ do { -- Rename other declarations - (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ; - (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; - (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ; - (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ; - (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ; - (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ; - (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ; + (rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ; + + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + (rn_tycl_decls, src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ; + (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; + (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ; + (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ; + (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ; + (rn_core_decls, src_fvs6) <- mapFvRn rnCoreDecl core_decls ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -117,12 +125,14 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, hs_coreds = rn_core_decls } ; - src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] } ; - traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, + src_fvs4, src_fvs5, src_fvs6] ; + src_dus = bind_dus `plusDU` usesOnly other_fvs + } ; + tcg_env <- getGblEnv ; - return (tcg_env, rn_group, src_fvs) + return (tcg_env, rn_group, src_dus) }}} \end{code} @@ -249,18 +259,13 @@ is just one hi-boot file (for RnSource). rnSrcDecls is part of the loop too, and it must be defined in this module. \begin{code} -rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars) -rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs) -rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs - -- The parser doesn't produce other forms - -rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars) +rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, DefUses) -- This version assumes that the binders are already in scope -- It's used only in 'mdo' -rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs) -rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs +rnBinds EmptyBinds = returnM (EmptyBinds, emptyDUs) +rnBinds (MonoBind bind sigs _) = rnMonoBinds NotTopLevel bind sigs rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_` - returnM (EmptyBinds, emptyFVs) + returnM (EmptyBinds, emptyDUs) rnBindsAndThen :: RdrNameHsBinds -> (RenamedHsBinds -> RnM (result, FreeVars)) @@ -378,7 +383,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- -- But the (unqualified) method names are in scope bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' -> - checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_` + checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_` returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, meth_fvs `plusFV` hsSigsFVs uprags') @@ -404,10 +409,10 @@ rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way returnM (IfaceRuleOut fn' rule) rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) - = addSrcLoc src_loc $ - bindPatSigTyVars (collectRuleBndrSigTys vars) $ + = addSrcLoc src_loc $ + bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocalsFVRn doc (map get_var vars) $ \ ids -> + bindLocalsFV doc (map get_var vars) $ \ ids -> mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> rnExpr lhs `thenM` \ (lhs', fv_lhs) -> @@ -559,11 +564,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_` mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' -> - let - binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] - in - renameSigs non_op_sigs `thenM` \ non_ops' -> - checkSigs okClsDclSig binders non_ops' `thenM_` + renameSigs non_op_sigs `thenM` \ non_ops' -> + checkSigs okClsDclSig non_ops' `thenM_` -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 421378a..19cec11 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -21,7 +21,7 @@ import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat, parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn, - bindPatSigTyVars, bindLocalsFVRn, warnUnusedMatches ) + bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) import TcRnMonad import PrelNames( cCallishClassKeys, eqStringName, eqClassName, ordClassName, @@ -310,8 +310,8 @@ rnPatsAndThen :: HsMatchContext Name -- f x x = 1 rnPatsAndThen ctxt pats thing_inside - = bindPatSigTyVars pat_sig_tys $ - bindLocalsFVRn doc_pat bndrs $ \ new_bndrs -> + = bindPatSigTyVarsFV pat_sig_tys $ + bindLocalsFV doc_pat bndrs $ \ new_bndrs -> rnPats pats `thenM` \ (pats', pat_fvs) -> thing_inside pats' `thenM` \ (res, res_fvs) -> diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7b94e17..981731c 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -49,7 +49,7 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv), + SourceType(..), PredType, TyVarDetails(VanillaTv), tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, @@ -61,13 +61,12 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) -import Class ( Class ) import DataCon ( DataCon,dataConSig ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName ) import PprType ( pprPred, pprParendType ) -import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst ) +import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 933fc51..2ebe668 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), isClassOpSig, isPragSig, placeHolderType ) -import BasicTypes ( RecFlag(..), StrictnessMark(..) ) +import BasicTypes ( RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, RenamedClassOpSig, RenamedMonoBinds, maybeGenericMatch @@ -48,12 +48,11 @@ import Class ( classTyVars, classBigSig, classTyCon, import TyCon ( tyConGenInfo ) import Subst ( substTyWith ) import MkId ( mkDictSelId, mkDefaultMethodId ) -import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma ) +import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) import NameSet ( emptyNameSet, unitNameSet ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, reportIfUnused ) +import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused ) import Outputable import Var ( TyVar ) import CmdLineOpts diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index c7b7d64..6221930 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -22,12 +22,12 @@ import TcEnv ( tcExtendTempInstEnv, newDFunName, pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( InstEnv, simpleDFunClassTyCon ) +import InstEnv ( simpleDFunClassTyCon ) import TcMonoType ( tcHsPred ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) -import RnEnv ( bindLocalsFVRn ) +import RnEnv ( bindLocalsFV ) import TcRnMonad ( thenM, returnM, mapAndUnzipM ) import HscTypes ( DFunId ) @@ -256,11 +256,11 @@ deriveOrdinaryStuff eqns -- Rename to get RenamedBinds. -- The only tricky bit is that the extra_binds must scope -- over the method bindings for the instances. - bindLocalsFVRn (ptext (SLIT("deriving"))) mbinders $ \ _ -> - rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, fvs) -> + bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ -> + rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, dus) -> mapAndUnzipM rn_meths method_binds_s `thenM` \ (rn_method_binds_s, fvs_s) -> returnM ((rn_method_binds_s, rn_extra_binds), - fvs `plusFV` plusFVs fvs_s) + duUses dus `plusFV` plusFVs fvs_s) ) `thenM` \ ((rn_method_binds_s, rn_extra_binds), fvs) -> let new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index afbaa61..f8ad79c 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -57,12 +57,12 @@ import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, ) import qualified Type ( getTyVar_maybe ) import Rules ( extendRuleBase ) -import Id ( idName, isLocalId, isDataConWrapId_maybe ) +import Id ( idName, isLocalId ) import Var ( TyVar, Id, idType ) import VarSet import VarEnv import CoreSyn ( IdCoreRule ) -import DataCon ( DataCon, dataConWrapId ) +import DataCon ( DataCon ) import TyCon ( TyCon, DataConDetails ) import Class ( Class, ClassOpItem ) import Name ( Name, NamedThing(..), @@ -76,7 +76,6 @@ import Rules ( RuleBase ) import BasicTypes ( EP ) import Module ( Module ) import InstEnv ( InstEnv, extendInstEnv ) -import Maybes ( seqMaybe ) import SrcLoc ( SrcLoc ) import Outputable import Maybe ( isJust ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 39e7e40..296c504 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -42,17 +42,16 @@ import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType, import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, tcFunArgTy, + mkTyConApp, mkClassPred, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, - tcSplitSigmaTy, tcTyConAppTyCon, - tidyOpenType + tcSplitSigmaTy, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon ) +import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index fe27324..4956bdb 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -28,7 +28,7 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWorkId_maybe ) +import Id ( Id, mkVanillaGlobal, mkLocalId ) import MkId ( mkFCallId ) import IdInfo import TyCon ( tyConDataCons, tyConTyVars ) @@ -40,7 +40,7 @@ import Name ( Name ) import UniqSupply ( initUs_ ) import Outputable import Util ( zipWithEqual, dropList, equalLength ) -import HscTypes ( TyThing(..), typeEnvIds ) +import HscTypes ( typeEnvIds ) import CmdLineOpts ( DynFlag(..) ) \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index bc332aa..6b17d3a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -49,7 +49,6 @@ import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) import NameSet -import Id ( setIdLocalExported ) import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 33782b9..b7743ae 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -19,7 +19,7 @@ module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred, #include "HsVersions.h" import HsSyn ( HsType(..), HsTyVarBndr(..), HsTyOp(..), - Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames ) + Sig(..), HsPred(..), HsTupCon(..), hsTyVarNames ) import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars ) import TcHsSyn ( TcId ) @@ -31,14 +31,14 @@ import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType, zonkTcType, checkValidType, UserTypeCtxt(..), pprUserTypeCtxt, newOpenTypeKind ) -import TcUnify ( unifyKind, unifyOpenTypeKind, unifyFunKind ) +import TcUnify ( unifyKind, unifyFunKind ) import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..), TcTyVar, TcKind, TcThetaType, TcTauType, mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind, zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy, mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, - liftedTypeKind, unliftedTypeKind, mkArrowKind, eqKind, - mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys + liftedTypeKind, unliftedTypeKind, eqKind, + tcSplitFunTy_maybe, tcSplitForAllTys ) import qualified Type ( splitFunTys ) import Inst ( Inst, InstOrigin(..), newMethod, instToId ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index eeed95c..6e65eec 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -41,7 +41,7 @@ import RdrName ( RdrName, getRdrName, mkRdrUnqual, import RnHsSyn ( RenamedStmt, RenamedTyClDecl, ruleDeclFVs, instDeclFVs, tyClDeclFVs ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopBinds, zonkTopDecls, mkHsLet, + zonkTopDecls, mkHsLet, zonkTopExpr, zonkTopBndrs ) @@ -58,7 +58,6 @@ import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, - tcExtendGlobalEnv, tcExtendInstEnv, tcExtendRules, tcLookupTyCon, tcLookupGlobal, tcLookupId @@ -116,7 +115,6 @@ import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance( isLocalGRE ) #endif -import Maybe ( catMaybes ) import Panic ( showException ) import List ( partition ) import Util ( sortLt ) @@ -154,7 +152,7 @@ tcRnModule hsc_env pcs traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ; + (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; @@ -186,8 +184,8 @@ tcRnModule hsc_env pcs setGblEnv tcg_env $ do { -- Report unused names - let { used_fvs = src_fvs `plusFV` export_fvs } ; - reportUnusedNames tcg_env used_fvs ; + let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; + reportUnusedNames tcg_env all_dus ; -- Dump output and return tcDump tcg_env ; @@ -543,12 +541,12 @@ tcRnExtCore hsc_env pcs -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter let { local_group = mkGroup local_decls } ; - (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) + (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod) (rnSrcDecls local_group) ; failIfErrsM ; -- Get the supporting decls - rn_imp_decls <- slurpImpDecls fvs ; + rn_imp_decls <- slurpImpDecls (duUses dus) ; let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part @@ -603,13 +601,12 @@ tcRnExtCore hsc_env pcs %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings - tcRnSrcDecls decls = do { -- Do all the declarations - ((tc_envs, fvs), lie) <- getLIE (tc_rn_src_decls decls) ; + ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -636,17 +633,17 @@ tcRnSrcDecls decls return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, - fvs) + dus) }} -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), FreeVars) +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) tc_rn_src_decls ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tc_envs@(_,tcl_env), src_fvs1) <- tcRnGroup first_group ; + (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -659,7 +656,8 @@ tc_rn_src_decls ds case group_tail of { Nothing -> do { -- Last thing: check for `main' (tcg_env, main_fvs) <- checkMain ; - return ((tcg_env, tcl_env), src_fvs1 `plusFV` main_fvs) + return ((tcg_env, tcl_env), + src_dus1 `plusDU` usesOnly main_fvs) } ; -- If there's a splice, we must carry on @@ -669,19 +667,19 @@ tc_rn_src_decls ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, fvs) <- initRn SourceMode $ - addSrcLoc splice_loc $ - rnExpr splice_expr ; - tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ; + (rn_splice_expr, splice_fvs) <- initRn SourceMode $ + addSrcLoc splice_loc $ + rnExpr splice_expr ; + tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; setGblEnv tcg_env $ do { -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tc_envs, src_fvs2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; + (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - return (tc_envs, src_fvs1 `plusFV` src_fvs2) + return (tcg_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) } #endif /* GHCI */ }}} @@ -706,24 +704,24 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), FreeVars) +tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls = do { showLIE (text "LIE at start of tcRnGroup" <+> ppr decls) ; -- Rename the declarations - (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations tc_envs <- tcTopSrcDecls rn_decls ; showLIE (text "LIE at end of tcRnGroup" <+> ppr decls) ; - return (tc_envs, src_fvs) + return (tc_envs, src_dus) }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) rnTopSrcDecls group = do { -- Bring top level binders into scope (rdr_env, imports) <- importsFromLocalDecls group ; @@ -736,12 +734,13 @@ rnTopSrcDecls group failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ; + (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports + let { src_fvs = duUses src_dus } ; rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; @@ -749,7 +748,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_fvs) + return (tcg_env, rn_decls, src_dus) }}} ------------------------------------------------ diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 1e58edd..b63ffc2 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -23,7 +23,7 @@ module TcRnTypes( ImportAvails(..), emptyImportAvails, plusImportAvails, plusAvail, pruneAvails, AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, - mkAvailEnv, lookupAvailEnv, availEnvElts, addAvail, + mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail, WhereFrom(..), -- Typechecker types @@ -464,10 +464,11 @@ emptyUsages = emptyNameSet ImportAvails summarises what was imported from where, irrespective of whether the imported htings are actually used or not -It is used * when porcessing the export list +It is used * when processing the export list * when constructing usage info for the inteface file * to identify the list of directly imported modules for initialisation purposes + * when figuring out what things are really unused \begin{code} data ImportAvails @@ -597,7 +598,13 @@ unitAvailEnv a = unitNameEnv (availName a) a plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv plusAvailEnv = plusNameEnv_C plusAvail -lookupAvailEnv = lookupNameEnv +lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo +lookupAvailEnv_maybe = lookupNameEnv + +lookupAvailEnv :: AvailEnv -> Name -> AvailInfo +lookupAvailEnv env n = case lookupNameEnv env n of + Just avail -> avail + Nothing -> pprPanic "lookupAvailEnv" (ppr n) availEnvElts = nameEnvElts diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8c1b9da..29be17e 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -27,8 +27,7 @@ import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTag import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId ) import Var ( TyVar ) import Name ( Name ) -import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, - mkGenOcc1, mkGenOcc2, setOccNameSpace ) +import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) import Outputable import TyCon ( TyCon, DataConDetails(..), visibleDataCons, tyConTyVars, tyConName ) diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index e4116e2..c04d310 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -34,7 +34,7 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, isTauTy, isSigmaTy, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcGetTyVar_maybe, tcGetTyVar, - mkTyConApp, mkFunTy, tyVarsOfType, mkPhiTy, + mkFunTy, tyVarsOfType, mkPhiTy, typeKind, tcSplitFunTy_maybe, mkForAllTys, isHoleTyVar, isSkolemTyVar, isUserTyVar, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, @@ -45,17 +45,17 @@ import qualified Type ( getTyVar_maybe ) import Inst ( newDicts, instToId, tcInstCall ) import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult, newKindVar, newTyVarTy, newTyVarTys, newOpenTypeKind, newHoleTyVarTy, - zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar ) + zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV ) import TcSimplify ( tcSimplifyCheck ) import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy ) -import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, findGlobals ) +import TcEnv ( tcGetGlobalTyVars, findGlobals ) import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) import PprType ( pprType ) -import Id ( Id, mkSysLocal, idType ) +import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems ) import VarEnv -import Name ( isSystemName, getSrcLoc ) +import Name ( isSystemName ) import ErrUtils ( Message ) import BasicTypes ( Boxity, Arity, isBoxed ) import Util ( equalLength, notNull ) -- 1.7.10.4