, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, lookupModuleEnvByName, extendModuleEnv_C
+ , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
+
) where
#include "HsVersions.h"
import FastString ( FastString, uniqueOfFS )
import Unique ( Uniquable(..), mkUniqueGrimily )
import UniqFM
+import UniqSet
\end{code}
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
\end{code}
+
+\begin{code}
+
+type ModuleSet = UniqSet Module
+mkModuleSet :: [Module] -> ModuleSet
+extendModuleSet :: ModuleSet -> Module -> ModuleSet
+emptyModuleSet :: ModuleSet
+moduleSetElts :: ModuleSet -> [Module]
+elemModuleSet :: Module -> ModuleSet -> Bool
+
+emptyModuleSet = emptyUniqSet
+mkModuleSet = mkUniqSet
+extendModuleSet = addOneToUniqSet
+moduleSetElts = uniqSetToList
+elemModuleSet = elementOfUniqSet
+\end{code}
import Util ( zipWithEqual )
import Name ( Name, lookupNameEnv )
import HscTypes ( HomeSymbolTable, PersistentCompilerState(..),
- TyThing(..), TypeEnv, lookupTypeEnv )
+ TyThing(..), TypeEnv, lookupType )
import CmdLineOpts ( DynFlags )
infixr 9 `thenDs`
-- such as fold, build, cons etc, so the chances are
-- it'll be found in the package symbol table. That's
-- why we don't merge all these tables
- pst = pcs_PST pcs
- lookup n = case lookupTypeEnv pst n of {
- Just (AnId v) -> v ;
- other ->
- case lookupTypeEnv hst n of {
+ pte = pcs_PTE pcs
+ lookup n = case lookupType hst pte n of {
Just (AnId v) -> v ;
other ->
case lookupNameEnv local_type_env n of
Just (AnId v) -> v ;
other -> pprPanic "initDS: lookup:" (ppr n)
- }}
+ }
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
import Rename ( renameModule, checkOldIface, closeIfaceDecls )
import Rules ( emptyRuleBase )
-import PrelInfo ( wiredInThings )
+import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelNames ( knownKeyNames )
import PrelRules ( builtinRules )
import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
-import Module ( ModuleName, moduleName, emptyModuleEnv, mkModuleInThisPackage )
+import Module ( ModuleName, moduleName, mkModuleInThisPackage )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn )
import UniqSupply ( mkSplitUniqSupply )
import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
PersistentRenamerState(..), ModuleLocation(..),
- HomeSymbolTable, PackageSymbolTable,
+ HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
- extendTypeEnv, groupTyThings,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
import InterpSyn ( UnlinkedIBind )
import StgInterp ( ItblEnv )
= do prs <- initPersistentRenamerState
return (
PCS { pcs_PIT = emptyIfaceTable,
- pcs_PST = initPackageDetails,
+ pcs_PTE = wiredInThingEnv,
pcs_insts = emptyInstEnv,
pcs_rules = emptyRuleBase,
pcs_PRS = prs
}
)
-initPackageDetails :: PackageSymbolTable
-initPackageDetails = extendTypeEnv emptyModuleEnv (groupTyThings wiredInThings)
-
---initPackageDetails = panic "initPackageDetails"
-
initPersistentRenamerState :: IO PersistentRenamerState
= do ns <- mkSplitUniqSupply 'r'
return (
module HscTypes (
ModuleLocation(..),
- ModDetails(..), ModIface(..), GlobalSymbolTable,
- HomeSymbolTable, PackageSymbolTable,
+ ModDetails(..), ModIface(..),
+ HomeSymbolTable, PackageTypeEnv,
HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
lookupTable, lookupTableByModName,
+ emptyModIface,
IfaceDecls(..),
VersionInfo(..), initialVersionInfo,
- TyThing(..), groupTyThings, isTyClThing,
+ TyThing(..), isTyClThing,
- TypeEnv, extendTypeEnv, lookupTypeEnv,
+ TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList,
typeEnvClasses, typeEnvTyCons,
WhetherHasOrphans, ImportVersion, WhatsImported(..),
import RdrName ( RdrNameEnv, emptyRdrEnv )
import Name ( Name, NameEnv, NamedThing,
- emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv,
+ emptyNameEnv, extendNameEnv,
lookupNameEnv, emptyNameEnv, getName, nameModule,
nameSrcLoc, nameEnvElts )
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
- extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName
+ lookupModuleEnv, lookupModuleEnvByName
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
import CoreSyn ( IdCoreRule )
import Type ( Type )
-import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
+import FiniteMap ( FiniteMap )
import Bag ( Bag )
import Maybes ( seqMaybe )
import UniqFM ( UniqFM, emptyUFM )
mi_module :: Module, -- Complete with package info
mi_version :: VersionInfo, -- Module version number
mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
+ mi_boot :: IsBootInterface, -- Whether this interface was read from an hi-boot file
mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy
-- to decide whether to write a new iface file
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
+ mi_version = initialVersionInfo,
+ mi_usages = [],
+ mi_orphan = False,
+ mi_boot = False,
mi_exports = [],
+ mi_fixities = emptyNameEnv,
mi_globals = emptyRdrEnv,
- mi_deprecs = NoDeprecs
+ mi_deprecs = NoDeprecs,
+ mi_decls = panic "emptyModIface: decls"
}
\end{code}
type PackageIfaceTable = IfaceTable
type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
-type PackageSymbolTable = SymbolTable -- Domain = modules in the some other package
-type GlobalSymbolTable = SymbolTable -- Domain = all modules
emptyIfaceTable :: IfaceTable
emptyIfaceTable = emptyUFM
%************************************************************************
\begin{code}
-type TypeEnv = NameEnv TyThing
-emptyTypeEnv = emptyNameEnv
-
data TyThing = AnId Id
| ATyCon TyCon
| AClass Class
\begin{code}
-lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
-lookupTypeEnv tbl name
- = case lookupModuleEnv tbl (nameModule name) of
- Just details -> lookupNameEnv (md_types details) name
- Nothing -> Nothing
+type TypeEnv = NameEnv TyThing
+emptyTypeEnv = emptyNameEnv
-groupTyThings :: [TyThing] -> FiniteMap Module TypeEnv
- -- Finite map because we want the range too
-groupTyThings things
- = foldl add emptyFM things
- where
- add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
- add tbl thing = addToFM tbl mod new_env
- where
- name = getName thing
- mod = nameModule name
- new_env = case lookupFM tbl mod of
- Nothing -> unitNameEnv name thing
- Just env -> extendNameEnv env name thing
+mkTypeEnv :: [TyThing] -> TypeEnv
+mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
-extendTypeEnv :: SymbolTable -> FiniteMap Module TypeEnv -> SymbolTable
-extendTypeEnv tbl things
- = foldFM add tbl things
+extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
+extendTypeEnvList env things
+ = foldl add_thing env things
where
- add mod type_env tbl
- = extendModuleEnv tbl mod new_details
- where
- new_details
- = case lookupModuleEnv tbl mod of
- Nothing -> emptyModDetails {md_types = type_env}
- Just details -> details {md_types = md_types details
- `plusNameEnv` type_env}
+ add_thing :: TypeEnv -> TyThing -> TypeEnv
+ add_thing env thing = extendNameEnv env (getName thing) thing
\end{code}
+\begin{code}
+lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing
+lookupType hst pte name
+ = case lookupModuleEnv hst (nameModule name) of
+ Just details -> lookupNameEnv (md_types details) name
+ Nothing -> lookupNameEnv pte name
+\end{code}
%************************************************************************
%* *
pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules
-- the mi_decls component is empty
- pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules
+ pcs_PTE :: PackageTypeEnv, -- Domain = non-home-package modules
-- except that the InstEnv components is empty
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
* A name supply, which deals with allocating unique names to
(Module,OccName) original names,
- * An accumulated InstEnv from all the modules in pcs_PST
+ * An accumulated TypeEnv from all the modules in imported packages
+
+ * An accumulated InstEnv from all the modules in imported packages
The point is that we don't want to keep recreating it whenever
we compile a new module. The InstEnv component of pcPST is empty.
(This means we might "see" instances that we shouldn't "really" see;
interface files but not yet sucked in, renamed, and typechecked
\begin{code}
+type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
import MkId -- All of it, for re-export
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
-import HscTypes ( TyThing(..) )
+import HscTypes ( TyThing(..), TypeEnv, mkTypeEnv )
-- others:
-import Name ( getName, NameEnv, mkNameEnv )
import TyCon ( tyConDataConsIfAvailable, TyCon )
import Class ( Class, classKey )
import Type ( funTyCon )
import Util ( isIn )
-import Outputable ( ppr, pprPanic )
\end{code}
%************************************************************************
n <- [dataConId dc, dataConWrapId dc] ]
-- Synonyms return empty list of constructors
-wiredInThingEnv :: NameEnv TyThing
-wiredInThingEnv = mkNameEnv [ (getName thing, thing) | thing <- wiredInThings ]
+wiredInThingEnv :: TypeEnv
+wiredInThingEnv = mkTypeEnv wiredInThings
\end{code}
We let a lot of "non-standard" values be visible, so that we can make
lookupOrigNames, lookupGlobalRn, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName
+ moduleNameUserString, moduleName, moduleEnvElts
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameModule,
import Type ( funTyCon )
import ErrUtils ( dumpIfSet )
import Bag ( bagToList )
-import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
+import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
import UniqFM ( lookupUFM )
mod_iface = ModIface { mi_module = this_module,
mi_version = initialVersionInfo,
+ mi_boot = False,
mi_orphan = any isOrphanDecl rn_local_decls,
mi_exports = my_exports,
mi_globals = gbl_env,
dcl_insts = new_insts }
mod_iface = ModIface { mi_module = mod, mi_version = version,
- mi_exports = avails, mi_orphan = pi_orphan iface,
+ mi_exports = avails, mi_usages = usages,
+ mi_boot = False, 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"
}
getRnStats imported_decls ifaces
= hcat [text "Renamer stats: ", stats]
where
- n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)]
+ n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)]
+ -- This is really only right for a one-shot compile
decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
-- Data, newtype, and class decls are in the decls_fm
#include "HsVersions.h"
import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import HscTypes
+import HscTypes ( ModuleLocation(..),
+ ModIface(..), emptyModIface,
+ VersionInfo(..),
+ lookupTableByModName,
+ ImportVersion, WhetherHasOrphans, IsBootInterface,
+ DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
+ AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
+ )
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
HsType(..), ConDecl(..),
FixitySig(..), RuleDecl(..),
NamedThing(..),
mkNameEnv, extendNameEnv
)
-import Module ( Module,
+import Module ( Module,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
- extendModuleEnv, lookupModuleEnvByName,
+ extendModuleEnv, mkVanillaModule
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
-import SrcLoc ( mkSrcLoc, SrcLoc )
+import SrcLoc ( mkSrcLoc )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d Ifaces
+loadHomeInterface :: SDoc -> Name -> RnM d ModIface
loadHomeInterface doc_str name
= loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
load mod = loadInterface (mk_doc mod) mod ImportBySystem
mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
-loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d Ifaces
+loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface
loadInterface doc mod from
= tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) ->
case maybe_err of
Nothing -> returnRn ifaces
Just err -> failWithRn ifaces err
-tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
+tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message)
-- Returns (Just err) if an error happened
-- It *doesn't* add an error to the monad, because sometimes it's ok to fail...
-- Specifically, when we read the usage information from an interface file,
-- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
= getHomeIfaceTableRn `thenRn` \ hit ->
- getIfacesRn `thenRn` \ ifaces ->
+ getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
- -- Check whether we have it already in the home package
- case lookupModuleEnvByName hit mod_name of {
- Just _ -> returnRn (ifaces, Nothing) ; -- In the home package
- Nothing ->
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ case lookupTableByModName hit pit mod_name of {
+ Just iface -> returnRn (iface, Nothing) ; -- Already loaded
+ Nothing ->
let
mod_map = iImpModInfo ifaces
hi_boot_file
= case (from, mod_info) of
- (ImportByUser, _) -> False -- Not hi-boot
- (ImportByUserSource, _) -> True -- hi-boot
- (ImportBySystem, Just (_, is_boot, _)) -> is_boot --
- (ImportBySystem, Nothing) -> False
+ (ImportByUser, _) -> False -- Not hi-boot
+ (ImportByUserSource, _) -> True -- hi-boot
+ (ImportBySystem, Just (_, is_boot)) -> is_boot
+ (ImportBySystem, Nothing) -> False
-- We're importing a module we know absolutely
-- nothing about, so we assume it's from
-- another package, where we aren't doing
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,False,_)) -> True
- other -> False
+ (ImportByUserSource, Just (_,False)) -> True
+ other -> False
in
- -- CHECK WHETHER WE HAVE IT ALREADY
- case mod_info of {
- Just (_, _, True)
- -> -- We're read it already so don't re-read it
- returnRn (ifaces, Nothing) ;
-
- _ ->
-- Issue a warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
Left err -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- new_mod_map = addToFM mod_map mod_name (False, False, True)
- new_ifaces = ifaces { iImpModInfo = new_mod_map }
+ fake_mod = mkVanillaModule mod_name
+ fake_iface = emptyModIface fake_mod
+ new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, Just err) ;
+ returnRn (fake_iface, Just err) ;
-- Found and parsed!
Right (mod, iface) ->
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
- -- from its usage info.
+ -- from its usage info; and delete the module itself, which is now in the PIT
mod_map1 = case from of
- ImportByUser -> addModDeps mod (pi_usages iface) mod_map
+ ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map
other -> mod_map
- mod_map2 = addToFM mod_map1 mod_name (has_orphans, hi_boot_file, True)
+ mod_map2 = delFromFM mod_map1 mod_name
+ is_loaded m = maybeToBool (lookupTableByModName hit pit m)
-- Now add info about this module to the PIT
has_orphans = pi_orphan iface
- new_pit = extendModuleEnv (iPIT ifaces) mod mod_iface
+ new_pit = extendModuleEnv pit mod mod_iface
mod_iface = ModIface { mi_module = mod, mi_version = version,
- mi_exports = avails, mi_orphan = has_orphans,
+ mi_orphan = has_orphans, mi_boot = hi_boot_file,
+ mi_exports = avails,
mi_fixities = fix_env, mi_deprecs = deprec_env,
mi_usages = [], -- Will be filled in later
mi_decls = panic "No mi_decls in PIT",
iImpModInfo = mod_map2 }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, Nothing)
- }}}
+ returnRn (mod_iface, Nothing)
+ }}
-----------------------------------------------------
-- Adding module dependencies from the
-- import decls in the interface file
-----------------------------------------------------
-addModDeps :: Module -> [ImportVersion a]
+addModDeps :: Module
+ -> (ModuleName -> Bool) -- True for module interfaces
+ -> [ImportVersion a]
-> ImportedModuleInfo -> ImportedModuleInfo
-- (addModDeps M ivs deps)
-- We are importing module M, and M.hi contains 'import' decls given by ivs
-addModDeps mod new_deps mod_deps
+addModDeps mod is_loaded new_deps mod_deps
= foldr add mod_deps filtered_new_deps
where
-- Don't record dependencies when importing a module from another package
-- Except for its descendents which contain orphans,
-- and in that case, forget about the boot indicator
- filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface, IsLoaded))]
+ filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface))]
filtered_new_deps
| isModuleInThisPackage mod
- = [ (imp_mod, (has_orphans, is_boot, False))
- | (imp_mod, has_orphans, is_boot, _) <- new_deps
+ = [ (imp_mod, (has_orphans, is_boot))
+ | (imp_mod, has_orphans, is_boot, _) <- new_deps,
+ not (is_loaded imp_mod)
]
- | otherwise = [ (imp_mod, (True, False, False))
- | (imp_mod, has_orphans, _, _) <- new_deps,
- has_orphans
+ | otherwise = [ (imp_mod, (True, False))
+ | (imp_mod, has_orphans, _, _) <- new_deps,
+ not (is_loaded imp_mod) && has_orphans
]
add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep
- combine old@(_, old_is_boot, old_is_loaded) new
- | old_is_loaded || not old_is_boot = old -- Keep the old info if it's already loaded
- -- or if it's a non-boot pending load
- | otherwise = new -- Otherwise pick new info
-
+ combine old@(old_has_orphans, old_is_boot) new@(new_has_orphans, new_is_boot)
+ | old_is_boot = new -- Record the best is_boot info
+ | otherwise = old
-----------------------------------------------------
-- Loading the export list
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
= getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupTable hit (iPIT ifaces) name of
- Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- Nothing -> returnRn defaultFixity
+ loadHomeInterface doc name `thenRn` \ iface ->
+ returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
import HscTypes
import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
InstDecl(..), HsType(..), hsTyVarNames, getBangType
NamedThing(..),
elemNameEnv
)
-import Module ( Module, ModuleEnv, mkVanillaModule,
+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 )
import FiniteMap
import Outputable
import Bag
-
-import List ( nub )
+import Util ( sortLt )
\end{code}
\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
+ = 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}
getIfacesRn `thenRn` \ ifaces ->
let
orphan_mods =
- [mod | (mod, (True, _, False)) <- fmToList (iImpModInfo ifaces)]
+ [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
in
loadOrphanModules orphan_mods `thenRn_`
= 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}
%*********************************************************
= getIfacesRn `thenRn` \ ifaces ->
returnRn (iSlurp ifaces)
-recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names })
+recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = (imp_mods, imp_names) })
avail
= let
new_slurped_names = addAvailToNameSet slurped_names avail
- new_imp_names = availName avail : imp_names
+ new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names name)
+ | otherwise = (extendModuleSet imp_mods mod, imp_names)
+ where
+ mod = nameModule name
+ name = availName avail
in
- ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names }
+ ifaces { iSlurp = new_slurped_names, iVSlurp = new_vslurp }
recordLocalSlurps local_avails
= getIfacesRn `thenRn` \ ifaces ->
getNonWiredInDecl :: Name -> RnMG ImportDeclResult
getNonWiredInDecl needed_name
= traceRn doc_str `thenRn_`
- loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
+ loadHomeInterface doc_str needed_name `thenRn_`
+ getIfacesRn `thenRn` \ ifaces ->
case lookupNameEnv (iDecls ifaces) needed_name of
{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
= 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]) ;
-- 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
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
-import HscTypes ( AvailEnv, lookupTypeEnv,
+import HscTypes ( AvailEnv, lookupType,
OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv,
WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), IsBootInterface, Avails,
DeclsMap, IfaceInsts, IfaceRules,
- HomeSymbolTable, PackageSymbolTable,
+ HomeSymbolTable, PackageTypeEnv,
PersistentCompilerState(..), GlobalRdrEnv,
HomeIfaceTable, PackageIfaceTable,
RdrAvailInfo )
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
)
-import Module ( Module, ModuleName )
+import Module ( Module, ModuleName, ModuleSet, emptyModuleSet )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc )
-- All the names (whether "big" or "small", whether wired-in or not,
-- whether locally defined or not) that have been slurped in so far.
- iVSlurp :: [Name]
- -- All the (a) non-wired-in (b) "big" (c) non-locally-defined
+ iVSlurp :: (ModuleSet, NameSet)
+ -- The Names are all the (a) non-wired-in
+ -- (b) "big"
+ -- (c) non-locally-defined
+ -- (d) home-package
-- names that have been slurped in so far, with their versions.
-- This is used to generate the "usage" information for this module.
-- Subset of the previous field.
+ -- The module set is the non-home-package modules from which we have
+ -- slurped at least one name.
-- It's worth keeping separately, because there's no very easy
-- way to distinguish the "big" names from the "non-big" ones.
-- But this is a decision we might want to revisit.
}
-type ImportedModuleInfo = FiniteMap ModuleName
- (WhetherHasOrphans, IsBootInterface, IsLoaded)
-type IsLoaded = Bool
+type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface)
+ -- Contains info ONLY about modules that have not yet
+ --- been loaded into the iPIT
\end{code}
initRn dflags hit hst pcs mod do_rn
= do
let prs = pcs_PRS pcs
- let pst = pcs_PST pcs
+ let pte = pcs_PTE pcs
let ifaces = Ifaces { iPIT = pcs_PIT pcs,
iDecls = prsDecls prs,
iInsts = prsInsts prs,
-- Pretend that the dummy unbound name has already been
-- slurped. This is what's returned for an out-of-scope name,
-- and we don't want thereby to try to suck it in!
- iVSlurp = []
+ iVSlurp = (emptyModuleSet, emptyNameSet)
}
let uniqs = prsNS prs
rn_dflags = dflags,
rn_hit = hit,
- rn_done = is_done hst pst,
+ rn_done = is_done hst pte,
rn_ns = names_var,
rn_errs = errs_var,
return (new_pcs, not (isEmptyBag errs), res)
-is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool
+is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool
-- Returns True iff the name is in either symbol table
-is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n)
+is_done hst pte n = maybeToBool (lookupType hst pte n)
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
= let
-- Getting stuff from the environment
TcEnv, initTcEnv,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
- getTcGST, getTcGEnv,
+ getTcGEnv,
-- Instance environment, and InstInfo type
tcGetInstEnv, tcSetInstEnv,
extendNameEnvList, emptyNameEnv
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
-import HscTypes ( DFunId, TypeEnv )
+import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
import Module ( Module )
import InstEnv ( InstEnv, emptyInstEnv )
-import HscTypes ( lookupTypeEnv, TyThing(..), GlobalSymbolTable )
+import HscTypes ( lookupType, TyThing(..) )
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
import Outputable
data TcEnv
= TcEnv {
- tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
+ tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
tcInsts :: InstEnv, -- All instances (both imported and in this module)
tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
- {- NameEnv TyThing-}-- compiling this module:
+ {- NameEnv TyThing-} -- compiling this module:
-- types and classes (both imported and local)
-- imported Ids
-- (Ids defined in this module are in the local envt)
-- 3. Then we zonk the kind variable.
-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
-initTcEnv :: GlobalSymbolTable -> IO TcEnv
-initTcEnv gst
+initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
+initTcEnv hst pte
= do { gtv_var <- newIORef emptyVarSet ;
- return (TcEnv { tcGST = gst,
+ return (TcEnv { tcGST = lookup,
tcGEnv = emptyNameEnv,
tcInsts = emptyInstEnv,
tcLEnv = emptyNameEnv,
tcTyVars = gtv_var
})}
+ where
+ lookup name = lookupType hst pte name
+
tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)]
tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)]
tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
-getTcGST (TcEnv { tcGST = gst }) = gst
getTcGEnv (TcEnv { tcGEnv = genv }) = genv
-- This data type is used to help tie the knot
lookup_global env name
= case lookupNameEnv (tcGEnv env) name of
Just thing -> Just thing
- Nothing -> lookupTypeEnv (tcGST env) name
+ Nothing -> tcGST env name
lookup_local :: TcEnv -> Name -> Maybe TcTyThing
-- Try the local envt and then try the global
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
-import Module ( Module, plusModuleEnv )
-import Name ( Name, nameOccName, isLocallyDefined, isGlobalName, getName,
- toRdrName, nameEnvElts, lookupNameEnv, mkNameEnv
+import Module ( Module )
+import Name ( Name, nameOccName, isLocallyDefined, isGlobalName,
+ toRdrName, nameEnvElts, lookupNameEnv,
)
import TyCon ( tyConGenInfo, isClassTyCon )
import OccName ( isSysOcc )
import Bag ( isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
- PackageSymbolTable, DFunId, ModIface(..),
- TypeEnv, extendTypeEnv, lookupTable,
- TyThing(..), groupTyThings )
+ PackageTypeEnv, DFunId, ModIface(..),
+ TypeEnv, extendTypeEnvList, lookupTable,
+ TyThing(..), mkTypeEnv )
import List ( partition )
\end{code}
-> IO (Maybe TcResults)
typecheckModule dflags this_mod pcs hst hit decls
- = do env <- initTcEnv global_symbol_table
+ = do env <- initTcEnv hst (pcs_PTE pcs)
(maybe_result, (warns,errs)) <- initTc dflags env tc_module
else
return Nothing
where
- global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
-
tc_module :: TcM (TcEnv, TcResults)
tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env)
(nameEnvElts (getTcGEnv final_env))
local_type_env :: TypeEnv
- local_type_env = mkNameEnv [(getName thing, thing) | thing <- local_things]
+ local_type_env = mkTypeEnv local_things
- new_pst :: PackageSymbolTable
- new_pst = extendTypeEnv (pcs_PST pcs) (groupTyThings imported_things)
+ new_pte :: PackageTypeEnv
+ new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
final_pcs :: PersistentCompilerState
- final_pcs = pcs { pcs_PST = new_pst,
+ final_pcs = pcs { pcs_PTE = new_pte,
pcs_insts = new_pcs_insts,
pcs_rules = new_pcs_rules
}
projects / ghc-hetmet.git / commitdiff