X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=094a01f4c3cb9cc885d0fd1cf224e7e18defa20e;hb=2ecf1c9f639dc75f1078e88c2e551116923f742a;hp=0cc7b3f0402244f869ed37898c679b792864e735;hpb=4a91d102be99778efcab80211ca5de3f2cf6619a;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 0cc7b3f..094a01f 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,54 +4,53 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( renameModule ) where +module Rename ( renameModule, closeIfaceDecls, checkOldIface ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation ) -import RnHsSyn ( RenamedHsDecl, - extractHsTyNames, extractHsCtxtTyNames +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, + RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl + ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, + extractHsTyNames, + instDeclFVs, tyClDeclFVs, ruleDeclFVs ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo, - getInterfaceExports, - getImportedRules, getSlurped, removeContext, - ImportDeclResult(..) +import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) +import RnIfaces ( slurpImpDecls, mkImportInfo, + getInterfaceExports, closeDecls, + RecompileRequired, recompileRequired ) -import RnEnv ( availName, availsToNameSet, - emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails, +import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) +import RnEnv ( availName, + emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupGlobalRn, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV + lookupOrigNames, lookupGlobalRn, newGlobalName ) import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, - lookupModuleEnv + moduleNameUserString, moduleName ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, - nameOccName, nameUnique, nameModule, - isUserExportedName, + nameOccName, nameModule, mkNameEnv, nameEnvElts, extendNameEnv ) +import RdrName ( elemRdrEnv ) import OccName ( occNameFlavour ) -import Id ( idType ) -import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) +import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyCon_RDR, + ioTyCon_RDR, main_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) -import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv ) -import Type ( namesOfType, funTyCon ) -import ErrUtils ( printErrorsAndWarnings, dumpIfSet ) -import Bag ( isEmptyBag, bagToList ) +import PrelInfo ( derivingOccurrences ) +import Type ( funTyCon ) +import ErrUtils ( dumpIfSet ) +import Bag ( bagToList ) import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C, elemFM, addToFM ) @@ -59,61 +58,63 @@ import UniqFM ( lookupUFM ) import Maybes ( maybeToBool, catMaybes ) import Outputable import IO ( openFile, IOMode(..) ) -import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, - ModIface(..), TyThing(..), - GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, +import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, + ModIface(..), WhatsImported(..), + VersionInfo(..), ImportVersion, IfaceDecls(..), + GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..), initialVersionInfo, - Deprecations(..), lookupDeprec + Deprecations(..), lookupDeprec, lookupTable ) import List ( partition, nub ) \end{code} +%********************************************************* +%* * +\subsection{The main function: rename} +%* * +%********************************************************* + \begin{code} -renameModule :: DynFlags -> Finder +renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe ModIface) - -- The mi_decls in the ModIface include - -- ones imported from packages too + -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) + -- Nothing => some error occurred in the renamer -renameModule dflags finder hit hst old_pcs this_module - this_mod@(HsModule _ _ _ _ _ _ loc) +renameModule dflags hit hst old_pcs this_module rdr_module = -- Initialise the renamer monad do { - ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) - <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ; - - -- Check for warnings - printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ; - - -- Dump any debugging output - dump_action ; + (new_pcs, errors_found, maybe_rn_stuff) + <- initRn dflags hit hst old_pcs this_module (rename this_module rdr_module) ; - -- Return results - if not (isEmptyBag rn_errs_bag) then - return (old_pcs, Nothing) + -- Return results. No harm in updating the PCS + if errors_found then + return (new_pcs, Nothing) else return (new_pcs, maybe_rn_stuff) } \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ()) -rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod `thenRn` \ maybe_stuff -> +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl])) +rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) + = pushSrcLocRn loc $ - -- CHECK FOR EARLY EXIT - case maybe_stuff of { - Nothing -> -- Everything is up to date; no need to recompile further - rnDump [] [] `thenRn` \ dump_action -> - returnRn (Nothing, [], dump_action) ; - - Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> + -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, + export_avails, global_avail_env) -> + -- Exit if we've found any errors + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnDump [] [] `thenRn_` + returnRn Nothing + else + -- DEAL WITH DEPRECATIONS rnDeprecs local_gbl_env mod_deprec [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> @@ -126,6 +127,9 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls rnSourceDecls local_decls ) `thenRn` \ (rn_local_decls, source_fvs) -> + -- CHECK THAT main IS DEFINED, IF REQUIRED + checkMain this_module local_gbl_env `thenRn_` + -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let @@ -145,11 +149,11 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND - rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action -> + rnDump rn_imp_decls rn_local_decls `thenRn_` checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now - returnRn (Nothing, dump_action) + returnRn Nothing else -- GENERATE THE VERSION/USAGE INFO @@ -159,9 +163,6 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls getNameSupplyRn `thenRn` \ name_supply -> getIfacesRn `thenRn` \ ifaces -> let - direct_import_mods :: [ModuleName] - direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] - -- We record fixities even for things that aren't exported, -- so that we can change into the context of this moodule easily fixities = mkNameEnv [ (name, fixity) @@ -170,7 +171,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls -- Sort the exports to make them easier to compare for versions - my_exports = sortAvails export_avails + my_exports = groupAvails this_module export_avails mod_iface = ModIface { mi_module = this_module, mi_version = initialVersionInfo, @@ -187,12 +188,23 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls in -- REPORT UNUSED NAMES, AND DEBUG DUMP - reportUnusedNames mod_name direct_import_mods - gbl_env global_avail_env - export_avails source_fvs - rn_imp_decls `thenRn_` + reportUnusedNames mod_iface imports global_avail_env + real_source_fvs rn_imp_decls `thenRn_` - returnRn (Just (mod_iface, final_decls), dump_action) } + returnRn (Just (mod_iface, final_decls)) + where + mod_name = moduleName this_module +\end{code} + +Checking that main is defined + +\begin{code} +checkMain :: Module -> GlobalRdrEnv -> RnMG () +checkMain this_mod local_env + | moduleName this_mod == mAIN_Name + = checkRn (main_RDR `elemRdrEnv` local_env) noMainErr + | otherwise + = returnRn () \end{code} @implicitFVs@ forces the renamer to slurp in some things which aren't @@ -269,297 +281,6 @@ isOrphanDecl other = False %********************************************************* %* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` - - -- The current slurped-set records all local things - getSlurped `thenRn` \ source_binders -> - slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> - - -- Then get everything else - closeDecls decls needed `thenRn` \ decls1 -> - - -- Finally, get any deferred data type decls - slurpDeferredDecls decls1 `thenRn` \ final_decls -> - - returnRn final_decls - -------------------------------------------------------- -slurpSourceRefs :: NameSet -- Variables defined in source - -> FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars) -- Un-satisfied needs --- The declaration (and hence home module) of each gate has --- already been loaded - -slurpSourceRefs source_binders source_fvs - = go_outer [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - emptyFVs -- Accumulating gates - (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet - where - -- The outer loop repeatedly slurps the decls for the current gates - -- and the instance decls - - -- The outer loop is needed because consider - -- instance Foo a => Baz (Maybe a) where ... - -- It may be that @Baz@ and @Maybe@ are used in the source module, - -- but not @Foo@; so we need to chase @Foo@ too. - -- - -- We also need to follow superclass refs. In particular, 'chasing @Foo@' must - -- include actually getting in Foo's class decl - -- class Wib a => Foo a where .. - -- so that its superclasses are discovered. The point is that Wib is a gate too. - -- We do this for tycons too, so that we look through type synonyms. - - go_outer decls fvs all_gates [] - = returnRn (decls, fvs) - - go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> - getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> - rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> - go_outer decls2 fvs2 (all_gates `plusFV` gates2) - (nameSetToList (gates2 `minusNameSet` all_gates)) - -- Knock out the all_gates because even if we don't slurp any new - -- decls we can get some apparently-new gates from wired-in names - - go_inner (decls, fvs, gates) wanted_name - = importDecl wanted_name `thenRn` \ import_result -> - case import_result of - AlreadySlurped -> returnRn (decls, fvs, gates) - WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name) - Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor - - HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl : decls, - fvs1 `plusFV` fvs, - gates `plusFV` getGates source_fvs new_decl) - -rnInstDecls decls fvs gates [] - = returnRn (decls, fvs, gates) -rnInstDecls decls fvs gates (d:ds) - = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnInstDecls (new_decl:decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getInstDeclGates new_decl) - ds -\end{code} - - -\begin{code} -------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - | not (isEmptyFVs needed) - = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - | otherwise - = getImportedRules `thenRn` \ rule_decls -> - case rule_decls of - [] -> returnRn decls -- No new rules, so we are done - other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - -------------------------------------------------------- --- Augment decls with any decls needed by needed. --- Return also free vars of the new decls (only) -slurpDecls decls needed - = go decls emptyFVs (nameSetToList needed) - where - go decls fvs [] = returnRn (decls, fvs) - go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> - go decls1 fvs1 refs - -------------------------------------------------------- -slurpDecl decls fvs wanted_name - = importDecl wanted_name `thenRn` \ import_result -> - case import_result of - -- Found a declaration... rename it - HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 `plusFV` fvs) - - -- No declaration... (wired in thing, or deferred, or already slurped) - other -> returnRn (decls, fvs) - - -------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) -\end{code} - - -%********************************************************* -%* * -\subsection{Deferred declarations} -%* * -%********************************************************* - -The idea of deferred declarations is this. Suppose we have a function - f :: T -> Int - data T = T1 A | T2 B - data A = A1 X | A2 Y - data B = B1 P | B2 Q -Then we don't want to load T and all its constructors, and all -the types those constructors refer to, and all the types *those* -constructors refer to, and so on. That might mean loading many more -interface files than is really necessary. So we 'defer' loading T. - -But f might be strict, and the calling convention for evaluating -values of type T depends on how many constructors T has, so -we do need to load T, but not the full details of the type T. -So we load the full decl for T, but only skeleton decls for A and B: - f :: T -> Int - data T = {- 2 constructors -} - -Whether all this is worth it is moot. - -\begin{code} -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls = returnRn decls - -{- OMIT FOR NOW -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls - = getDeferredDecls `thenRn` \ def_decls -> - rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> - ASSERT( isEmptyFVs fvs ) - returnRn decls1 - -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc - name1 name2)) - -- Nuke the context and constructors - -- But retain the *number* of constructors! - -- Also the tvs will have kinds on them. --} -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the `gates'} -%* * -%********************************************************* - -When we import a declaration like -\begin{verbatim} - data T = T1 Wibble | T2 Wobble -\end{verbatim} -we don't want to treat @Wibble@ and @Wobble@ as gates -{\em unless} @T1@, @T2@ respectively are mentioned by the user program. -If only @T@ is mentioned -we want only @T@ to be a gate; -that way we don't suck in useless instance -decls for (say) @Eq Wibble@, when they can't possibly be useful. - -@getGates@ takes a newly imported (and renamed) decl, and the free -vars of the source program, and extracts from the decl the gate names. - -\begin{code} -getGates source_fvs (SigD (IfaceSig _ ty _ _)) - = extractHsTyNames ty - -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ )) - = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (hsTyVarNames tvs) - `addOneToNameSet` cls) - `plusFV` maybe_double - where - get (ClassOpSig n _ ty _) - | n `elemNameSet` source_fvs = extractHsTyNames ty - | otherwise = emptyFVs - - -- If we load any numeric class that doesn't have - -- Int as an instance, add Double to the gates. - -- This takes account of the fact that Double might be needed for - -- defaulting, but we don't want to load Double (and all its baggage) - -- if the more exotic classes aren't used at all. - maybe_double | nameUnique cls `elem` fractionalClassKeys - = unitFV (getName doubleTyCon) - | otherwise - = emptyFVs - -getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) - = delListFromNameSet (extractHsTyNames ty) - (hsTyVarNames tvs) - -- A type synonym type constructor isn't a "gate" for instance decls - -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) - (hsTyVarNames tvs) - `addOneToNameSet` tycon - where - get (ConDecl n _ tvs ctxt details _) - | n `elemNameSet` source_fvs - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details `plusFV` - extractHsCtxtTyNames ctxt) - (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 - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - 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_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t - | otherwise = emptyFVs - - get_bang bty = extractHsTyNames (getBangType bty) - -getGates source_fvs other_decl = emptyFVs -\end{code} - -@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ -rather than a declaration. - -\begin{code} -getWiredInGates :: Name -> FreeVars -getWiredInGates name -- No classes are wired in - = case lookupNameEnv wiredInThingEnv name of - Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id)) - - Just (ATyCon tc) - | isSynTyCon tc - -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) - where - (tyvars,ty) = getSynTyConDefn tc - - other -> unitFV name - -getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) -\end{code} - -\begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs -\end{code} - - -%********************************************************* -%* * \subsection{Fixities} %* * %********************************************************* @@ -631,11 +352,168 @@ rnDeprecs gbl_env Nothing decls = pushSrcLocRn loc $ lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name -> case maybe_name of - Just n -> returnRn (Just (n,txt)) + Just n -> returnRn (Just (n,(n,txt))) Nothing -> returnRn Nothing \end{code} +%************************************************************************ +%* * +\subsection{Grabbing the old interface file and checking versions} +%* * +%************************************************************************ + +\begin{code} +checkOldIface :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module + -> Bool -- Source unchanged + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface)) + -- True <=> errors happened + +checkOldIface dflags hit hst pcs mod source_unchanged maybe_iface + = initRn dflags hit hst pcs mod $ + + -- Load the old interface file, if we havn't already got it + loadOldIface mod maybe_iface `thenRn` \ maybe_iface -> + + -- Check versions + recompileRequired mod source_unchanged maybe_iface `thenRn` \ recompile -> + + returnRn (recompile, maybe_iface) +\end{code} + + +\begin{code} +loadOldIface :: Module -> Maybe ModIface -> RnMG (Maybe ModIface) +loadOldIface mod (Just iface) + = returnRn (Just iface) + +loadOldIface mod Nothing + = -- LOAD THE OLD INTERFACE FILE + findAndReadIface doc_str (moduleName mod) False {- Not hi-boot -} `thenRn` \ read_result -> + case read_result of { + Left err -> -- Old interface file not found, or garbled, so we'd better bail out + traceRn (vcat [ptext SLIT("No old interface file:"), err]) `thenRn_` + returnRn Nothing ; + + Right (_, iface) -> + + -- RENAME IT + initIfaceRnMS mod ( + loadHomeDecls (pi_decls iface) `thenRn` \ decls -> + loadHomeRules (pi_rules iface) `thenRn` \ rules -> + loadHomeInsts (pi_insts iface) `thenRn` \ insts -> + returnRn (decls, rules, insts) + ) `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> + + mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages -> + loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> + loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> + loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> + let + version = VersionInfo { vers_module = pi_vers iface, + vers_exports = export_vers, + vers_rules = rule_vers, + vers_decls = decls_vers } + + decls = IfaceDecls { dcl_tycl = new_decls, + dcl_rules = new_rules, + dcl_insts = new_insts } + + mod_iface = ModIface { mi_module = mod, mi_version = version, + mi_exports = avails, mi_orphan = pi_orphan iface, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_usages = usages, + mi_decls = decls, + mi_globals = panic "No mi_globals in old interface" + } + in + returnRn (Just mod_iface) + } + + + where + doc_str = ptext SLIT("need usage info from") <+> ppr mod +\end{code} + +\begin{code} +loadHomeDecls :: [(Version, RdrNameTyClDecl)] + -> RnMS (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls + +loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) + -> (Version, RdrNameTyClDecl) + -> RnMS (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecl (version_map, decls) (version, decl) + = rnTyClDecl decl `thenRn` \ decl' -> + returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) + +------------------ +loadHomeRules :: (Version, [RdrNameRuleDecl]) + -> RnMS (Version, [RenamedRuleDecl]) +loadHomeRules (version, rules) + = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' -> + returnRn (version, rules') + +------------------ +loadHomeInsts :: [RdrNameInstDecl] + -> RnMS [RenamedInstDecl] +loadHomeInsts insts = mapRn rnInstDecl insts + +------------------ +loadHomeUsage :: ImportVersion OccName + -> RnMG (ImportVersion Name) +loadHomeUsage (mod_name, orphans, is_boot, whats_imported) + = rn_imps whats_imported `thenRn` \ whats_imported' -> + returnRn (mod_name, orphans, is_boot, whats_imported') + where + rn_imps NothingAtAll = returnRn NothingAtAll + rn_imps (Everything v) = returnRn (Everything v) + rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' -> + returnRn (Specifically mv ev items' rv) + rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name -> + returnRn (name,vers) +\end{code} + + + +%********************************************************* +%* * +\subsection{Closing up the interface decls} +%* * +%********************************************************* + +Suppose we discover we don't need to recompile. Then we start from the +IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. + +\begin{code} +closeIfaceDecls :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> ModIface -- Get the decls from here + -> IO (PersistentCompilerState, Bool, [RenamedHsDecl]) + -- True <=> errors happened +closeIfaceDecls dflags hit hst pcs + mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) + = initRn dflags hit hst pcs mod $ + + let + rule_decls = dcl_rules iface_decls + inst_decls = dcl_insts iface_decls + tycl_decls = dcl_tycl iface_decls + decls = map RuleD rule_decls ++ + map InstD inst_decls ++ + map TyClD tycl_decls + needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` + unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` + unionManyNameSets (map tyClDeclFVs tycl_decls) + in + closeDecls decls needed +\end{code} + %********************************************************* %* * \subsection{Unused names} @@ -643,23 +521,22 @@ rnDeprecs gbl_env Nothing decls %********************************************************* \begin{code} -reportUnusedNames :: ModuleName -> [ModuleName] - -> GlobalRdrEnv -> AvailEnv - -> Avails -> NameSet -> [RenamedHsDecl] +reportUnusedNames :: ModIface -> [RdrNameImportDecl] + -> AvailEnv + -> NameSet + -> [RenamedHsDecl] -> RnMG () -reportUnusedNames mod_name direct_import_mods - gbl_env avail_env - export_avails mentioned_names - imported_decls +reportUnusedNames my_mod_iface imports avail_env + used_names imported_decls = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports mod_name minimal_imports `thenRn_` - warnDeprecations really_used_names `thenRn_` + printMinimalImports my_mod_iface minimal_imports `thenRn_` + warnDeprecations my_mod_iface really_used_names `thenRn_` returnRn () where - used_names = mentioned_names `unionNameSets` availsToNameSet export_avails + gbl_env = mi_globals my_mod_iface -- Now, a use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) @@ -738,7 +615,10 @@ reportUnusedNames mod_name direct_import_mods | otherwise = addToFM acc m emptyAvailEnv -- Add an empty collection of imports for a module -- from which we have sucked only instance decls - + + direct_import_mods :: [ModuleName] + direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] + -- unused_imp_mods are the directly-imported modules -- that are not mentioned in minimal_imports unused_imp_mods = [m | m <- direct_import_mods, @@ -749,7 +629,7 @@ reportUnusedNames mod_name direct_import_mods module_unused mod = moduleName mod `elem` unused_imp_mods -warnDeprecations used_names +warnDeprecations my_mod_iface used_names = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> if not warn_drs then returnRn () else @@ -764,17 +644,16 @@ warnDeprecations used_names mapRn_ warnDeprec deprecs where - lookup_deprec hit pit n - = case lookupModuleEnv hit mod of - Just iface -> lookupDeprec iface n - Nothing -> case lookupModuleEnv pit mod of - Just iface -> lookupDeprec iface n - Nothing -> pprPanic "warnDeprecations:" (ppr n) - where - mod = nameModule n + mod = mi_module my_mod_iface + my_deprecs = mi_deprecs my_mod_iface + lookup_deprec hit pit n + | isLocalThing mod n = lookupDeprec my_deprecs n + | otherwise = case lookupTable hit pit n of + Just iface -> lookupDeprec (mi_deprecs iface) n + Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports mod_name imps +printMinimalImports my_mod_iface imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else @@ -784,7 +663,8 @@ printMinimalImports mod_name imps }) `thenRn_` returnRn () where - filename = moduleNameUserString mod_name ++ ".imports" + filename = moduleNameUserString (moduleName (mi_module my_mod_iface)) + ++ ".imports" ppr_mod_ie (mod_name, ies) | mod_name == pRELUDE_Name = empty @@ -799,28 +679,37 @@ printMinimalImports mod_name imps to_ie (Avail n) = returnRn (IEVar n) to_ie (AvailTC n [m]) = ASSERT( n==m ) returnRn (IEThingAbs n) - to_ie (AvailTC n ns) = getInterfaceExports (moduleName (nameModule n)) - ImportBySystem `thenRn` \ (_, avails) -> - case [ms | AvailTC m ms <- avails, m == n] of - [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n) - | otherwise -> returnRn (IEThingWith n (filter (/= n) ns)) - other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ - returnRn (IEVar n) + to_ie (AvailTC n ns) + = getInterfaceExports n_mod ImportBySystem `thenRn` \ (_, avails_by_module) -> + case [xs | (m,as) <- avails_by_module, + m == n_mod, + AvailTC x xs <- as, + x == n] of + [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n) + | otherwise -> returnRn (IEThingWith n (filter (/= n) ns)) + other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ + returnRn (IEVar n) + where + n_mod = moduleName (nameModule n) rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls - -> RnMG (IO ()) + -> RnMG () rnDump imp_decls local_decls - = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> - doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> - if dump_rn_trace || dump_rn_stats || dump_rn then - getRnStats imp_decls `thenRn` \ stats_msg -> - returnRn (printErrs stats_msg >> - dumpIfSet dump_rn "Renamer:" - (vcat (map ppr (local_decls ++ imp_decls)))) - else - returnRn (return ()) + = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> + doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + getIfacesRn `thenRn` \ ifaces -> + + ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) + "Renamer statistics" + (getRnStats imp_decls ifaces) ; + + dumpIfSet dump_rn "Renamer:" + (vcat (map ppr (local_decls ++ imp_decls))) + }) `thenRn_` + + returnRn () \end{code} @@ -831,47 +720,45 @@ rnDump imp_decls local_decls %********************************************************* \begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG SDoc -getRnStats imported_decls - = getIfacesRn `thenRn` \ ifaces -> - let - n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] - - decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) - ] - - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read - (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls - - unslurped_insts = iInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported, out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported, out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"], - text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- imported_decls, isClassDecl d]), - text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- decls_read, isClassDecl d])] - in - returnRn (hcat [text "Renamer stats: ", stats]) +getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc +getRnStats imported_decls ifaces + = hcat [text "Renamer stats: ", stats] + where + n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] + + decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + not (isLocallyDefined (availName avail)) + ] + + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read + (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + + unslurped_insts = iInsts ifaces + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [ int dd_sp, text "data decls imported, out of", + int dd_rd, text "read"], + hsep [ int nd_sp, text "newtype decls imported, out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"], + text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- imported_decls, isClassDecl d]), + text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) + [d | d <- decls_read, isClassDecl d])] count_decls decls = (class_decls, @@ -882,9 +769,8 @@ count_decls decls inst_decls) where tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls + (class_decls, data_decls, newtype_decls, syn_decls, val_decls) = countTyClDecls tycl_decls - val_decls = length [() | SigD _ <- decls] inst_decls = length [() | InstD _ <- decls] \end{code} @@ -915,142 +801,10 @@ dupFixityDecl rdr_name loc1 loc2 badDeprec d = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), nest 4 (ppr d)] -\end{code} - - -%******************************************************** -%* * -\subsection{Checking usage information} -%* * -%******************************************************** - -\begin{code} -{- -checkEarlyExit mod_name - = traceRn (text "Considering whether compilation is required...") `thenRn_` - - -- Read the old interface file, if any, for the module being compiled - findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case maybe_iface of - Left err -> -- Old interface file not found, so we'd better bail out - traceRn (vcat [ptext SLIT("No old interface file for") <+> ppr mod_name, - err]) `thenRn_` - returnRn (outOfDate, Nothing) - - Right iface - | panic "checkEarlyExit: ???: not opt_SourceUnchanged" - -> -- Source code changed - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn (False, Just iface) - - | otherwise - -> -- Source code unchanged and no errors yet... carry on - checkModUsage (pi_usages iface) `thenRn` \ up_to_date -> - returnRn (up_to_date, Just iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name] -\end{code} - -\begin{code} -upToDate = True -outOfDate = False - -checkModUsage :: [ImportVersion OccName] -> RnMG Bool --- Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. - -checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date! - -checkModUsage ((mod_name, _, _, NothingAtAll) : rest) - -- If CurrentModule.hi contains - -- import Foo :: ; - -- then that simply records that Foo lies below CurrentModule in the - -- hierarchy, but CurrentModule doesn't depend in any way on Foo. - -- In this case we don't even want to open Foo's interface. - = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` - checkModUsage rest -- This one's ok, so check the rest - -checkModUsage ((mod_name, _, _, whats_imported) : rest) - = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> - case maybe_err of { - Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name]) ; - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain -- it might just be that - -- the current module doesn't need that import and it's been deleted - - Nothing -> - let - (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) - = case lookupFM (iImpModInfo ifaces) mod_name of - Just (_, _, Just stuff) -> stuff - - old_mod_vers = case whats_imported of - Everything v -> v - Specifically v _ _ _ -> v - -- NothingAtAll case dealt with by previous eqn for checkModUsage - in - -- If the module version hasn't changed, just move on - if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), ppr mod_name]) - `thenRn_` checkModUsage rest - else - traceRn (sep [ptext SLIT("Module version has changed:"), ppr mod_name]) - `thenRn_` - -- Module version changed, so check entities inside - - -- If the usage info wants to say "I imported everything from this module" - -- it does so by making whats_imported equal to Everything - -- In that case, we must recompile - case whats_imported of { -- NothingAtAll dealt with earlier - - Everything _ - -> out_of_date (ptext SLIT("...and I needed the whole module")) ; - - Specifically _ old_fix_vers old_rule_vers old_local_vers -> - - if old_fix_vers /= new_fix_vers then - out_of_date (ptext SLIT("Fixities changed")) - else if old_rule_vers /= new_rule_vers then - out_of_date (ptext SLIT("Rules changed")) - else - -- Non-empty usage list, so check item by item - checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> - if up_to_date then - traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` - checkModUsage rest -- This one's ok, so check the rest - else - returnRn outOfDate -- This one failed, so just bail out now - }} - where - doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - - -checkEntityUsage mod decls [] - = returnRn upToDate -- Yes! All up to date! - -checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = newGlobalName mod occ_name `thenRn` \ name -> - case lookupNameEnv decls name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) - - Just (new_vers,_,_,_) -- It's there, but is it up to date? - | new_vers == old_vers - -- Up to date, so check the rest - -> checkEntityUsage mod decls rest - - | otherwise - -- Out of date, so bale out - -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) -out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate --} +noMainErr + = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name), + ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] \end{code}