X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=9d340f24c1966ed5fc3193993d2e6f97609f4eb5;hb=a237946da277f10bd3d223e5926d118044d24194;hp=1a9cc0bcc06d8ad3e8be745147b65ab72bd5d420;hpb=ec459c238894ee4e2f7d1a30875a4d5446131c5d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 1a9cc0b..9d340f2 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -15,7 +15,7 @@ import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) -import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports, +import CmdLineOpts ( dopt_D_dump_rn_trace, dopt_D_dump_minimal_imports, opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations, opt_WarnUnusedBinds ) @@ -23,13 +23,13 @@ import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports, - getImportedRules, loadHomeInterface, getSlurped, removeContext, + getImportedRules, getSlurped, removeContext, loadBuiltinRules, getDeferredDecls, ImportDeclResult(..) ) import RnEnv ( availName, availsToNameSet, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupImplicitOccsRn, pprAvail, unknownNameErr, + lookupOrigNames, unknownNameErr, FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), @@ -38,8 +38,9 @@ import Module ( Module, ModuleName, WhereFrom(..), import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, nameOccName, nameUnique, nameModule, maybeUserImportedFrom, isUserImportedExplicitlyName, isUserImportedName, - maybeWiredInTyConName, maybeWiredInIdName, isWiredInName, - isUserExportedName, toRdrName + maybeWiredInTyConName, maybeWiredInIdName, + isUserExportedName, toRdrName, + nameEnvElts, extendNameEnv ) import OccName ( occNameFlavour, isValOcc ) import Id ( idType ) @@ -47,10 +48,12 @@ import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) import PrelRules ( builtinRules ) -import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyCon_RDR, unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR, - fractionalClassKeys, derivingOccurrences +import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, + ioTyCon_RDR, + unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, + eqString_RDR ) +import PrelInfo ( fractionalClassKeys, derivingOccurrences ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) import BasicTypes ( Version, initialVersion ) @@ -75,14 +78,17 @@ type RenameResult = ( Module -- This module , ParsedIface -- The new interface , RnNameSupply -- Final env; for renaming derivings , FixityEnv -- The fixity environment; for derivings - , [ModuleName]) -- Imported modules; for profiling + , [Module]) -- Imported modules -renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult) -renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc) +renameModule :: PersistentCompilerState -> RdrNameHsModule -> IO (Maybe RenameResult) +renameModule pcs this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad do { ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) - <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ; + <- initRn pcs + (mkThisModule mod_name) + (mkSearchPath opt_HiMap) loc + (rename this_mod) ; -- Check for warnings printErrorsAndWarnings rn_errs_bag rn_warns_bag ; @@ -154,10 +160,20 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) -> -- RETURN THE RENAMED MODULE - getNameSupplyRn `thenRn` \ name_supply -> + getNameSupplyRn `thenRn` \ name_supply -> + getIfacesRn `thenRn` \ ifaces -> let + direct_import_mods :: [Module] + direct_import_mods = [m | (_, _, Just (m, _, _, _, imp, _)) + <- eltsFM (iImpModInfo ifaces), user_import imp] + + -- *don't* just pick the forward edges. It's entirely possible + -- that a module is only reachable via back edges. + user_import ImportByUser = True + user_import ImportByUserSource = True + user_import _ = False + this_module = mkThisModule mod_name - direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] -- Export only those fixities that are for names that are -- (a) defined in this module @@ -209,7 +225,7 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} implicitFVs mod_name decls - = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names -> + = lookupOrigNames implicit_occs `thenRn` \ implicit_names -> returnRn (mkNameSet (map getName default_tycons) `plusFV` implicit_names) where @@ -234,9 +250,10 @@ implicitFVs mod_name decls implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls -- Virtually every program has error messages in it somewhere - string_occs = [unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR] + string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, + eqString_RDR] - get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _)) + get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -262,6 +279,7 @@ isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) check (HsVar v) = not (isLocallyDefined v) check (HsApp f a) = check f && check a check (HsLit _) = False + check (HsOverLit _) = False check (OpApp l o _ r) = check l && check o && check r check (NegApp e _) = check e check (HsPar e) = check e @@ -455,8 +473,9 @@ slurpDeferredDecls decls ASSERT( isEmptyFVs fvs ) returnRn decls1 -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc)) +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc + name1 name2)) -- Nuke the context and constructors -- But retain the *number* of constructors! -- Also the tvs will have kinds on them. @@ -487,13 +506,13 @@ vars of the source program, and extracts from the decl the gate names. getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _)) +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ )) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (map getTyVarName tvs) + (hsTyVarNames tvs) `addOneToNameSet` cls) `plusFV` maybe_double where - get (ClassOpSig n _ _ ty _) + get (ClassOpSig n _ ty _) | n `elemNameSet` source_fvs = extractHsTyNames ty | otherwise = emptyFVs @@ -509,12 +528,12 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _)) getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) = delListFromNameSet (extractHsTyNames ty) - (map getTyVarName tvs) + (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) - (map getTyVarName tvs) + (hsTyVarNames tvs) `addOneToNameSet` tycon where get (ConDecl n _ tvs ctxt details _) @@ -522,7 +541,7 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) - (map getTyVarName tvs) + (hsTyVarNames tvs) get (ConDecl n _ tvs ctxt (RecCon fields) _) -- Even if the constructor isn't mentioned, the fields -- might be, as selectors. They can't mention existentially @@ -535,14 +554,11 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) get_details (VanillaCon tys) = plusFVs (map get_bang tys) get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_details (NewCon t _) = extractHsTyNames t get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t | otherwise = emptyFVs - get_bang (Banged t) = extractHsTyNames t - get_bang (Unbanged t) = extractHsTyNames t - get_bang (Unpacked t) = extractHsTyNames t + get_bang bty = extractHsTyNames (getBangType bty) getGates source_fvs other_decl = emptyFVs \end{code} @@ -591,7 +607,7 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ )) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl @@ -612,7 +628,7 @@ fixitiesFromLocalDecls gbl_env decls Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` returnRn acc ; - Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) + Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc)) }} \end{code} @@ -656,7 +672,7 @@ rnDeprecs gbl_env mod_deprec decls %********************************************************* \begin{code} -reportUnusedNames :: ModuleName -> [ModuleName] +reportUnusedNames :: ModuleName -> [Module] -> GlobalRdrEnv -> AvailEnv -> Avails -> NameSet -> [RenamedHsDecl] -> RnMG () @@ -725,19 +741,19 @@ reportUnusedNames mod_name direct_import_mods -- import This. Sigh. -- There's really no good way to detect this, so the error message -- in RnEnv.warnUnusedModules is weakened instead - inst_mods = [m | InstD (InstDecl _ _ _ dfun _) <- imported_decls, - let m = moduleName (nameModule dfun), + inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls, + let m = nameModule dfun, m `elem` direct_import_mods ] - minimal_imports :: FiniteMap ModuleName AvailEnv + minimal_imports :: FiniteMap Module AvailEnv minimal_imports0 = emptyFM minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods add_name n acc = case maybeUserImportedFrom n of Nothing -> acc - Just m -> addToFM_C plusAvailEnv acc (moduleName m) + Just m -> addToFM_C plusAvailEnv acc m (unitAvailEnv (mk_avail n)) add_inst_mod m acc | m `elemFM` acc = acc -- We import something already @@ -753,13 +769,14 @@ reportUnusedNames mod_name direct_import_mods -- unused_imp_mods are the directly-imported modules -- that are not mentioned in minimal_imports - unused_imp_mods = [m | m <- direct_import_mods, - not (maybeToBool (lookupFM minimal_imports m))] + unused_imp_mods = [m | m <- direct_import_mods, + not (maybeToBool (lookupFM minimal_imports m)), + moduleName m /= pRELUDE_Name] module_unused :: Name -> Bool -- Name is imported from a module that's completely unused, -- so don't report stuff about the name (the module covers it) - module_unused n = moduleName (expectJust "module_unused" (maybeUserImportedFrom n)) + module_unused n = expectJust "module_unused" (maybeUserImportedFrom n) `elem` unused_imp_mods -- module_unused is only called if it's user-imported in @@ -792,7 +809,7 @@ printMinimalImports mod_name imps parens (fsep (punctuate comma (map ppr ies))) to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies -> - returnRn (mod, ies) + returnRn (moduleName mod, ies) to_ie :: AvailInfo -> RnMG (IE Name) to_ie (Avail n) = returnRn (IEVar n)