%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[RnIfaces]{Cacheing and Renaming of Interfaces}
+section
+\%[RnIfaces]{Cacheing and Renaming of Interfaces}
\begin{code}
module RnIfaces
- (
- getInterfaceExports,
- recordLocalSlurps,
- mkImportInfo,
-
- slurpImpDecls, closeDecls,
-
- RecompileRequired, outOfDate, upToDate, recompileRequired
+ ( slurpImpDecls, importSupportingDecls,
+ RecompileRequired, outOfDate, upToDate, checkVersions
)
where
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
import HscTypes
-import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
+import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..),
InstDecl(..), HsType(..), hsTyVarNames, getBangType
)
-import HsImpExp ( ImportDecl(..) )
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl,
extractHsTyNames, extractHsCtxtTyNames,
- tyClDeclFVs, ruleDeclFVs, instDeclFVs
- )
-import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
- loadOrphanModules
+ tyClDeclFVs, ruleDeclFVs, impDeclFVs
)
+import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules )
+import RnNames ( mkModDeps )
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, isLocalName, nameUnique,
- NamedThing(..)
- )
-import Name ( elemNameEnv, delFromNameEnv )
-import Module ( Module, ModuleEnv,
- moduleName, isModuleInThisPackage,
- ModuleName, WhereFrom(..),
- emptyModuleEnv,
- extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
- elemModuleSet, extendModuleSet
- )
+import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe )
+import TcRnMonad
+import Id ( idType, idName, globalIdDetails )
+import IdInfo ( GlobalIdDetails(..) )
+import TcType ( tyClsNamesOfType, classNamesOfTheta )
+import FieldLabel ( fieldLabelTyCon )
+import DataCon ( dataConTyCon, dataConWrapId )
+import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
+import Class ( className, classSCTheta )
+import Name ( Name {-instance NamedThing-}, isWiredInName, nameIsLocalOrFrom,
+ nameModule, NamedThing(..) )
+import NameEnv ( delFromNameEnv, lookupNameEnv )
import NameSet
-import PrelInfo ( wiredInThingEnv, fractionalClassKeys )
-import TysWiredIn ( doubleTyCon )
-import Maybes ( orElse )
-import FiniteMap
+import Module ( Module, isHomeModule )
+import PrelNames ( hasKey, fractionalClassKey, numClassKey,
+ integerTyConName, doubleTyConName )
import Outputable
import Bag
-import Util ( sortLt )
+import Maybe( fromJust )
\end{code}
%*********************************************************
-%* *
-\subsection{Getting what a module exports}
-%* *
-%*********************************************************
-
-@getInterfaceExports@ is called only for directly-imported modules.
-
-\begin{code}
-getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)])
-getInterfaceExports mod_name from
- = loadInterface doc_str mod_name from `thenRn` \ iface ->
- returnRn (mi_module iface, mi_exports iface)
- where
- doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")]
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Keeping track of what we've slurped, and version numbers}
-%* *
-%*********************************************************
-
-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.
-
-We produce a line for every module B below the module, A, currently being
-compiled:
- import B <n> ;
-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.
-
-\begin{code}
-mkImportInfo :: ModuleName -- Name of this module
- -> [ImportDecl n] -- The import decls
- -> RnMG [ImportVersion Name]
-
-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 = [ 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
-
- | Just ns <- lookupModuleEnv mv_map mod -- Case (a)
- = go_for_it (Specifically mod_vers maybe_export_vers
- (mk_import_items ns) rules_vers)
-
- | mod `elemModuleSet` imp_pkg_mods -- Case (b)
- = go_for_it (Everything mod_vers)
-
- | 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
- returnRn import_info
-\end{code}
-
-%*********************************************************
%* *
\subsection{Slurping declarations}
%* *
\begin{code}
-------------------------------------------------------
+slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl]
slurpImpDecls source_fvs
- = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
+ = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_`
- -- The current slurped-set records all local things
- getSlurped `thenRn` \ source_binders ->
- slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
+ -- Slurp in things which might be 'gates' for instance
+ -- declarations, plus the instance declarations themselves
+ slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) ->
-- Then get everything else
- closeDecls decls needed
+ let
+ needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls
+ in
+ import_supporting_decls (gate_decls, bndrs) needed
-------------------------------------------------------
-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
+slurpSourceRefs :: FreeVars -- Variables referenced in source
+ -> TcRn m ([RenamedHsDecl], -- Needed declarations
+ NameSet) -- Names bound by those declarations
+-- Slurp imported declarations needed directly by the source code;
+-- and some of the ones they need. The goal is to find all the 'gates'
+-- for instance declarations.
+
+slurpSourceRefs source_fvs
+ = go_outer [] emptyFVs -- Accumulating decls
(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
-
- 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 ->
- 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
- -- 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 ->
+ -- 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 bndrs [] = returnM (decls, bndrs)
+
+ go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet
+ = traceRn (text "go_outer" <+> ppr refs) `thenM_`
+ foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) ->
+ getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) ->
+ rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' ->
+ go_outer (map InstD inst_decls' ++ decls1)
+ bndrs1
+ (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls')))
+ -- NB: we go round again to fetch the decls for any gates of any decls
+ -- we have loaded. For example, if we mention
+ -- print :: Show a => a -> String
+ -- then we must load the decl for Show before stopping, to ensure
+ -- that instances from its home module are available
+
+ go_inner (decls, bndrs, gates) wanted_name
+ = importDecl bndrs wanted_name `thenM` \ import_result ->
case import_result of
- 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)
+ AlreadySlurped -> returnM (decls, bndrs, gates)
+
+ InTypeEnv ty_thing
+ -> returnM (decls,
+ bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates
+ gates `plusFV` getWiredInGates ty_thing)
+
+ HereItIs decl new_bndrs
+ -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl ->
+ returnM (TyClD new_decl : decls,
+ bndrs `plusFV` new_bndrs,
+ gates `plusFV` getGates source_fvs new_decl)
\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 ->
+-- import_supporting_decls keeps going until the free-var set is empty
+importSupportingDecls needed
+ = import_supporting_decls ([], emptyNameSet) needed
+
+import_supporting_decls
+ :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders
+ -> FreeVars -- Remaining un-slurped names
+ -> TcRn m [RenamedHsDecl]
+import_supporting_decls decls needed
+ = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) ->
+ getImportedRules bndrs1 `thenM` \ rule_decls ->
case rule_decls of
- [] -> returnRn decls -- No new rules, so we are done
- other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' ->
+ [] -> returnM decls1 -- No new rules, so we are done
+ other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' ->
let
- rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
+ rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
+ decls2 = decls1 ++ map RuleD rule_decls'
in
- traceRn (text "closeRules" <+> ppr rule_decls' $$ fsep (map ppr (nameSetToList rule_fvs))) `thenRn_`
- closeDecls (map RuleD rule_decls' ++ decls) rule_fvs
+ traceRn (text "closeRules" <+> ppr rule_decls' $$
+ fsep (map ppr (nameSetToList rule_fvs))) `thenM_`
+ import_supporting_decls (decls2, bndrs1) rule_fvs
-
-------------------------------------------------------
--- 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)
+-- Augment decls with any decls needed by needed,
+-- and so on transitively
+slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped
+ -> FreeVars -- Still needed
+ -> TcRn m ([RenamedHsDecl], NameSet)
+slurpIfaceDecls (decls, bndrs) needed
+ = slurp decls bndrs (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
+ slurp decls bndrs [] = returnM (decls, bndrs)
+ slurp decls bndrs (n:ns)
+ = importDecl bndrs n `thenM` \ import_result ->
+ case import_result of
+ HereItIs decl new_bndrs -- Found a declaration... rename it
+ -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl ->
+ slurp (TyClD new_decl : decls)
+ (bndrs `plusFV` new_bndrs)
+ (nameSetToList (tyClDeclFVs new_decl) ++ ns)
+
+
+ other -> -- No declaration... (wired in thing, or deferred,
+ -- or already slurped)
+ slurp decls (bndrs `addOneFV` n) ns
-------------------------------------------------------
-slurpDecl decls fvs wanted_name
- = importDecl wanted_name `thenRn` \ import_result ->
- case import_result of
- -- Found a declaration... rename it
- HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
+rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls
+rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl)
+\end{code}
- -- No declaration... (wired in thing, or deferred, or already slurped)
- other -> returnRn (decls, fvs)
+\begin{code}
+ -- Tiresomely, we must get the "main" name for the
+ -- thing, because that's what VSlurp contains, and what
+ -- is recorded in the usage information
+get_main_name (AClass cl) = className cl
+get_main_name (ADataCon dc) = tyConName (dataConTyCon dc)
+get_main_name (ATyCon tc)
+ | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
+ | otherwise = tyConName tc
+get_main_name (AnId id)
+ = case globalIdDetails id of
+ DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl))
+ GenericOpId tc -> get_main_name (ATyCon tc)
+ ClassOpId cl -> className cl
+ other -> idName id
+
+
+recordUsage :: Name -> TcRn m ()
+-- Record that the Name has been used, for
+-- later generation of usage info in the interface file
+recordUsage name = updUsages (upd_usg name)
+
+upd_usg name usages
+ | isHomeModule mod = addOneToNameSet usages name
+ | otherwise = usages
+ where
+ mod = nameModule name
+\end{code}
--------------------------------------------------------
-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'))
+%*********************************************************
+%* *
+\subsection{Getting in a declaration}
+%* *
+%*********************************************************
-rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' ->
- returnRn (decl', tyClDeclFVs decl')
-\end{code}
+\begin{code}
+importDecl :: NameSet -> Name -> TcRn m ImportDeclResult
+data ImportDeclResult
+ = AlreadySlurped
+ | InTypeEnv TyThing
+ | HereItIs (Module, RdrNameTyClDecl) NameSet
+ -- The NameSet is the bunch of names bound by this decl
+
+importDecl already_slurped name
+ = -- STEP 0: Check if it's from this module
+ -- Doing this catches a common case quickly
+ getModule `thenM` \ this_mod ->
+ if nameIsLocalOrFrom this_mod name then
+ -- Variables defined on the GHCi command line (e.g. let x = 3)
+ -- are Internal names (which don't have a Module)
+ returnM AlreadySlurped
+ else
-\begin{code}
-getSlurped
- = getIfacesRn `thenRn` \ ifaces ->
- returnRn (iSlurp ifaces)
-
-recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
- iSlurp = slurped_names,
- iVSlurp = (imp_mods, imp_names) })
- avail
- = 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 ->
+ -- STEP 1: Check if we've slurped it in while compiling this module
+ if name `elemNameSet` already_slurped then
+ returnM AlreadySlurped
+ else
+
+ -- STEP 2: Check if it's already in the type environment
+ tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
+ case maybe_thing of {
+
+ Just ty_thing
+ | isWiredInName name
+ -> -- 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 `thenM_`
+ returnM (InTypeEnv ty_thing)
+
+ | otherwise
+ -> -- We have slurp something that's already in the type environment,
+ -- that was not slurped in an earlier compilation.
+ -- Must still record it in the Usages info, because that's used to
+ -- generate usage information
+
+ traceRn (text "not wired in" <+> ppr name) `thenM_`
+ recordUsage (get_main_name ty_thing) `thenM_`
+ returnM (InTypeEnv ty_thing) ;
+
+ Nothing ->
+
+ -- STEP 4: OK, we have to slurp it in from an interface file
+ -- First load the interface file
+ traceRn nd_doc `thenM_`
+ loadHomeInterface nd_doc name `thenM_`
+
+ -- STEP 4: Get the declaration out
+ getEps `thenM` \ eps ->
let
- new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails
+ (decls_map, n_slurped) = eps_decls eps
in
- setIfacesRn (ifaces { iSlurp = new_slurped_names })
-\end{code}
+ case lookupNameEnv decls_map name of
+ Just (avail,_,decl) -> setEps eps' `thenM_`
+ recordUsage (availName avail) `thenM_`
+ returnM (HereItIs decl (mkFVs avail_names))
+ where
+ avail_names = availNames avail
+ new_decls_map = foldl delFromNameEnv decls_map avail_names
+ eps' = eps { eps_decls = (new_decls_map, n_slurped+1) }
+
+ Nothing -> addErr (getDeclErr name) `thenM_`
+ returnM AlreadySlurped
+ }
+ where
+ wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+ nd_doc = ptext SLIT("need decl for") <+> ppr name
+\end{code}
%*********************************************************
More precisely, the gates of a module are the types and classes
that are mentioned in:
- a) the source code
+ a) the source code [Note: in fact these don't seem
+ to be treated as gates, perhaps
+ because no imported instance decl
+ can mention them; mutter mutter
+ recursive modules.]
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
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.
+ all its gates are either in the gates of the module,
+ or the gates of a previously-loaded module
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.
+In the module being compiled we might need (Baz (Maybe T)), where T is
+defined in this module, and hence we need the instance for (Foo T).
+So @Foo@ becomes a gate. But there's no way to 'see' that. More
+generally, types might be involved as well:
+
+ instance Foo2 S a => Baz2 a where ...
+
+Now we must treat S as a gate too, as well as Foo2. So the solution
+we adopt is:
+
+ we simply treat the gates of all previously-loaded
+ modules as gates of this one
+
+So the gates are remembered across invocations of the renamer in the
+PersistentRenamerState. This gloss mainly affects ghc --make and ghc
+--interactive.
+
+(We used to use the persistent type environment for this purpose,
+but it has too much. For a start, it contains all tuple types,
+because they are in the wired-in type env!)
+
Consructors and class operations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
getGates :: FreeVars -- Things mentioned in the source program
+ -- Used for the cunning "constructors and
+ -- class ops" story described 10 lines above.
-> RenamedTyClDecl
-> FreeVars
getGates source_fvs decl
= get_gates (\n -> n `elemNameSet` source_fvs) decl
-get_gates is_used (IfaceSig _ ty _ _)
- = extractHsTyNames ty
+get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
+get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
-get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
- = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
- (hsTyVarNames tvs)
- `addOneToNameSet` cls)
- `plusFV` maybe_double
+get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
+ = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
+ implicitClassGates cls
where
+ super_cls_and_sigs = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
+ (hsTyVarNames tvs)
get (ClassOpSig n _ ty _)
| 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.
- -- 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
-
-get_gates is_used (TySynonym tycon tvs ty _)
+get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
= delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
- = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
+get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})
+ = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt)
+ (visibleDataCons cons))
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
- get (ConDecl n _ tvs ctxt details _)
+ get (ConDecl n tvs ctxt details _)
| is_used n
-- 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) _)
+ 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
get other_con = emptyFVs
- get_details (VanillaCon tys) = plusFVs (map get_bang tys)
+ get_details (PrefixCon 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 is_used fs = get_bang t
- | otherwise = emptyFVs
+ get_field (f,t) | is_used f = get_bang t
+ | otherwise = emptyFVs
get_bang bty = extractHsTyNames (getBangType bty)
+
+implicitClassGates :: Name -> FreeVars
+implicitClassGates cls
+ -- If we load class Num, add Integer to the free gates
+ -- This takes account of the fact that Integer might be needed for
+ -- defaulting, but we don't want to load Integer (and all its baggage)
+ -- if there's no numeric stuff needed.
+ -- Similarly for class Fractional and Double
+ --
+ -- NB: adding T to the gates will force T to be loaded
+ --
+ -- NB: If we load (say) Floating, we'll end up loading Fractional too,
+ -- since Fractional is a superclass of Floating
+ | cls `hasKey` numClassKey = unitFV integerTyConName
+ | cls `hasKey` fractionalClassKey = unitFV doubleTyConName
+ | otherwise = emptyFVs
\end{code}
@getWiredInGates@ is just like @getGates@, but it sees a previously-loaded
-- 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 (AClass cl)
+ = unitFV (getName cl) `plusFV` mkFVs super_classes
+ where
+ super_classes = classNamesOfTheta (classSCTheta cl)
+
+getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id)
+getWiredInGates (ADataCon dc) = tyClsNamesOfType (idType (dataConWrapId dc))
+ -- Should include classes in the 'stupid context' of the data con?
getWiredInGates (ATyCon tc)
- | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars)
+ | isSynTyCon tc = tyClsNamesOfType ty
| otherwise = unitFV (getName tc)
where
- (tyvars,ty) = getSynTyConDefn tc
+ (_,ty) = getSynTyConDefn tc
getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty
\end{code}
\begin{code}
-getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)]
+getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet)
+ -- Returns the gates that are new since last time
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 ->
+ getImports `thenM` \ imports ->
+ getEps `thenM` \ eps ->
let
- orphan_mods =
- [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
+ old_gates = eps_inst_gates eps
+ new_gates = gates `minusNameSet` old_gates
+ all_gates = new_gates `unionNameSets` old_gates
+ orphan_mods = imp_orphs imports
in
- loadOrphanModules orphan_mods `thenRn_`
+ loadOrphanModules orphan_mods `thenM_`
-- 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 ->
+ -- removing them from the bag kept in EPS
+ -- Don't foget to get the EPS a second time...
+ -- loadOrphanModules may have side-effected it!
+ getEps `thenM` \ eps ->
let
- (decls, new_insts) = selectGated gates lookup (iInsts ifaces)
+ available n = n `elemNameSet` all_gates
+ (decls, new_insts) = selectGated available (eps_insts eps)
in
- setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
+ setEps (eps { eps_insts = new_insts,
+ eps_inst_gates = all_gates }) `thenM_`
traceRn (sep [text "getImportedInstDecls:",
- nest 4 (fsep (map ppr gate_list)),
+ nest 4 (fsep (map ppr (nameSetToList gates))),
+ nest 4 (fsep (map ppr (nameSetToList all_gates))),
+ nest 4 (fsep (map ppr (nameSetToList new_gates))),
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
+ nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_`
+ returnM (decls, new_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 []
+getImportedRules :: NameSet -- Slurped already
+ -> TcRn m [(Module,RdrNameRuleDecl)]
+getImportedRules slurped
+ | opt_IgnoreIfacePragmas = returnM []
| 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
+ = getEps `thenM` \ eps ->
+ getInGlobalScope `thenM` \ in_type_env ->
+ let -- Slurp rules for anything that is slurped,
+ -- either now, or previously
+ available n = n `elemNameSet` slurped || in_type_env n
+ (decls, new_rules) = selectGated available (eps_rules eps)
in
if null decls then
- returnRn []
+ returnM []
else
- setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
+ setEps (eps { eps_rules = new_rules }) `thenM_`
traceRn (sep [text "getImportedRules:",
- text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
- returnRn decls
+ text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_`
+ returnM decls
-selectGated gates lookup (decl_bag, n_slurped)
- -- Select only those decls whose gates are *all* in 'gates'
- -- or are a class in 'lookup'
+selectGated :: (Name->Bool) -> GatedDecls d
+ -> ([(Module,d)], GatedDecls d)
+selectGated available (decl_bag, n_slurped)
+ -- Select only those decls whose gates are *all* available
#ifdef DEBUG
| opt_NoPruneDecls -- Just to try the effect of not gating at all
= let
= 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}
-
-
-%*********************************************************
-%* *
-\subsection{Getting in a declaration}
-%* *
-%*********************************************************
-
-\begin{code}
-importDecl :: Name -> RnMG ImportDeclResult
-
-data ImportDeclResult
- = AlreadySlurped
- | InTypeEnv TyThing
- | HereItIs (Module, RdrNameTyClDecl)
-
-importDecl name
- = -- 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
-
- -- 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
-
- -- 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)
-
- | otherwise
- -> returnRn (InTypeEnv ty_thing) ;
-
- Nothing ->
-
- -- 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 name) `thenRn_`
- returnRn AlreadySlurped
- }
- where
- wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
- nd_doc = ptext SLIT("need decl for") <+> ppr name
-
+ select (gate_fn, decl) (yes, no)
+ | gate_fn available = (decl:yes, no)
+ | otherwise = (yes, (gate_fn,decl) `consBag` no)
\end{code}
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-recompileRequired :: FilePath -- Only needed for debug msgs
- -> Bool -- Source unchanged
- -> ModIface -- Old interface
- -> RnMG RecompileRequired
-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
- traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off")) `thenRn_`
- returnRn outOfDate
- else
+checkVersions :: Bool -- True <=> source unchanged
+ -> ModIface -- Old interface
+ -> TcRn m RecompileRequired
+checkVersions source_unchanged iface
+ | not source_unchanged
+ = returnM outOfDate
+ | otherwise
+ = traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon) `thenM_`
-- Source code unchanged and no errors yet... carry on
- checkList [checkModUsage u | u <- mi_usages iface]
+ -- First put the dependent-module info in the envt, just temporarily,
+ -- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
+ -- It's just temporary because either the usage check will succeed
+ -- (in which case we are done with this module) or it'll fail (in which
+ -- case we'll compile the module from scratch anyhow).
+ updGblEnv (\ gbl -> gbl { tcg_imports = mod_deps }) (
+ checkList [checkModUsage u | u <- mi_usages iface]
+ )
+
+ where
+ -- This is a bit of a hack really
+ mod_deps = emptyImportAvails { imp_dep_mods = mkModDeps (dep_mods (mi_deps iface)) }
-checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
-checkList [] = returnRn upToDate
-checkList (check:checks) = check `thenRn` \ recompile ->
+checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired
+checkList [] = returnM upToDate
+checkList (check:checks) = check `thenM` \ recompile ->
if recompile then
- returnRn outOfDate
+ returnM outOfDate
else
checkList checks
\end{code}
\begin{code}
-checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
+checkModUsage :: Usage Name -> TcRn m RecompileRequired
-- 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 (mod_name, _, _, NothingAtAll)
- -- 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.
- = up_to_date (ptext SLIT("Nothing used from:") <+> ppr mod_name)
-
-checkModUsage (mod_name, _, is_boot, whats_imported)
+checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
+ usg_rules = old_rule_vers,
+ usg_exports = maybe_old_export_vers,
+ usg_entities = old_decl_vers })
= -- Load the imported interface is possible
- -- We use tryLoadInterface, because failure is not an error
- -- (might just be that the old .hi file for this module is out of date)
- -- We use ImportByUser/ImportByUserSource as the 'from' flag,
- -- a) because we need to know whether to load the .hi-boot file
- -- b) because loadInterface things matters are amiss if we
- -- ImportBySystem an interface it knows nothing about
let
doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
- from | is_boot = ImportByUserSource
- | otherwise = ImportByUser
in
- tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) ->
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
+
+ tryM (loadInterface doc_str mod_name ImportBySystem) `thenM` \ mb_iface ->
- case maybe_err of {
- Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
- ppr mod_name]) ;
+ case mb_iface of {
+ Left exn -> (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 ->
+ Right iface ->
let
- new_vers = mi_version iface
- new_decl_vers = vers_decls new_vers
+ new_vers = mi_version iface
+ new_mod_vers = vers_module new_vers
+ new_decl_vers = vers_decls new_vers
+ new_export_vers = vers_exports new_vers
+ new_rule_vers = vers_rules new_vers
in
- case whats_imported of { -- NothingAtAll dealt with earlier
-
- Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile ->
- if recompile then
- out_of_date (ptext SLIT("...and I needed the whole module"))
- else
- returnRn upToDate ;
-
- Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers ->
-
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile ->
+ checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
if not recompile then
- returnRn upToDate
+ returnM upToDate
else
-- CHECK EXPORT LIST
- if checkExportList maybe_old_export_vers new_vers then
- out_of_date (ptext SLIT("Export list changed"))
+ if checkExportList maybe_old_export_vers new_export_vers then
+ out_of_date_vers (ptext SLIT(" Export list changed"))
+ (fromJust maybe_old_export_vers)
+ new_export_vers
else
-- CHECK RULES
- if old_rule_vers /= vers_rules new_vers then
- out_of_date (ptext SLIT("Rules changed"))
+ if old_rule_vers /= new_rule_vers then
+ out_of_date_vers (ptext SLIT(" Rules changed"))
+ old_rule_vers new_rule_vers
else
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenRn` \ recompile ->
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
if recompile then
- returnRn outOfDate -- This one failed, so just bail out now
+ returnM outOfDate -- This one failed, so just bail out now
else
- up_to_date (ptext SLIT("...but the bits I use haven't."))
+ up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
- }}
+ }
------------------------
-checkModuleVersion old_mod_vers new_vers
- | vers_module new_vers == old_mod_vers
+checkModuleVersion old_mod_vers new_mod_vers
+ | new_mod_vers == old_mod_vers
= up_to_date (ptext SLIT("Module version unchanged"))
| otherwise
- = out_of_date (ptext SLIT("Module version has changed"))
+ = out_of_date_vers (ptext SLIT(" Module version has changed"))
+ old_mod_vers new_mod_vers
------------------------
checkExportList Nothing new_vers = upToDate
-checkExportList (Just v) new_vers = v /= vers_exports new_vers
+checkExportList (Just v) new_vers = v /= new_vers
------------------------
checkEntityUsage new_vers (name,old_vers)
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 -> returnRn upToDate
- | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
-
-up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
-out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate
+ | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
+ returnM upToDate
+ | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
+ old_vers new_vers
+
+up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
+out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+out_of_date_vers msg old_vers new_vers
+ = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
\end{code}
projects / ghc-hetmet.git / blobdiff