X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnIfaces.lhs;h=43e3cd9b01b5638641a1fcc56a487bf7abd8b3e3;hb=f74e9e28c66072f93150fe026f87549e2f255128;hp=9d0ffaf5491f1e5c0f574d6e2727b7c2b747674b;hpb=2ecf1c9f639dc75f1078e88c2e551116923f742a;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 9d0ffaf..43e3cd9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -18,33 +18,37 @@ where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls ) import HscTypes import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType ) import HsImpExp ( ImportDecl(..) ) -import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl ) -import RnHsSyn ( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames, tyClDeclFVs ) +import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, + extractHsTyNames, extractHsCtxtTyNames, + tyClDeclFVs, ruleDeclFVs, instDeclFVs + ) import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules ) -import RnSource ( rnTyClDecl, rnDecl ) +import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) import RnEnv import RnMonad import Id ( idType ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocallyDefined, nameUnique, - NamedThing(..), - elemNameEnv + nameModule, isLocalName, nameUnique, + NamedThing(..) ) -import Module ( Module, ModuleEnv, mkVanillaModule, +import Name ( elemNameEnv, delFromNameEnv ) +import Module ( Module, ModuleEnv, moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), - emptyModuleEnv, lookupModuleEnvByName, - extendModuleEnv_C, lookupWithDefaultModuleEnv + emptyModuleEnv, + extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, + elemModuleSet, extendModuleSet ) import NameSet import PrelInfo ( wiredInThingEnv, fractionalClassKeys ) @@ -53,8 +57,7 @@ import Maybes ( orElse ) import FiniteMap import Outputable import Bag - -import List ( nub ) +import Util ( sortLt ) \end{code} @@ -69,95 +72,10 @@ import List ( nub ) \begin{code} getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)]) getInterfaceExports mod_name from - = getHomeIfaceTableRn `thenRn` \ hit -> - case lookupModuleEnvByName hit mod_name of { - Just mi -> returnRn (mi_module mi, mi_exports mi) ; - Nothing -> - - loadInterface doc_str mod_name from `thenRn` \ ifaces -> - case lookupModuleEnvByName (iPIT ifaces) mod_name of - Just mi -> returnRn (mi_module mi, mi_exports mi) ; - -- loadInterface always puts something in the map - -- even if it's a fake - Nothing -> returnRn (mkVanillaModule mod_name, []) - -- pprPanic "getInterfaceExports" (ppr mod_name) - } - where - doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")] -\end{code} - - -%********************************************************* -%* * -\subsection{Instance declarations are handled specially} -%* * -%********************************************************* - -\begin{code} -getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] -getImportedInstDecls gates - = -- First, load any orphan-instance modules that aren't aready loaded - -- Orphan-instance modules are recorded in the module dependecnies - getIfacesRn `thenRn` \ ifaces -> - let - orphan_mods = - [mod | (mod, (True, _, False)) <- fmToList (iImpModInfo ifaces)] - in - loadOrphanModules orphan_mods `thenRn_` - - -- Now we're ready to grab the instance declarations - -- Find the un-gated ones and return them, - -- removing them from the bag kept in Ifaces - getIfacesRn `thenRn` \ ifaces -> - let - (decls, new_insts) = selectGated gates (iInsts ifaces) - in - setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` - - traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr gate_list)), - text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` - returnRn decls - where - gate_list = nameSetToList gates - -ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) - = case inst_ty of - HsForAllTy _ _ tau -> ppr tau - other -> ppr inst_ty - -getImportedRules :: RnMG [(Module,RdrNameHsDecl)] -getImportedRules - | opt_IgnoreIfacePragmas = returnRn [] - | otherwise - = getIfacesRn `thenRn` \ ifaces -> - let - gates = iSlurp ifaces -- Anything at all that's been slurped - rules = iRules ifaces - (decls, new_rules) = selectGated gates rules - in - if null decls then - returnRn [] - else - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` - traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` - returnRn decls - -selectGated gates decl_bag - -- Select only those decls whose gates are *all* in 'gates' -#ifdef DEBUG - | opt_NoPruneDecls -- Just to try the effect of not gating at all - = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all - - | otherwise -#endif - = foldrBag select ([], emptyBag) decl_bag + = loadInterface doc_str mod_name from `thenRn` \ iface -> + returnRn (mi_module iface, mi_exports iface) where - select (reqd, decl) (yes, no) - | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) - | otherwise = (yes, (reqd,decl) `consBag` no) + doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")] \end{code} @@ -167,53 +85,14 @@ selectGated gates decl_bag %* * %********************************************************* -getImportVersions figures out what the ``usage information'' for this +mkImportInof figures out what the ``usage information'' for this moudule is; that is, what it must record in its interface file as the -things it uses. It records: - -\begin{itemize} -\item (a) anything reachable from its body code -\item (b) any module exported with a @module Foo@ -\item (c) anything reachable from an exported item -\end{itemize} - -Why (b)? Because if @Foo@ changes then this module's export list -will change, so we must recompile this module at least as far as -making a new interface file --- but in practice that means complete -recompilation. - -Why (c)? Consider this: -\begin{verbatim} - module A( f, g ) where | module B( f ) where - import B( f ) | f = h 3 - g = ... | h = ... -\end{verbatim} - -Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in -@A@'s usages? Our idea is that we aren't going to touch A.hi if it is -*identical* to what it was before. If anything about @B.f@ changes -than anyone who imports @A@ should be recompiled in case they use -@B.f@ (they'll get an early exit if they don't). So, if anything -about @B.f@ changes we'd better make sure that something in A.hi -changes, and the convenient way to do that is to record the version -number @B.f@ in A.hi in the usage list. If B.f changes that'll force a -complete recompiation of A, which is overkill but it's the only way to -write a new, slightly different, A.hi. - -But the example is tricker. Even if @B.f@ doesn't change at all, -@B.h@ may do so, and this change may not be reflected in @f@'s version -number. But with -O, a module that imports A must be recompiled if -@B.h@ changes! So A must record a dependency on @B.h@. So we treat -the occurrence of @B.f@ in the export list *just as if* it were in the -code of A, and thereby haul in all the stuff reachable from it. - -[NB: If B was compiled with -O, but A isn't, we should really *still* -haul in all the unfoldings for B, in case the module that imports A *is* -compiled with -O. I think this is the case.] - -Even if B is used at all we get a usage line for B - import B :: ... ; -in A.hi, to record the fact that A does import B. This is used to decide +things it uses. + +We produce a line for every module B below the module, A, currently being +compiled: + import B ; +to record the fact that A does import B indireclty. This is used to decide to look to look for B.hi rather than B.hi-boot when compiling a module that imports A. This line says that A imports B, but uses nothing in it. So we'll get an early bale-out when compiling A if B's version changes. @@ -227,93 +106,99 @@ mkImportInfo this_mod imports = getIfacesRn `thenRn` \ ifaces -> getHomeIfaceTableRn `thenRn` \ hit -> let + (imp_pkg_mods, imp_home_names) = iVSlurp ifaces + pit = iPIT ifaces + import_all_mods :: [ModuleName] -- Modules where we imported all the names -- (apart from hiding some, perhaps) - import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports, - import_all imp_list ] + import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports, + import_all imp_list ] + where + import_all (Just (False, _)) = False -- Imports are specified explicitly + import_all other = True -- Everything is imported + + -- mv_map groups together all the things imported and used + -- from a particular module in this package + -- We use a finite map because we want the domain + mv_map :: ModuleEnv [Name] + mv_map = foldNameSet add_mv emptyModuleEnv imp_home_names + add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] + where + mod = nameModule name + add_item names _ = name:names + + -- In our usage list we record + -- a) Specifically: Detailed version info for imports from modules in this package + -- Gotten from iVSlurp plus import_all_mods + -- + -- b) Everything: Just the module version for imports from modules in other packages + -- Gotten from iVSlurp plus import_all_mods + -- + -- c) NothingAtAll: The name only of modules, Baz, in this package that are 'below' us, + -- but which we didn't need at all (this is needed only to decide whether + -- to open Baz.hi or Baz.hi-boot higher up the tree). + -- This happens when a module, Foo, that we explicitly imported has + -- 'import Baz' in its interface file, recording that Baz is below + -- Foo in the module dependency hierarchy. We want to propagate this info. + -- These modules are in a combination of HIT/PIT and iImpModInfo + -- + -- d) NothingAtAll: The name only of all orphan modules we know of (this is needed + -- so that anyone who imports us can find the orphan modules) + -- These modules are in a combination of HIT/PIT and iImpModInfo + + import_info0 = foldModuleEnv mk_imp_info [] pit + import_info1 = foldModuleEnv mk_imp_info import_info0 hit + import_info = [ (mod_name, orphans, is_boot, NothingAtAll) + | (mod_name, (orphans, is_boot)) <- fmToList (iImpModInfo ifaces) ] ++ + import_info1 + + mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name] + mk_imp_info iface so_far - import_all (Just (False, _)) = False -- Imports are specified explicitly - import_all other = True -- Everything is imported + | Just ns <- lookupModuleEnv mv_map mod -- Case (a) + = go_for_it (Specifically mod_vers maybe_export_vers + (mk_import_items ns) rules_vers) - mod_map = iImpModInfo ifaces - imp_names = iVSlurp ifaces - pit = iPIT ifaces + | mod `elemModuleSet` imp_pkg_mods -- Case (b) + = go_for_it (Everything mod_vers) - -- mv_map groups together all the things imported from a particular module. - mv_map :: ModuleEnv [Name] - mv_map = foldr add_mv emptyModuleEnv imp_names - - add_mv name mv_map = addItem mv_map (nameModule name) name - - -- Build the result list by adding info for each module. - -- For (a) a library module, we don't record it at all unless it contains orphans - -- (We must never lose track of orphans.) - -- - -- (b) a home-package module - - mk_imp_info mod_name (has_orphans, is_boot, opened) so_far - | mod_name == this_mod -- Check if M appears in the set of modules 'below' M - -- This seems like a convenient place to check - = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> - ptext SLIT("imports itself (perhaps indirectly)") ) - so_far - - | not opened -- We didn't even open the interface - = -- This happens when a module, Foo, that we explicitly imported has - -- 'import Baz' in its interface file, recording that Baz is below - -- Foo in the module dependency hierarchy. We want to propagate this - -- information. The Nothing says that we didn't even open the interface - -- file but we must still propagate the dependency info. - -- The module in question must be a local module (in the same package) - go_for_it NothingAtAll - - - | is_lib_module - -- Ignore modules from other packages, unless it has - -- orphans, in which case we must remember it in our - -- dependencies. But in that case we only record the - -- module version, nothing more detailed - = if has_orphans then - go_for_it (Everything module_vers) - else - so_far - - | otherwise - = go_for_it whats_imported - - where - go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far - mod_iface = lookupTableByModName hit pit mod_name `orElse` panic "mkImportInfo" - mod = mi_module mod_iface - is_lib_module = not (isModuleInThisPackage mod) - version_info = mi_version mod_iface - version_env = vers_decls version_info - module_vers = vers_module version_info - - whats_imported = Specifically module_vers - export_vers import_items - (vers_rules version_info) - - import_items = [(n,v) | n <- lookupWithDefaultModuleEnv mv_map [] mod, - let v = lookupNameEnv version_env n `orElse` - pprPanic "mk_whats_imported" (ppr n) - ] - export_vers | moduleName mod `elem` import_all_mods - = Just (vers_exports version_info) - | otherwise - = Nothing - - import_info = foldFM mk_imp_info [] mod_map + | import_all_mod -- Case (a) and (b); the import-all part + = if is_home_pkg_mod then + go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers) + else + go_for_it (Everything mod_vers) + + | is_home_pkg_mod || has_orphans -- Case (c) or (d) + = go_for_it NothingAtAll + + | otherwise = so_far + where + go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far + + mod = mi_module iface + mod_name = moduleName mod + is_home_pkg_mod = isModuleInThisPackage mod + version_info = mi_version iface + version_env = vers_decls version_info + mod_vers = vers_module version_info + rules_vers = vers_rules version_info + export_vers = vers_exports version_info + import_all_mod = mod_name `elem` import_all_mods + has_orphans = mi_orphan iface + + -- The sort is to put them into canonical order + mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns, + let v = lookupNameEnv version_env n `orElse` + pprPanic "mk_whats_imported" (ppr n) + ] + where + lt_occ n1 n2 = nameOccName n1 < nameOccName n2 + + maybe_export_vers | import_all_mod = Just (vers_exports version_info) + | otherwise = Nothing in - traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_` returnRn import_info - - -addItem :: ModuleEnv [a] -> Module -> a -> ModuleEnv [a] -addItem fm mod x = extendModuleEnv_C add_item fm mod [x] - where - add_item xs _ = x:xs \end{code} %********************************************************* @@ -332,12 +217,7 @@ slurpImpDecls source_fvs 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 + closeDecls decls needed ------------------------------------------------------- @@ -358,15 +238,6 @@ slurpSourceRefs source_binders source_fvs -- 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) @@ -375,7 +246,7 @@ slurpSourceRefs source_binders source_fvs = 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) -> + rnIfaceInstDecls 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 @@ -384,23 +255,13 @@ slurpSourceRefs source_binders source_fvs 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 + AlreadySlurped -> returnRn (decls, fvs, gates) + InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing) HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> returnRn (TyClD 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} @@ -416,8 +277,13 @@ closeDecls decls needed = 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 + other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' -> + let + rule_fvs = plusFVs (map ruleDeclFVs rule_decls') + in + traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs))) `thenRn_` + closeDecls (map RuleD rule_decls' ++ decls) rule_fvs + ------------------------------------------------------- @@ -443,14 +309,15 @@ slurpDecl decls fvs wanted_name ------------------------------------------------------- -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) +rnIfaceDecls rn decls = mapRn (rnIfaceDecl rn) decls +rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl) + +rnIfaceInstDecls decls fvs gates inst_decls + = rnIfaceDecls rnInstDecl inst_decls `thenRn` \ inst_decls' -> + returnRn (map InstD inst_decls' ++ decls, + fvs `plusFV` plusFVs (map instDeclFVs inst_decls'), + gates `plusFV` plusFVs (map getInstDeclGates inst_decls')) + rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' -> returnRn (decl', tyClDeclFVs decl') \end{code} @@ -461,13 +328,21 @@ getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) +recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), + iSlurp = slurped_names, + iVSlurp = (imp_mods, imp_names) }) avail - = let - new_slurped_names = addAvailToNameSet slurped_names avail - new_imp_names = availName avail : imp_names - in - ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names } + = ASSERT2( not (isLocalName (availName avail)), ppr avail ) + ifaces { iDecls = (decls_map', n_slurped+1), + iSlurp = new_slurped_names, + iVSlurp = new_vslurp } + where + decls_map' = foldl delFromNameEnv decls_map (availNames avail) + main_name = availName avail + mod = nameModule main_name + new_slurped_names = addAvailToNameSet slurped_names avail + new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name) + | otherwise = (extendModuleSet imp_mods mod, imp_names) recordLocalSlurps local_avails = getIfacesRn `thenRn` \ ifaces -> @@ -481,84 +356,89 @@ recordLocalSlurps local_avails %********************************************************* %* * -\subsection{Deferred declarations} +\subsection{Extracting the `gates'} %* * %********************************************************* -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. +The gating story +~~~~~~~~~~~~~~~~~ +We want to avoid sucking in too many instance declarations. +An instance decl is only useful if the types and classes mentioned in +its 'head' are all available in the program being compiled. E.g. -\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} + instance (..) => C (T1 a) (T2 b) where ... +is only useful if C, T1 and T2 are all "available". So we keep +instance decls that have been parsed from .hi files, but not yet +slurped in, in a pool called the 'gated instance pool'. +Each has its set of 'gates': {C, T1, T2} in the above example. -%********************************************************* -%* * -\subsection{Extracting the `gates'} -%* * -%********************************************************* +More precisely, the gates of a module are the types and classes +that are mentioned in: + a) the source code + b) the type of an Id that's mentioned in the source code + [includes constructors and selectors] + c) the RHS of a type synonym that is a gate + d) the superclasses of a class that is a gate + e) the context of an instance decl that is slurped in + +We slurp in an instance decl from the gated instance pool iff + + all its gates are either in the gates of the module, + or are a previously-loaded class. + +The latter constraint is because there might have been an instance +decl slurped in during an earlier compilation, like this: + + instance Foo a => Baz (Maybe a) where ... + +In the module being compiled we might need (Baz (Maybe T)), where T +is defined in this module, and hence we need (Foo T). So @Foo@ becomes +a gate. But there's no way to 'see' that, so we simply treat all +previously-loaded classes as gates. + +Consructors and class operations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. +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. + +And that's just what (b) says: we only treat T1's type as a gate if +T1 is mentioned. getGates, which deals with decls we are slurping in, +has to be a bit careful, because a mention of T1 will slurp in T's whole +declaration. + +----------------------------- @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 (IfaceSig _ ty _ _) +getGates :: FreeVars -- Things mentioned in the source program + -> RenamedTyClDecl + -> FreeVars + +getGates source_fvs decl + = get_gates (\n -> n `elemNameSet` source_fvs) decl + +get_gates is_used (IfaceSig _ ty _ _) = extractHsTyNames ty -getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ ) +get_gates is_used (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 + | is_used n = extractHsTyNames ty + | otherwise = emptyFVs -- If we load any numeric class that doesn't have -- Int as an instance, add Double to the gates. @@ -570,18 +450,17 @@ getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ ) | otherwise = emptyFVs -getGates source_fvs (TySynonym tycon tvs ty _) - = delListFromNameSet (extractHsTyNames ty) - (hsTyVarNames tvs) +get_gates is_used (TySynonym tycon tvs ty _) + = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) +get_gates is_used (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 + | is_used n -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) @@ -599,35 +478,113 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) 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_field (fs,t) | any is_used fs = get_bang t + | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) \end{code} -@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ -rather than a declaration. +@getWiredInGates@ is just like @getGates@, but it sees a previously-loaded +thing 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 :: TyThing -> FreeVars +-- The TyThing is one that we already have in our type environment, either +-- a) because the TyCon or Id is wired in, or +-- b) from a previous compile +-- Either way, we might have instance decls in the (persistent) collection +-- of parsed-but-not-slurped instance decls that should be slurped in. +-- This might be the first module that mentions both the type and the class +-- for that instance decl, even though both the type and the class were +-- mentioned in other modules, and hence are in the type environment + +getWiredInGates (AnId the_id) = namesOfType (idType the_id) +getWiredInGates (AClass cl) = emptyFVs -- The superclasses must also be previously + -- loaded, and hence are automatically gates +getWiredInGates (ATyCon tc) + | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars) + | otherwise = unitFV (getName tc) + where + (tyvars,ty) = getSynTyConDefn tc -getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) +getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty \end{code} \begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs +getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)] +getImportedInstDecls gates + = -- First, load any orphan-instance modules that aren't aready loaded + -- Orphan-instance modules are recorded in the module dependecnies + getIfacesRn `thenRn` \ ifaces -> + let + orphan_mods = + [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)] + in + loadOrphanModules orphan_mods `thenRn_` + + -- Now we're ready to grab the instance declarations + -- Find the un-gated ones and return them, + -- removing them from the bag kept in Ifaces + getIfacesRn `thenRn` \ ifaces -> + getTypeEnvRn `thenRn` \ lookup -> + let + (decls, new_insts) = selectGated gates lookup (iInsts ifaces) + in + setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` + + traceRn (sep [text "getImportedInstDecls:", + nest 4 (fsep (map ppr gate_list)), + text "Slurped" <+> int (length decls) <+> text "instance declarations", + nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` + returnRn decls + where + gate_list = nameSetToList gates + +ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) + = case inst_ty of + HsForAllTy _ _ tau -> ppr tau + other -> ppr inst_ty + +getImportedRules :: RnMG [(Module,RdrNameRuleDecl)] +getImportedRules + | opt_IgnoreIfacePragmas = returnRn [] + | otherwise + = getIfacesRn `thenRn` \ ifaces -> + getTypeEnvRn `thenRn` \ lookup -> + let + gates = iSlurp ifaces -- Anything at all that's been slurped + rules = iRules ifaces + (decls, new_rules) = selectGated gates lookup rules + in + if null decls then + returnRn [] + else + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + traceRn (sep [text "getImportedRules:", + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + returnRn decls + +selectGated gates lookup (decl_bag, n_slurped) + -- Select only those decls whose gates are *all* in 'gates' + -- or are a class in 'lookup' +#ifdef DEBUG + | opt_NoPruneDecls -- Just to try the effect of not gating at all + = let + decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag -- Grab them all + in + (decls, (emptyBag, n_slurped + length decls)) + + | otherwise +#endif + = case foldrBag select ([], emptyBag) decl_bag of + (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls)) + where + available n = n `elemNameSet` gates + || case lookup n of { Just (AClass c) -> True; other -> False } + + select (reqd, decl) (yes, no) + | all available reqd = (decl:yes, no) + | otherwise = (yes, (reqd,decl) `consBag` no) \end{code} @@ -642,132 +599,61 @@ importDecl :: Name -> RnMG ImportDeclResult data ImportDeclResult = AlreadySlurped - | WiredIn - | Deferred + | InTypeEnv TyThing | HereItIs (Module, RdrNameTyClDecl) importDecl name - = -- Check if it was loaded before beginning this module - if isLocallyDefined name then - returnRn AlreadySlurped - else - checkAlreadyAvailable name `thenRn` \ done -> - if done then + = -- STEP 1: Check if it was loaded before beginning this module + if isLocalName name then + traceRn (text "Already (local)" <+> ppr name) `thenRn_` returnRn AlreadySlurped else - -- Check if we slurped it in while compiling this module + -- STEP 2: Check if we've slurped it in while compiling this module getIfacesRn `thenRn` \ ifaces -> if name `elemNameSet` iSlurp ifaces then returnRn AlreadySlurped - else - - -- Don't slurp in decls from this module's own interface file - -- (Indeed, this shouldn't happen.) - if isLocallyDefined name then - addWarnRn (importDeclWarn name) `thenRn_` - returnRn AlreadySlurped else - -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - if name `elemNameEnv` wiredInThingEnv then - loadHomeInterface doc name `thenRn_` - returnRn WiredIn - - else getNonWiredInDecl name - where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name - -getNonWiredInDecl :: Name -> RnMG ImportDeclResult -getNonWiredInDecl needed_name - = traceRn doc_str `thenRn_` - loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> - case lookupNameEnv (iDecls ifaces) needed_name of - -{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS - Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _))) - -- This case deals with deferred import of algebraic data types + -- STEP 3: Check if it's already in the type environment + getTypeEnvRn `thenRn` \ lookup -> + case lookup name of { + Just ty_thing | name `elemNameEnv` wiredInThingEnv + -> -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + loadHomeInterface wi_doc name `thenRn_` + returnRn (InTypeEnv ty_thing) - | not opt_NoPruneTyDecls + | otherwise + -> returnRn (InTypeEnv ty_thing) ; - && (opt_IgnoreIfacePragmas || ncons > 1) - -- We only defer if imported interface pragmas are ingored - -- or if it's not a product type. - -- Sole reason: The wrapper for a strict function may need to look - -- inside its arg, and hence need to see its arg type's constructors. - - && not (getUnique tycon_name `elem` cCallishTyKeys) - -- Never defer ccall types; we have to unbox them, - -- and importing them does no harm - - - -> -- OK, so we're importing a deferrable data type - if needed_name == tycon_name - -- The needed_name is the TyCon of a data type decl - -- Record that it's slurped, put it in the deferred set - -- and don't return a declaration at all - setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces - `addOneToNameSet` tycon_name}) - version (AvailTC needed_name [needed_name])) `thenRn_` - returnRn Deferred + Nothing -> - else - -- The needed name is a constructor of a data type decl, - -- getting a constructor, so remove the TyCon from the deferred set - -- (if it's there) and return the full declaration - setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces - `delFromNameSet` tycon_name}) - version avail) `thenRn_` - returnRn (HereItIs decl) - where - tycon_name = availName avail --} + -- STEP 4: OK, we have to slurp it in from an interface file + -- First load the interface file + traceRn nd_doc `thenRn_` + loadHomeInterface nd_doc name `thenRn_` + getIfacesRn `thenRn` \ ifaces -> + -- STEP 5: Get the declaration out + let + (decls_map, _) = iDecls ifaces + in + case lookupNameEnv decls_map name of Just (avail,_,decl) -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` returnRn (HereItIs decl) Nothing - -> addErrRn (getDeclErr needed_name) `thenRn_` + -> addErrRn (getDeclErr name) `thenRn_` returnRn AlreadySlurped + } where - doc_str = ptext SLIT("need decl for") <+> ppr needed_name + wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name + nd_doc = ptext SLIT("need decl for") <+> ppr name -{- OMIT FOR NOW -getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] -getDeferredDecls - = getIfacesRn `thenRn` \ ifaces -> - let - decls_map = iDecls ifaces - deferred_names = nameSetToList (iDeferred ifaces) - get_abstract_decl n = case lookupNameEnv decls_map n of - Just (_, _, _, decl) -> decl - in - traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` - returnRn (map get_abstract_decl deferred_names) --} \end{code} -@getWiredInDecl@ maps a wired-in @Name@ to what it makes available. -It behaves exactly as if the wired in decl were actually in an interface file. -Specifically, -\begin{itemize} -\item if the wired-in name is a data type constructor or a data constructor, - it brings in the type constructor and all the data constructors; and - marks as ``occurrences'' any free vars of the data con. - -\item similarly for synonum type constructor - -\item if the wired-in name is another wired-in Id, it marks as ``occurrences'' - the free vars of the Id's type. - -\item it loads the interface file for the wired-in thing for the - sole purpose of making sure that its instance declarations are available -\end{itemize} -All this is necessary so that we know all types that are ``in play'', so -that we know just what instances to bring into scope. - %******************************************************** %* * @@ -785,26 +671,21 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: Module +recompileRequired :: FilePath -- Only needed for debug msgs -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface, if any + -> ModIface -- Old interface -> RnMG RecompileRequired -recompileRequired mod source_unchanged maybe_iface - = traceRn (text "Considering whether compilation is required for" <+> ppr mod <> colon) `thenRn_` +recompileRequired iface_path source_unchanged iface + = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_` -- CHECK WHETHER THE SOURCE HAS CHANGED if not source_unchanged then - traceRn (nest 4 (text "Source file changed or recompilation check turned off")) `thenRn_` + traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off")) `thenRn_` returnRn outOfDate else - -- CHECK WHETHER WE HAVE AN OLD IFACE - case maybe_iface of - Nothing -> traceRn (nest 4 (ptext SLIT("No old interface file"))) `thenRn_` - returnRn outOfDate ; - - Just iface -> -- Source code unchanged and no errors yet... carry on - checkList [checkModUsage u | u <- mi_usages iface] + -- Source code unchanged and no errors yet... carry on + checkList [checkModUsage u | u <- mi_usages iface] checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired checkList [] = returnRn upToDate @@ -830,7 +711,7 @@ checkModUsage (mod_name, _, _, NothingAtAll) = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name) checkModUsage (mod_name, _, _, whats_imported) - = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> + = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (iface, maybe_err) -> case maybe_err of { Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), ppr mod_name]) ; @@ -839,12 +720,8 @@ checkModUsage (mod_name, _, _, whats_imported) -- the current module doesn't need that import and it's been deleted Nothing -> - - getHomeIfaceTableRn `thenRn` \ hit -> let - mod_details = lookupTableByModName hit (iPIT ifaces) mod_name - `orElse` panic "checkModUsage" - new_vers = mi_version mod_details + new_vers = mi_version iface new_decl_vers = vers_decls new_vers in case whats_imported of { -- NothingAtAll dealt with earlier @@ -907,8 +784,8 @@ checkEntityUsage new_vers (name,old_vers) | new_vers == old_vers -> returnRn upToDate | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) -up_to_date msg = traceRn msg `thenRn_` returnRn upToDate -out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate +up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate +out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate \end{code} @@ -923,12 +800,4 @@ getDeclErr name = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), ptext SLIT("from module") <+> quotes (ppr (nameModule name)) ] - -importDeclWarn name - = sep [ptext SLIT( - "Compiler tried to import decl from interface file with same name as module."), - ptext SLIT( - "(possible cause: module name clashes with interface file already in scope.)") - ] $$ - hsep [ptext SLIT("name:"), quotes (ppr name)] \end{code}