summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
authorSimon Marlow <simonmar@microsoft.com>2006-07-25 13:01:54 +0000
committerSimon Marlow <simonmar@microsoft.com>2006-07-25 13:01:54 +0000
commit61d2625ae2e6a4cdae2ffc92df828905e81c24cc (patch)
tree9577057d0ba03d38aca3431090fb6d6f491ab3f1 /compiler/main
parentb93eb0c23bed01905e86c0a8c485edb388626761 (diff)
downloadhaskell-61d2625ae2e6a4cdae2ffc92df828905e81c24cc.tar.gz
Generalise Package Support
This patch pushes through one fundamental change: a module is now identified by the pair of its package and module name, whereas previously it was identified by its module name alone. This means that now a program can contain multiple modules with the same name, as long as they belong to different packages. This is a language change - the Haskell report says nothing about packages, but it is now necessary to understand packages in order to understand GHC's module system. For example, a type T from module M in package P is different from a type T from module M in package Q. Previously this wasn't an issue because there could only be a single module M in the program. The "module restriction" on combining packages has therefore been lifted, and a program can contain multiple versions of the same package. Note that none of the proposed syntax changes have yet been implemented, but the architecture is geared towards supporting import declarations qualified by package name, and that is probably the next step. It is now necessary to specify the package name when compiling a package, using the -package-name flag (which has been un-deprecated). Fortunately Cabal still uses -package-name. Certain packages are "wired in". Currently the wired-in packages are: base, haskell98, template-haskell and rts, and are always referred to by these versionless names. Other packages are referred to with full package IDs (eg. "network-1.0"). This is because the compiler needs to refer to entities in the wired-in packages, and we didn't want to bake the version of these packages into the comiler. It's conceivable that someone might want to upgrade the base package independently of GHC. Internal changes: - There are two module-related types: ModuleName just a FastString, the name of a module Module a pair of a PackageId and ModuleName A mapping from ModuleName can be a UniqFM, but a mapping from Module must be a FiniteMap (we provide it as ModuleEnv). - The "HomeModules" type that was passed around the compiler is now gone, replaced in most cases by the current package name which is contained in DynFlags. We can tell whether a Module comes from the current package by comparing its package name against the current package. - While I was here, I changed PrintUnqual to be a little more useful: it now returns the ModuleName that the identifier should be qualified with according to the current scope, rather than its original module. Also, PrintUnqual tells whether to qualify module names with package names (currently unused). Docs to follow.
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.lhs16
-rw-r--r--compiler/main/DriverMkDepend.hs29
-rw-r--r--compiler/main/DriverPipeline.hs56
-rw-r--r--compiler/main/DynFlags.hs25
-rw-r--r--compiler/main/Finder.lhs404
-rw-r--r--compiler/main/GHC.hs265
-rw-r--r--compiler/main/HeaderInfo.hs16
-rw-r--r--compiler/main/HscMain.lhs20
-rw-r--r--compiler/main/HscTypes.lhs208
-rw-r--r--compiler/main/PackageConfig.hs48
-rw-r--r--compiler/main/Packages.lhs270
-rw-r--r--compiler/main/TidyPgm.lhs31
12 files changed, 742 insertions, 646 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index d1b293353a..30f273ebaa 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -27,6 +27,7 @@ import Finder ( mkStubPaths )
import PprC ( writeCs )
import CmmLint ( cmmLint )
import Packages
+import PackageConfig ( rtsPackageId )
import Util
import FastString ( unpackFS )
import Cmm ( Cmm )
@@ -35,7 +36,7 @@ import DynFlags
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
import Pretty ( Mode(..), printDoc )
-import Module ( Module, ModLocation(..) )
+import Module ( Module, ModLocation(..), moduleName )
import List ( nub )
import Maybes ( firstJust )
@@ -156,7 +157,7 @@ outputC dflags filenm mod location flat_absC
hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
writeCs dflags h flat_absC
where
- (_, stub_h) = mkStubPaths dflags mod location
+ (_, stub_h) = mkStubPaths dflags (moduleName mod) location
\end{code}
@@ -259,12 +260,9 @@ outputForeignStubs dflags mod location stubs
"Foreign export header file" stub_h_output_d
-- we need the #includes from the rts package for the stub files
- let rtsid = rtsPackageId (pkgState dflags)
- rts_includes
- | ExtPackage pid <- rtsid =
- let rts_pkg = getPackageDetails (pkgState dflags) pid in
- concatMap mk_include (includes rts_pkg)
- | otherwise = []
+ let rts_includes =
+ let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
+ concatMap mk_include (includes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
stub_h_file_exists
@@ -287,7 +285,7 @@ outputForeignStubs dflags mod location stubs
return (stub_h_file_exists, stub_c_file_exists)
where
- (stub_c, stub_h) = mkStubPaths dflags mod location
+ (stub_c, stub_h) = mkStubPaths dflags (moduleName mod) location
cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 80d906c4a7..56f57f0f71 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -17,13 +17,12 @@ import GHC ( Session, ModSummary(..) )
import DynFlags ( DynFlags( verbosity, opt_dep ), getOpts )
import Util ( escapeSpaces, splitFilename, joinFileExt )
import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath )
-import Packages ( PackageIdH(..) )
import SysTools ( newTempName )
import qualified SysTools
-import Module ( Module, ModLocation(..), mkModule,
+import Module ( ModuleName, ModLocation(..), mkModuleName,
addBootSuffix_maybe )
import Digraph ( SCC(..) )
-import Finder ( findModule, FindResult(..) )
+import Finder ( findImportedModule, FindResult(..) )
import Util ( global, consIORef )
import Outputable
import Panic
@@ -153,7 +152,7 @@ beginMkDependHS dflags = do
-----------------------------------------------------------------
processDeps :: Session
- -> [Module]
+ -> [ModuleName]
-> Handle -- Write dependencies to here
-> SCC ModSummary
-> IO ()
@@ -217,24 +216,24 @@ processDeps session excl_mods hdl (AcyclicSCC node)
findDependency :: HscEnv
-> FilePath -- Importing module: used only for error msg
- -> Module -- Imported module
+ -> ModuleName -- Imported module
-> IsBootInterface -- Source import
-> Bool -- Record dependency on package modules
-> IO (Maybe FilePath) -- Interface file file
findDependency hsc_env src imp is_boot include_pkg_deps
= do { -- Find the module; this will be fast because
-- we've done it once during downsweep
- r <- findModule hsc_env imp True {-explicit-}
+ r <- findImportedModule hsc_env imp Nothing
; case r of
- Found loc pkg
- -- Not in this package: we don't need a dependency
- | ExtPackage _ <- pkg, not include_pkg_deps
- -> return Nothing
-
+ Found loc mod
-- Home package: just depend on the .hi or hi-boot file
- | otherwise
+ | isJust (ml_hs_file loc)
-> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+ -- Not in this package: we don't need a dependency
+ | otherwise
+ -> return Nothing
+
_ -> panic "findDependency"
}
@@ -322,7 +321,7 @@ endMkDependHS dflags
-- Flags
GLOBAL_VAR(v_Dep_makefile, "Makefile", String);
GLOBAL_VAR(v_Dep_include_pkg_deps, False, Bool);
-GLOBAL_VAR(v_Dep_exclude_mods, [], [Module]);
+GLOBAL_VAR(v_Dep_exclude_mods, [], [ModuleName]);
GLOBAL_VAR(v_Dep_suffixes, [], [String]);
GLOBAL_VAR(v_Dep_warnings, True, Bool);
@@ -337,6 +336,6 @@ dep_opts =
, ( "w", NoArg (writeIORef v_Dep_warnings False) )
, ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) )
, ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) )
- , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModule) )
- , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModule) )
+ , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
+ , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
]
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index a39ca38a99..800baf1480 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -36,6 +36,7 @@ import Finder
import HscTypes
import Outputable
import Module
+import UniqFM ( eltsUFM )
import ErrUtils
import DynFlags
import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) )
@@ -235,7 +236,7 @@ compileStub dflags mod location = do
stub_o = o_base ++ "_stub" `joinFileExt` o_ext
-- compile the _stub.c file w/ gcc
- let (stub_c,_) = mkStubPaths dflags mod location
+ let (stub_c,_) = mkStubPaths dflags (moduleName mod) location
runPipeline StopLn dflags (stub_c,Nothing)
(SpecificFile stub_o) Nothing{-no ModLocation-}
@@ -271,7 +272,7 @@ link BatchCompile dflags batch_attempt_linking hpt
| batch_attempt_linking
= do
let
- home_mod_infos = moduleEnvElts hpt
+ home_mod_infos = eltsUFM hpt
-- the packages we depend on
pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
@@ -376,9 +377,7 @@ doLink dflags stop_phase o_files
where
-- Always link in the haskell98 package for static linking. Other
-- packages have to be specified via the -package flag.
- link_pkgs
- | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
- | otherwise = []
+ link_pkgs = [haskell98PackageId]
-- ---------------------------------------------------------------------------
@@ -640,7 +639,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
case src_flavour of
ExtCoreFile -> do { -- no explicit imports in ExtCore input.
; m <- getCoreModuleName input_fn
- ; return (Nothing, mkModule m) }
+ ; return (Nothing, mkModuleName m) }
other -> do { buf <- hGetStringBuffer input_fn
; (_,_,L _ mod_name) <- getImports dflags buf input_fn
@@ -677,22 +676,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
= location3 { ml_obj_file = ofile }
| otherwise = location3
- -- Make the ModSummary to hand to hscMain
- src_timestamp <- getModificationTime (basename `joinFileExt` suff)
- let
- unused_field = panic "runPhase:ModSummary field"
- -- Some fields are not looked at by hscMain
- mod_summary = ModSummary { ms_mod = mod_name,
- ms_hsc_src = src_flavour,
- ms_hspp_file = input_fn,
- ms_hspp_opts = dflags,
- ms_hspp_buf = hspp_buf,
- ms_location = location4,
- ms_hs_date = src_timestamp,
- ms_obj_date = Nothing,
- ms_imps = unused_field,
- ms_srcimps = unused_field }
-
o_file = ml_obj_file location4 -- The real object file
@@ -703,6 +686,8 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to False tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
+ src_timestamp <- getModificationTime (basename `joinFileExt` suff)
+
let do_recomp = dopt Opt_RecompChecking dflags
source_unchanged <-
if not do_recomp || not (isStopLn stop)
@@ -731,7 +716,22 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
hsc_env <- newHscEnv dflags'
-- Tell the finder cache about this module
- addHomeModuleToFinder hsc_env mod_name location4
+ mod <- addHomeModuleToFinder hsc_env mod_name location4
+
+ -- Make the ModSummary to hand to hscMain
+ let
+ unused_field = panic "runPhase:ModSummary field"
+ -- Some fields are not looked at by hscMain
+ mod_summary = ModSummary { ms_mod = mod,
+ ms_hsc_src = src_flavour,
+ ms_hspp_file = input_fn,
+ ms_hspp_opts = dflags,
+ ms_hspp_buf = hspp_buf,
+ ms_location = location4,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = Nothing,
+ ms_imps = unused_field,
+ ms_srcimps = unused_field }
-- run the compiler!
mbResult <- hscCompileOneShot hsc_env
@@ -749,7 +749,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
return (StopLn, dflags', Just location4, o_file)
Just (HscRecomp hasStub)
-> do when hasStub $
- do stub_o <- compileStub dflags' mod_name location4
+ do stub_o <- compileStub dflags' mod location4
consIORef v_Ld_inputs stub_o
-- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
@@ -1272,12 +1272,8 @@ doMkDLL dflags o_files dep_packages = do
let extra_ld_opts = getOpts dflags opt_dll
let pstate = pkgState dflags
- rts_id | ExtPackage id <- rtsPackageId pstate = id
- | otherwise = panic "staticLink: rts package missing"
- base_id | ExtPackage id <- basePackageId pstate = id
- | otherwise = panic "staticLink: base package missing"
- rts_pkg = getPackageDetails pstate rts_id
- base_pkg = getPackageDetails pstate base_id
+ rts_pkg = getPackageDetails pstate rtsPackageId
+ base_pkg = getPackageDetails pstate basePackageId
let extra_os = if static || no_hs_main
then []
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 731ac29b49..bc6a0af300 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -49,10 +49,14 @@ module DynFlags (
#include "HsVersions.h"
-import Module ( Module, mkModule )
+import Module ( Module, mkModuleName, mkModule )
+import PackageConfig
import PrelNames ( mAIN )
-import StaticFlags ( opt_Static, opt_PIC,
- WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag )
+#ifdef i386_TARGET_ARCH
+import StaticFlags ( opt_Static )
+#endif
+import StaticFlags ( opt_PIC, WayName(..), v_Ways, v_Build_tag,
+ v_RTS_Build_tag )
import {-# SOURCE #-} Packages (PackageState)
import DriverPhases ( Phase(..), phaseInputExt )
import Config
@@ -210,6 +214,7 @@ data DynFlags = DynFlags {
importPaths :: [FilePath],
mainModIs :: Module,
mainFunIs :: Maybe String,
+ thisPackage :: PackageId,
-- ways
wayNames :: [WayName], -- way flags from the cmd line
@@ -344,6 +349,7 @@ defaultDynFlags =
importPaths = ["."],
mainModIs = mAIN,
mainFunIs = Nothing,
+ thisPackage = mainPackageId,
wayNames = panic "ways",
buildTag = panic "buildTag",
@@ -864,7 +870,7 @@ dynamic_flags = [
------- Packages ----------------------------------------------------
, ( "package-conf" , HasArg extraPkgConf_ )
, ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) )
- , ( "package-name" , HasArg ignorePackage ) -- for compatibility
+ , ( "package-name" , HasArg setPackageName )
, ( "package" , HasArg exposePackage )
, ( "hide-package" , HasArg hidePackage )
, ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) )
@@ -1073,6 +1079,13 @@ hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
+setPackageName p
+ | Nothing <- unpackPackageId pid
+ = throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
+ | otherwise
+ = upd (\s -> s{ thisPackage = pid })
+ where
+ pid = stringToPackageId p
-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags
-- (-fvia-C, -fasm, -filx respectively).
@@ -1096,10 +1109,10 @@ setMainIs :: String -> DynP ()
setMainIs arg
| not (null main_fn) -- The arg looked like "Foo.baz"
= upd $ \d -> d{ mainFunIs = Just main_fn,
- mainModIs = mkModule main_mod }
+ mainModIs = mkModule mainPackageId (mkModuleName main_mod) }
| isUpper (head main_mod) -- The arg looked like "Foo"
- = upd $ \d -> d{ mainModIs = mkModule main_mod }
+ = upd $ \d -> d{ mainModIs = mkModule mainPackageId (mkModuleName main_mod) }
| otherwise -- The arg looked like "baz"
= upd $ \d -> d{ mainFunIs = Just main_mod }
diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index fbde40f6ea..fd0982da19 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -1,45 +1,47 @@
%
-% (c) The University of Glasgow, 2000
+% (c) The University of Glasgow, 2000-2006
%
\section[Finder]{Module Finder}
\begin{code}
module Finder (
- flushFinderCache, -- :: IO ()
+ flushFinderCaches,
FindResult(..),
- findModule, -- :: ModuleName -> Bool -> IO FindResult
- findPackageModule, -- :: ModuleName -> Bool -> IO FindResult
- mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation
- mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation
- addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO ()
- uncacheModule, -- :: HscEnv -> Module -> IO ()
+ findImportedModule,
+ findExactModule,
+ findHomeModule,
+ mkHomeModLocation,
+ mkHomeModLocation2,
+ addHomeModuleToFinder,
+ uncacheModule,
mkStubPaths,
findObjectLinkableMaybe,
findObjectLinkable,
- cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc
+ cantFindError,
) where
#include "HsVersions.h"
import Module
-import UniqFM ( filterUFM, delFromUFM )
import HscTypes
import Packages
import FastString
import Util
+import PrelNames ( gHC_PRIM )
import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) )
import Outputable
+import FiniteMap
+import UniqFM
import Maybes ( expectJust )
-import DATA_IOREF ( IORef, writeIORef, readIORef )
+import DATA_IOREF ( IORef, writeIORef, readIORef, modifyIORef )
import Data.List
import System.Directory
import System.IO
import Control.Monad
-import Data.Maybe ( isNothing )
import Time ( ClockTime )
@@ -61,137 +63,174 @@ type BaseName = String -- Basename of file
-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session.
-flushFinderCache :: IORef FinderCache -> IO ()
-flushFinderCache finder_cache = do
- fm <- readIORef finder_cache
- writeIORef finder_cache $! filterUFM (\(loc,m) -> isNothing m) fm
-
-addToFinderCache :: IORef FinderCache -> Module -> FinderCacheEntry -> IO ()
-addToFinderCache finder_cache mod_name entry = do
- fm <- readIORef finder_cache
- writeIORef finder_cache $! extendModuleEnv fm mod_name entry
-
-removeFromFinderCache :: IORef FinderCache -> Module -> IO ()
-removeFromFinderCache finder_cache mod_name = do
- fm <- readIORef finder_cache
- writeIORef finder_cache $! delFromUFM fm mod_name
-
-lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FinderCacheEntry)
-lookupFinderCache finder_cache mod_name = do
- fm <- readIORef finder_cache
- return $! lookupModuleEnv fm mod_name
+flushFinderCaches :: HscEnv -> IO ()
+flushFinderCaches hsc_env = do
+ writeIORef fc_ref emptyUFM
+ flushModLocationCache this_pkg mlc_ref
+ where
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ fc_ref = hsc_FC hsc_env
+ mlc_ref = hsc_MLC hsc_env
+
+flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO ()
+flushModLocationCache this_pkg ref = do
+ fm <- readIORef ref
+ writeIORef ref $! filterFM is_ext fm
+ return ()
+ where is_ext mod _ | modulePackageId mod /= this_pkg = True
+ | otherwise = False
+
+addToFinderCache ref key val = modifyIORef ref $ \c -> addToUFM c key val
+addToModLocationCache ref key val = modifyIORef ref $ \c -> addToFM c key val
+
+removeFromFinderCache ref key = modifyIORef ref $ \c -> delFromUFM c key
+removeFromModLocationCache ref key = modifyIORef ref $ \c -> delFromFM c key
+
+lookupFinderCache ref key = do
+ c <- readIORef ref
+ return $! lookupUFM c key
+
+lookupModLocationCache ref key = do
+ c <- readIORef ref
+ return $! lookupFM c key
-- -----------------------------------------------------------------------------
-- The two external entry points
--- This is the main interface to the finder, which maps ModuleNames to
--- Modules and ModLocations.
---
--- The Module contains one crucial bit of information about a module:
--- whether it lives in the current ("home") package or not (see Module
--- for more details).
---
--- The ModLocation contains the names of all the files associated with
--- that module: its source file, .hi file, object file, etc.
-
-data FindResult
- = Found ModLocation PackageIdH
- -- the module was found
- | FoundMultiple [PackageId]
- -- *error*: both in multiple packages
- | PackageHidden PackageId
- -- for an explicit source import: the package containing the module is
- -- not exposed.
- | ModuleHidden PackageId
- -- for an explicit source import: the package containing the module is
- -- exposed, but the module itself is hidden.
- | NotFound [FilePath]
- -- the module was not found, the specified places were searched.
-
-findModule :: HscEnv -> Module -> Bool -> IO FindResult
-findModule = findModule' True
-
-findPackageModule :: HscEnv -> Module -> Bool -> IO FindResult
-findPackageModule = findModule' False
-
-
-data LocalFindResult
- = Ok FinderCacheEntry
- | CantFindAmongst [FilePath]
- | MultiplePackages [PackageId]
-
-findModule' :: Bool -> HscEnv -> Module -> Bool -> IO FindResult
-findModule' home_allowed hsc_env name explicit
- = do -- First try the cache
- mb_entry <- lookupFinderCache cache name
- case mb_entry of
- Just old_entry -> return $! found old_entry
- Nothing -> not_cached
+-- | Locate a module that was imported by the user. We have the
+-- module's name, and possibly a package name. Without a package
+-- name, this function will use the search path and the known exposed
+-- packages to find the module, if a package is specified then only
+-- that package is searched for the module.
+
+findImportedModule :: HscEnv -> ModuleName -> Maybe PackageId -> IO FindResult
+findImportedModule hsc_env mod_name mb_pkgid =
+ case mb_pkgid of
+ Nothing -> unqual_import
+ Just pkg | pkg == this_pkg -> home_import
+ | otherwise -> pkg_import pkg
+ where
+ dflags = hsc_dflags hsc_env
+ this_pkg = thisPackage dflags
+
+ home_import = findHomeModule hsc_env mod_name
+
+ pkg_import pkg = findPackageModule hsc_env (mkModule pkg mod_name)
+ -- ToDo: this isn't quite right, the module we want
+ -- might actually be in another package, but re-exposed
+ -- ToDo: should return NotFoundInPackage if
+ -- the module isn't exposed by the package.
+
+ unqual_import = home_import
+ `orIfNotFound`
+ findExposedPackageModule hsc_env mod_name
+
+-- | Locate a specific 'Module'. The purpose of this function is to
+-- create a 'ModLocation' for a given 'Module', that is to find out
+-- where the files associated with this module live. It is used when
+-- reading the interface for a module mentioned by another interface,
+-- for example (a "system import").
+
+findExactModule :: HscEnv -> Module -> IO FindResult
+findExactModule hsc_env mod =
+ let dflags = hsc_dflags hsc_env in
+ if modulePackageId mod == thisPackage dflags
+ then findHomeModule hsc_env (moduleName mod)
+ else findPackageModule hsc_env mod
- where
- cache = hsc_FC hsc_env
- dflags = hsc_dflags hsc_env
-
- -- We've found the module, so the remaining question is
- -- whether it's visible or not
- found :: FinderCacheEntry -> FindResult
- found (loc, Nothing)
- | home_allowed = Found loc HomePackage
- | otherwise = NotFound []
- found (loc, Just (pkg, exposed_mod))
- | explicit && not exposed_mod = ModuleHidden pkg_name
- | explicit && not (exposed pkg) = PackageHidden pkg_name
- | otherwise =
- Found loc (ExtPackage (mkPackageId (package pkg)))
- where
- pkg_name = packageConfigId pkg
-
- found_new entry = do
- addToFinderCache cache name entry
- return $! found entry
-
- not_cached
- | not home_allowed = do
- j <- findPackageModule' dflags name
- case j of
- Ok entry -> found_new entry
- MultiplePackages pkgs -> return (FoundMultiple pkgs)
- CantFindAmongst paths -> return (NotFound paths)
-
- | otherwise = do
- j <- findHomeModule' dflags name
- case j of
- Ok entry -> found_new entry
- MultiplePackages pkgs -> return (FoundMultiple pkgs)
- CantFindAmongst home_files -> do
- r <- findPackageModule' dflags name
- case r of
- CantFindAmongst pkg_files ->
- return (NotFound (home_files ++ pkg_files))
- MultiplePackages pkgs ->
- return (FoundMultiple pkgs)
- Ok entry ->
- found_new entry
-
-addHomeModuleToFinder :: HscEnv -> Module -> ModLocation -> IO ()
-addHomeModuleToFinder hsc_env mod loc
- = addToFinderCache (hsc_FC hsc_env) mod (loc, Nothing)
-
-uncacheModule :: HscEnv -> Module -> IO ()
-uncacheModule hsc_env mod = removeFromFinderCache (hsc_FC hsc_env) mod
+-- -----------------------------------------------------------------------------
+-- Helpers
+
+this `orIfNotFound` or_this = do
+ res <- this
+ case res of
+ NotFound here -> do
+ res2 <- or_this
+ case res2 of
+ NotFound or_here -> return (NotFound (here ++ or_here))
+ _other -> return res2
+ _other -> return res
+
+
+homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
+homeSearchCache hsc_env mod_name do_this = do
+ m <- lookupFinderCache (hsc_FC hsc_env) mod_name
+ case m of
+ Just result -> return result
+ Nothing -> do
+ result <- do_this
+ addToFinderCache (hsc_FC hsc_env) mod_name result
+ case result of
+ Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
+ _other -> return ()
+ return result
+
+findExposedPackageModule :: HscEnv -> ModuleName -> IO FindResult
+findExposedPackageModule hsc_env mod_name
+ -- not found in any package:
+ | null found = return (NotFound [])
+ -- found in just one exposed package:
+ | [(pkg_conf, _)] <- found_exposed
+ = let pkgid = mkPackageId (package pkg_conf) in
+ findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf
+ -- not found in any exposed package, report how it was hidden:
+ | null found_exposed, ((pkg_conf, exposed_mod):_) <- found
+ = let pkgid = mkPackageId (package pkg_conf) in
+ if not (exposed_mod)
+ then return (ModuleHidden pkgid)
+ else return (PackageHidden pkgid)
+ | otherwise
+ = return (FoundMultiple (map (mkPackageId.package.fst) found_exposed))
+ where
+ dflags = hsc_dflags hsc_env
+ found = lookupModuleInAllPackages dflags mod_name
+ found_exposed = filter is_exposed found
+ is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod
+
+
+modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
+modLocationCache hsc_env mod do_this = do
+ mb_loc <- lookupModLocationCache mlc mod
+ case mb_loc of
+ Just loc -> return (Found loc mod)
+ Nothing -> do
+ result <- do_this
+ case result of
+ Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
+ _other -> return ()
+ return result
+ where
+ mlc = hsc_MLC hsc_env
+
+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
+addHomeModuleToFinder hsc_env mod_name loc = do
+ let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
+ addToFinderCache (hsc_FC hsc_env) mod_name (Found loc mod)
+ addToModLocationCache (hsc_MLC hsc_env) mod loc
+ return mod
+
+uncacheModule :: HscEnv -> ModuleName -> IO ()
+uncacheModule hsc_env mod = do
+ let this_pkg = thisPackage (hsc_dflags hsc_env)
+ removeFromFinderCache (hsc_FC hsc_env) mod
+ removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod)
-- -----------------------------------------------------------------------------
-- The internal workers
-findHomeModule' :: DynFlags -> Module -> IO LocalFindResult
-findHomeModule' dflags mod = do
- let home_path = importPaths dflags
- hisuf = hiSuf dflags
+-- | Search for a module in the home package only.
+findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule hsc_env mod_name =
+ homeSearchCache hsc_env mod_name $
+ let
+ dflags = hsc_dflags hsc_env
+ home_path = importPaths dflags
+ hisuf = hiSuf dflags
+ mod = mkModule (thisPackage dflags) mod_name
- let
source_exts =
- [ ("hs", mkHomeModLocationSearched dflags mod "hs")
- , ("lhs", mkHomeModLocationSearched dflags mod "lhs")
+ [ ("hs", mkHomeModLocationSearched dflags mod_name "hs")
+ , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs")
]
hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf)
@@ -203,31 +242,43 @@ findHomeModule' dflags mod = do
-- compilation mode we look for .hi and .hi-boot files only.
exts | isOneShot (ghcMode dflags) = hi_exts
| otherwise = source_exts
-
+ in
searchPathExts home_path mod exts
-
-findPackageModule' :: DynFlags -> Module -> IO LocalFindResult
-findPackageModule' dflags mod
- = case lookupModuleInAllPackages dflags mod of
- [] -> return (CantFindAmongst [])
- [pkg_info] -> findPackageIface dflags mod pkg_info
- many -> return (MultiplePackages (map (mkPackageId.package.fst) many))
-
-findPackageIface :: DynFlags -> Module -> (PackageConfig,Bool) -> IO LocalFindResult
-findPackageIface dflags mod pkg_info@(pkg_conf, _) = do
+
+
+-- | Search for a module in external packages only.
+findPackageModule :: HscEnv -> Module -> IO FindResult
+findPackageModule hsc_env mod = do
let
+ dflags = hsc_dflags hsc_env
+ pkg_id = modulePackageId mod
+ pkg_map = pkgIdMap (pkgState dflags)
+ --
+ case lookupPackage pkg_map pkg_id of
+ Nothing -> return (NoPackage pkg_id)
+ Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
+
+findPackageModule_ hsc_env mod pkg_conf =
+ modLocationCache hsc_env mod $
+
+ -- special case for GHC.Prim; we won't find it in the filesystem.
+ if mod == gHC_PRIM
+ then return (Found (error "GHC.Prim ModLocation") mod)
+ else
+
+ let
+ dflags = hsc_dflags hsc_env
tag = buildTag dflags
-- hi-suffix for packages depends on the build tag.
package_hisuf | null tag = "hi"
| otherwise = tag ++ "_hi"
hi_exts =
- [ (package_hisuf,
- mkPackageModLocation dflags pkg_info package_hisuf) ]
+ [ (package_hisuf, mkHiOnlyModLocation dflags package_hisuf) ]
source_exts =
- [ ("hs", mkPackageModLocation dflags pkg_info package_hisuf)
- , ("lhs", mkPackageModLocation dflags pkg_info package_hisuf)
+ [ ("hs", mkHiOnlyModLocation dflags package_hisuf)
+ , ("lhs", mkHiOnlyModLocation dflags package_hisuf)
]
-- mkdependHS needs to look for source files in packages too, so
@@ -238,7 +289,7 @@ findPackageIface dflags mod pkg_info@(pkg_conf, _) = do
| otherwise = hi_exts
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
-
+ in
searchPathExts (importDirs pkg_conf) mod exts
-- -----------------------------------------------------------------------------
@@ -248,11 +299,11 @@ searchPathExts
:: [FilePath] -- paths to search
-> Module -- module name
-> [ (
- FileExt, -- suffix
- FilePath -> BaseName -> IO FinderCacheEntry -- action
+ FileExt, -- suffix
+ FilePath -> BaseName -> IO ModLocation -- action
)
]
- -> IO LocalFindResult
+ -> IO FindResult
searchPathExts paths mod exts
= do result <- search to_search
@@ -267,9 +318,9 @@ searchPathExts paths mod exts
return result
where
- basename = dots_to_slashes (moduleString mod)
+ basename = dots_to_slashes (moduleNameString (moduleName mod))
- to_search :: [(FilePath, IO FinderCacheEntry)]
+ to_search :: [(FilePath, IO ModLocation)]
to_search = [ (file, fn path basename)
| path <- paths,
(ext,fn) <- exts,
@@ -278,30 +329,17 @@ searchPathExts paths mod exts
file = base `joinFileExt` ext
]
- search [] = return (CantFindAmongst (map fst to_search))
+ search [] = return (NotFound (map fst to_search))
search ((file, mk_result) : rest) = do
b <- doesFileExist file
if b
- then do { res <- mk_result; return (Ok res) }
+ then do { loc <- mk_result; return (Found loc mod) }
else search rest
-mkHomeModLocationSearched :: DynFlags -> Module -> FileExt
- -> FilePath -> BaseName -> IO FinderCacheEntry
+mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
+ -> FilePath -> BaseName -> IO ModLocation
mkHomeModLocationSearched dflags mod suff path basename = do
- loc <- mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff
- return (loc, Nothing)
-
-mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName
- -> IO FinderCacheEntry
-mkHiOnlyModLocation dflags hisuf path basename = do
- loc <- hiOnlyModLocation dflags path basename hisuf
- return (loc, Nothing)
-
-mkPackageModLocation :: DynFlags -> (PackageConfig, Bool) -> FileExt
- -> FilePath -> BaseName -> IO FinderCacheEntry
-mkPackageModLocation dflags pkg_info hisuf path basename = do
- loc <- hiOnlyModLocation dflags path basename hisuf
- return (loc, Just pkg_info)
+ mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff
-- -----------------------------------------------------------------------------
-- Constructing a home module location
@@ -336,18 +374,18 @@ mkPackageModLocation dflags pkg_info hisuf path basename = do
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation
+mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation dflags mod src_filename = do
let (basename,extension) = splitFilename src_filename
mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: DynFlags
- -> Module
+ -> ModuleName
-> FilePath -- Of source module, without suffix
-> String -- Suffix
-> IO ModLocation
mkHomeModLocation2 dflags mod src_basename ext = do
- let mod_basename = dots_to_slashes (moduleString mod)
+ let mod_basename = dots_to_slashes (moduleNameString mod)
obj_fn <- mkObjPath dflags src_basename mod_basename
hi_fn <- mkHiPath dflags src_basename mod_basename
@@ -356,8 +394,9 @@ mkHomeModLocation2 dflags mod src_basename ext = do
ml_hi_file = hi_fn,
ml_obj_file = obj_fn })
-hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation
-hiOnlyModLocation dflags path basename hisuf
+mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
+ -> IO ModLocation
+mkHiOnlyModLocation dflags hisuf path basename
= do let full_basename = path `joinFileName` basename
obj_fn <- mkObjPath dflags full_basename basename
return ModLocation{ ml_hs_file = Nothing,
@@ -412,7 +451,7 @@ mkHiPath dflags basename mod_basename
mkStubPaths
:: DynFlags
- -> Module
+ -> ModuleName
-> ModLocation
-> (FilePath,FilePath)
@@ -420,7 +459,7 @@ mkStubPaths dflags mod location
= let
stubdir = stubDir dflags
- mod_basename = dots_to_slashes (moduleString mod)
+ mod_basename = dots_to_slashes (moduleNameString mod)
src_basename = basenameOf (expectJust "mkStubPaths"
(ml_hs_file location))
@@ -466,7 +505,7 @@ dots_to_slashes = map (\c -> if c == '.' then '/' else c)
-- -----------------------------------------------------------------------------
-- Error messages
-cantFindError :: DynFlags -> Module -> FindResult -> SDoc
+cantFindError :: DynFlags -> ModuleName -> FindResult -> SDoc
cantFindError dflags mod_name (FoundMultiple pkgs)
= hang (ptext SLIT("Cannot import") <+> quotes (ppr mod_name) <> colon) 2 (
sep [ptext SLIT("it was found in multiple packages:"),
@@ -486,6 +525,10 @@ cantFindError dflags mod_name find_result
-> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package")
<+> ppr pkg)
+ NoPackage pkg
+ -> ptext SLIT("no package matching") <+> ppr pkg <+>
+ ptext SLIT("was found")
+
NotFound files
| null files
-> ptext SLIT("it is not a module in the current program, or in any known package.")
@@ -495,5 +538,8 @@ cantFindError dflags mod_name find_result
-> hang (ptext SLIT("locations searched:"))
2 (vcat (map text files))
+ NotFoundInPackage pkg
+ -> ptext SLIT("it is not in package") <+> ppr pkg
+
_ -> panic "cantFindErr"
\end{code}
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5f82cf3fdb..543d2a940d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -43,7 +43,7 @@ module GHC (
TypecheckedSource, ParsedSource, RenamedSource,
-- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..), ModLocation(..),
+ ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
isLoaded,
topSortModuleGraph,
@@ -65,6 +65,7 @@ module GHC (
-- * Interactive evaluation
getBindings, getPrintUnqual,
+ findModule,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
@@ -83,8 +84,12 @@ module GHC (
-- * Abstract syntax elements
+ -- ** Packages
+ PackageId,
+
-- ** Modules
- Module, mkModule, pprModule,
+ Module, mkModule, pprModule, moduleName, modulePackageId,
+ ModuleName, mkModuleName, moduleNameString,
-- ** Names
Name,
@@ -177,6 +182,7 @@ import RdrName ( plusGlobalRdrEnv, Provenance(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
mkGlobalRdrEnv )
import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
+import Name ( nameOccName )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce# )
@@ -208,7 +214,7 @@ import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
dataConFieldLabels, dataConStrictMarks,
dataConIsInfix, isVanillaDataCon )
import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
- nameSrcLoc, nameOccName )
+ nameSrcLoc )
import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
@@ -216,19 +222,20 @@ import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
-import Packages ( isHomePackage )
import Finder
import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
import SysTools ( initSysTools, cleanTempFiles )
import Module
+import UniqFM
+import PackageConfig ( PackageId )
import FiniteMap
import Panic
import Digraph
import Bag ( unitBag )
import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
+ mkPlainErrMsg, printBagOfErrors )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
@@ -448,7 +455,7 @@ guessTarget file Nothing
if exists
then return (Target (TargetFile lhs_file Nothing) Nothing)
else do
- return (Target (TargetModule (mkModule file)) Nothing)
+ return (Target (TargetModule (mkModuleName file)) Nothing)
where
hs_file = file `joinFileExt` "hs"
lhs_file = file `joinFileExt` "lhs"
@@ -483,7 +490,7 @@ setGlobalTypeScope session ids
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
+depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
depanal (Session ref) excluded_mods allow_dup_roots = do
hsc_env <- readIORef ref
let
@@ -522,8 +529,8 @@ data ErrMsg = ErrMsg {
data LoadHowMuch
= LoadAllTargets
- | LoadUpTo Module
- | LoadDependenciesOf Module
+ | LoadUpTo ModuleName
+ | LoadDependenciesOf ModuleName
-- | Try to load the program. If a Module is supplied, then just
-- attempt to load up to this target. If no Module is supplied,
@@ -552,10 +559,11 @@ load2 s@(Session ref) how_much mod_graph = do
-- B.hs-boot in the module graph, but no B.hs
-- The downsweep should have ensured this does not happen
-- (see msDeps)
- let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
+ let all_home_mods = [ms_mod_name s
+ | s <- mod_graph, not (isBootSummary s)]
#ifdef DEBUG
bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
- not (ms_mod s `elem` all_home_mods)]
+ not (ms_mod_name s `elem` all_home_mods)]
#endif
ASSERT( null bad_boot_mods ) return ()
@@ -586,7 +594,7 @@ load2 s@(Session ref) how_much mod_graph = do
-- Unload any modules which are going to be re-linked this time around.
let stable_linkables = [ linkable
| m <- stable_obj++stable_bco,
- Just hmi <- [lookupModuleEnv pruned_hpt m],
+ Just hmi <- [lookupUFM pruned_hpt m],
Just linkable <- [hm_linkable hmi] ]
unload hsc_env stable_linkables
@@ -623,7 +631,7 @@ load2 s@(Session ref) how_much mod_graph = do
partial_mg
| LoadDependenciesOf mod <- how_much
= ASSERT( case last partial_mg0 of
- AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
+ AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
List.init partial_mg0
| otherwise
= partial_mg0
@@ -631,9 +639,9 @@ load2 s@(Session ref) how_much mod_graph = do
stable_mg =
[ AcyclicSCC ms
| AcyclicSCC ms <- full_mg,
- ms_mod ms `elem` stable_obj++stable_bco,
- ms_mod ms `notElem` [ ms_mod ms' |
- AcyclicSCC ms' <- partial_mg ] ]
+ ms_mod_name ms `elem` stable_obj++stable_bco,
+ ms_mod_name ms `notElem` [ ms_mod_name ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
mg = stable_mg ++ partial_mg
@@ -679,7 +687,7 @@ load2 s@(Session ref) how_much mod_graph = do
when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
- "because there is no " ++ moduleString main_mod ++ " module."))
+ "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
-- link everything together
linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
@@ -701,7 +709,7 @@ load2 s@(Session ref) how_much mod_graph = do
= filter ((`notElem` mods_to_zap_names).ms_mod)
modsDone
- let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep)
+ let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
(hsc_HPT hsc_env1)
-- Clean up after ourselves
@@ -709,7 +717,7 @@ load2 s@(Session ref) how_much mod_graph = do
-- there should be no Nothings where linkables should be, now
ASSERT(all (isJust.hm_linkable)
- (moduleEnvElts (hsc_HPT hsc_env))) do
+ (eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together
linkresult <- link ghci_mode dflags False hpt4
@@ -780,7 +788,7 @@ type TypecheckedSource = LHsBinds Id
-- for a module. 'checkModule' loads all the dependencies of the specified
-- module in the Session, and then attempts to typecheck the module. If
-- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> Module -> IO (Maybe CheckedModule)
+checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
checkModule session@(Session ref) mod = do
-- load up the dependencies first
r <- load session (LoadDependenciesOf mod)
@@ -789,7 +797,7 @@ checkModule session@(Session ref) mod = do
-- now parse & typecheck the module
hsc_env <- readIORef ref
let mg = hsc_mod_graph hsc_env
- case [ ms | ms <- mg, ms_mod ms == mod ] of
+ case [ ms | ms <- mg, ms_mod_name ms == mod ] of
[] -> return Nothing
(ms:_) -> do
mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
@@ -885,9 +893,9 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
checkStability
:: HomePackageTable -- HPT from last compilation
-> [SCC ModSummary] -- current module graph (cyclic)
- -> [Module] -- all home modules
- -> ([Module], -- stableObject
- [Module]) -- stableBCO
+ -> [ModuleName] -- all home modules
+ -> ([ModuleName], -- stableObject
+ [ModuleName]) -- stableBCO
checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
where
@@ -897,7 +905,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
| otherwise = (stable_obj, stable_bco)
where
scc = flattenSCC scc0
- scc_mods = map ms_mod scc
+ scc_mods = map ms_mod_name scc
home_module m = m `elem` all_home_mods && m `notElem` scc_mods
scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
@@ -919,7 +927,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
&& same_as_prev t
| otherwise = False
where
- same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of
+ same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi
-> isObjectLinkable l && t == linkableTime l
_other -> True
@@ -931,13 +939,13 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
-- make's behaviour.
bco_ok ms
- = case lookupModuleEnv hpt (ms_mod ms) of
+ = case lookupUFM hpt (ms_mod_name ms) of
Just hmi | Just l <- hm_linkable hmi ->
not (isObjectLinkable l) &&
linkableTime l >= ms_hs_date ms
_other -> False
-ms_allimps :: ModSummary -> [Module]
+ms_allimps :: ModSummary -> [ModuleName]
ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-- -----------------------------------------------------------------------------
@@ -958,23 +966,23 @@ ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
pruneHomePackageTable
:: HomePackageTable
-> [ModSummary]
- -> ([Module],[Module])
+ -> ([ModuleName],[ModuleName])
-> HomePackageTable
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
- = mapModuleEnv prune hpt
+ = mapUFM prune hpt
where prune hmi
| is_stable modl = hmi'
| otherwise = hmi'{ hm_details = emptyModDetails }
where
- modl = mi_module (hm_iface hmi)
+ modl = moduleName (mi_module (hm_iface hmi))
hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
= hmi{ hm_linkable = Nothing }
| otherwise
= hmi
- where ms = expectJust "prune" (lookupModuleEnv ms_map modl)
+ where ms = expectJust "prune" (lookupUFM ms_map modl)
- ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ]
+ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
is_stable m = m `elem` stable_obj || m `elem` stable_bco
@@ -1011,7 +1019,7 @@ findPartiallyCompletedCycles modsDone theGraph
upsweep
:: HscEnv -- Includes initially-empty HPT
-> HomePackageTable -- HPT from last time round (pruned)
- -> ([Module],[Module]) -- stable modules (see checkStability)
+ -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
-> IO () -- How to clean up unwanted tmp files
-> [SCC ModSummary] -- Mods to do (the worklist)
-> IO (SuccessFlag,
@@ -1044,11 +1052,10 @@ upsweep' hsc_env old_hpt stable_mods cleanup
case mb_mod_info of
Nothing -> return (Failed, hsc_env, [])
Just mod_info -> do
- { let this_mod = ms_mod mod
+ { let this_mod = ms_mod_name mod
-- Add new info to hsc_env
- hpt1 = extendModuleEnv (hsc_HPT hsc_env)
- this_mod mod_info
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-- Space-saving: delete the old HPT entry
@@ -1058,7 +1065,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup
-- main Haskell source file. Deleting it
-- would force .. (what?? --SDM)
old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delModuleEnv old_hpt this_mod
+ | otherwise = delFromUFM old_hpt this_mod
; (restOK, hsc_env2, modOKs)
<- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
@@ -1071,7 +1078,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
-> HomePackageTable
- -> ([Module],[Module])
+ -> ([ModuleName],[ModuleName])
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
@@ -1080,13 +1087,14 @@ upsweep_mod :: HscEnv
upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= do
let
+ this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary
obj_fn = ml_obj_file (ms_location summary)
hs_date = ms_hs_date summary
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = upsweep_compile hsc_env old_hpt this_mod
+ compile_it = upsweep_compile hsc_env old_hpt this_mod_name
summary mod_index nmods
case ghcMode (hsc_dflags hsc_env) of
@@ -1134,10 +1142,10 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
compile_it Nothing
-- no existing code at all: we must recompile.
where
- is_stable_obj = this_mod `elem` stable_obj
- is_stable_bco = this_mod `elem` stable_bco
+ is_stable_obj = this_mod_name `elem` stable_obj
+ is_stable_bco = this_mod_name `elem` stable_bco
- old_hmi = lookupModuleEnv old_hpt this_mod
+ old_hmi = lookupUFM old_hpt this_mod_name
-- Run hsc to compile a module
upsweep_compile hsc_env old_hpt this_mod summary
@@ -1154,7 +1162,7 @@ upsweep_compile hsc_env old_hpt this_mod summary
-- will always be recompiled
mb_old_iface
- = case lookupModuleEnv old_hpt this_mod of
+ = case lookupUFM old_hpt this_mod of
Nothing -> Nothing
Just hm_info | isBootSummary summary -> Just iface
| not (mi_boot iface) -> Just iface
@@ -1180,11 +1188,11 @@ upsweep_compile hsc_env old_hpt this_mod summary
-- Filter modules in the HPT
-retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
- = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info)
+ = listToUFM [ (mod, expectJust "retain" mb_mod_info)
| mod <- keep_these
- , let mb_mod_info = lookupModuleEnv hpt mod
+ , let mb_mod_info = lookupUFM hpt mod
, isJust mb_mod_info ]
-- ---------------------------------------------------------------------------
@@ -1193,7 +1201,7 @@ retainInTopLevelEnvs keep_these hpt
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
- -> Maybe Module
+ -> Maybe ModuleName
-> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
@@ -1226,7 +1234,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
| otherwise = throwDyn (ProgramError "module does not exist")
moduleGraphNodes :: Bool -> [ModSummary]
- -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int)
+ -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
where
-- Drop hs-boot nodes by using HsSrcFile as the key
@@ -1235,7 +1243,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)),
+ nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
| s <- summaries
@@ -1243,23 +1251,24 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
-- Drop the hi-boot ones if told to do so
key_map :: NodeMap Int
- key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
+ key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
+ | s <- summaries]
`zip` [1..])
- lookup_key :: HscSource -> Module -> Maybe Int
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
- out_edge_keys :: HscSource -> [Module] -> [Int]
+ out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- the IsBootInterface parameter True; else False
-type NodeKey = (Module, HscSource) -- The nodes of the graph are
+type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
msKey :: ModSummary -> NodeKey
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
@@ -1267,6 +1276,9 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
+ms_mod_name :: ModSummary -> ModuleName
+ms_mod_name = moduleName . ms_mod
+
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
@@ -1284,7 +1296,7 @@ nodeMapElts = eltsFM
downsweep :: HscEnv
-> [ModSummary] -- Old summaries
- -> [Module] -- Ignore dependencies on these; treat
+ -> [ModuleName] -- Ignore dependencies on these; treat
-- them as if they were package modules
-> Bool -- True <=> allow multiple targets to have
-- the same module name; this is
@@ -1336,7 +1348,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton (nodeMapElts root_map)
- loop :: [(Located Module,IsBootInterface)]
+ loop :: [(Located ModuleName,IsBootInterface)]
-- Work list: process these modules
-> NodeMap [ModSummary]
-- Visited set; the range is a list because
@@ -1365,7 +1377,7 @@ mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
mkRootMap summaries = addListToFM_C (++) emptyFM
[ (msKey s, [s]) | s <- summaries ]
-msDeps :: ModSummary -> [(Located Module, IsBootInterface)]
+msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
-- *both* the hs-boot file
@@ -1432,14 +1444,14 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf
(dflags', hspp_fn, buf)
<- preprocessFile dflags file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
-- Make a ModLocation for this file
- location <- mkHomeModLocation dflags mod file
+ location <- mkHomeModLocation dflags mod_name file
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
- addHomeModuleToFinder hsc_env mod location
+ mod <- addHomeModuleToFinder hsc_env mod_name location
src_timestamp <- case maybe_buf of
Just (_,t) -> return t
@@ -1469,9 +1481,9 @@ summariseModule
:: HscEnv
-> NodeMap ModSummary -- Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
- -> Located Module -- Imported module to be summarised
+ -> Located ModuleName -- Imported module to be summarised
-> Maybe (StringBuffer, ClockTime)
- -> [Module] -- Modules to exclude
+ -> [ModuleName] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
@@ -1508,9 +1520,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
obj_timestamp <- getObjTimestamp location is_boot
return (Just old_summary{ ms_obj_date = obj_timestamp })
| otherwise =
- -- source changed: find and re-summarise. We call the finder
- -- again, because the user may have moved the source file.
- new_summary location src_fn src_timestamp
+ -- source changed: re-summarise.
+ new_summary location (ms_mod old_summary) src_fn src_timestamp
find_it = do
-- Don't use the Finder's cache this time. If the module was
@@ -1518,17 +1529,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
-- search path, so we want to consider it to be a home module. If
-- the module was previously a home module, it may have moved.
uncacheModule hsc_env wanted_mod
- found <- findModule hsc_env wanted_mod True {-explicit-}
+ found <- findImportedModule hsc_env wanted_mod Nothing
case found of
- Found location pkg
- | not (isHomePackage pkg) -> return Nothing
- -- Drop external-pkg
- | isJust (ml_hs_file location) -> just_found location
+ Found location mod
+ | isJust (ml_hs_file location) ->
-- Home package
+ just_found location mod
+ | otherwise ->
+ -- Drop external-pkg
+ ASSERT(modulePackageId mod /= thisPackage dflags)
+ return Nothing
+ where
+
err -> noModError dflags loc wanted_mod err
-- Not found
- just_found location = do
+ just_found location mod = do
-- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
let location' | is_boot = addBootSuffixLocn location
@@ -1540,10 +1556,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> noHsFileErr loc src_fn
- Just t -> new_summary location' src_fn t
+ Just t -> new_summary location' mod src_fn t
- new_summary location src_fn src_timestamp
+ new_summary location mod src_fn src_timestamp
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
@@ -1558,7 +1574,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
-- Find the object timestamp, and return the summary
obj_timestamp <- getObjTimestamp location is_boot
- return (Just ( ModSummary { ms_mod = wanted_mod,
+ return (Just ( ModSummary { ms_mod = mod,
ms_hsc_src = hsc_src,
ms_location = location,
ms_hspp_file = hspp_fn,
@@ -1610,7 +1626,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
-- Error messages
-----------------------------------------------------------------------------
-noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab
+noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
noModError dflags loc wanted_mod err
= throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
@@ -1650,8 +1666,7 @@ cyclicModuleErr ms
-- Note: if you change the working directory, you should also unload
-- the current program (set targets to empty, followed by load).
workingDirectoryChanged :: Session -> IO ()
-workingDirectoryChanged s = withSession s $ \hsc_env ->
- flushFinderCache (hsc_FC hsc_env)
+workingDirectoryChanged s = withSession s $ flushFinderCaches
-- -----------------------------------------------------------------------------
-- inspecting the session
@@ -1660,9 +1675,9 @@ workingDirectoryChanged s = withSession s $ \hsc_env ->
getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph s = withSession s (return . hsc_mod_graph)
-isLoaded :: Session -> Module -> IO Bool
+isLoaded :: Session -> ModuleName -> IO Bool
isLoaded s m = withSession s $ \hsc_env ->
- return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
+ return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
getBindings :: Session -> IO [TyThing]
getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
@@ -1686,7 +1701,7 @@ getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
getModuleInfo s mdl = withSession s $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg
- then getHomeModuleInfo hsc_env mdl
+ then getHomeModuleInfo hsc_env (moduleName mdl)
else do
{- if isHomeModule (hsc_dflags hsc_env) mdl
then return Nothing
@@ -1713,7 +1728,7 @@ getPackageModuleInfo hsc_env mdl = do
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
- minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl,
+ minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
minf_instances = error "getModuleInfo: instances for package module unimplemented"
}))
#else
@@ -1722,7 +1737,7 @@ getPackageModuleInfo hsc_env mdl = do
#endif
getHomeModuleInfo hsc_env mdl =
- case lookupModuleEnv (hsc_HPT hsc_env) mdl of
+ case lookupUFM (hsc_HPT hsc_env) mdl of
Nothing -> return Nothing
Just hmi -> do
let details = hm_details hmi
@@ -1753,7 +1768,7 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
-modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
modInfoLookupName s minf name = withSession s $ \hsc_env -> do
@@ -1761,7 +1776,8 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do
Just tyThing -> return (Just tyThing)
Nothing -> do
eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+ return $! lookupType (hsc_dflags hsc_env)
+ (hsc_HPT hsc_env) (eps_PTE eps) name
isDictonaryId :: Id -> Bool
isDictonaryId id
@@ -1774,7 +1790,8 @@ isDictonaryId id
lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
lookupGlobalName s name = withSession s $ \hsc_env -> do
eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+ return $! lookupType (hsc_dflags hsc_env)
+ (hsc_HPT hsc_env) (eps_PTE eps) name
-- -----------------------------------------------------------------------------
-- Misc exported utils
@@ -1811,6 +1828,29 @@ getTokenStream :: Session -> Module -> IO [Located Token]
-- -----------------------------------------------------------------------------
-- Interactive evaluation
+-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
+-- filesystem and package database to find the corresponding 'Module',
+-- using the algorithm that is used for an @import@ declaration.
+findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
+findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
+ findModule' hsc_env mod_name maybe_pkg
+
+findModule' hsc_env mod_name maybe_pkg =
+ let
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ this_pkg = thisPackage dflags
+ in
+ case lookupUFM hpt mod_name of
+ Just mod_info -> return (mi_module (hm_iface mod_info))
+ _not_a_home_module -> do
+ res <- findImportedModule hsc_env mod_name Nothing
+ case res of
+ Found _ m | modulePackageId m /= this_pkg -> return m
+ -- not allowed to be a home module
+ err -> let msg = cantFindError dflags mod_name err in
+ throwDyn (CmdLineError (showSDoc msg))
+
#ifdef GHCI
-- | Set the interactive evaluation context.
@@ -1822,17 +1862,16 @@ setContext :: Session
-> [Module] -- entire top level scope of these modules
-> [Module] -- exports only of these modules
-> IO ()
-setContext (Session ref) toplevs exports = do
+setContext (Session ref) toplev_mods export_mods = do
hsc_env <- readIORef ref
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
-
- mapM_ (checkModuleExists hsc_env hpt) exports
- export_env <- mkExportEnv hsc_env exports
- toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
+ --
+ export_env <- mkExportEnv hsc_env export_mods
+ toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
- writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
- ic_exports = exports,
+ writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
+ ic_exports = export_mods,
ic_rn_gbl_env = all_env }}
@@ -1842,47 +1881,35 @@ mkExportEnv hsc_env mods = do
stuff <- mapM (getModuleExports hsc_env) mods
let
(_msgs, mb_name_sets) = unzip stuff
- gres = [ nameSetToGlobalRdrEnv name_set mod
+ gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
| (Just name_set, mod) <- zip mb_name_sets mods ]
--
return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
-nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
+nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
nameSetToGlobalRdrEnv names mod =
mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
| name <- nameSetToList names ]
-vanillaProv :: Module -> Provenance
+vanillaProv :: ModuleName -> Provenance
-- We're building a GlobalRdrEnv as if the user imported
-- all the specified modules into the global interactive module
-vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
+vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
where
- decl = ImpDeclSpec { is_mod = mod, is_as = mod,
+ decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
is_qual = False,
is_dloc = srcLocSpan interactiveSrcLoc }
-checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
-checkModuleExists hsc_env hpt mod =
- case lookupModuleEnv hpt mod of
- Just mod_info -> return ()
- _not_a_home_module -> do
- res <- findPackageModule hsc_env mod True
- case res of
- Found _ _ -> return ()
- err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in
- throwDyn (CmdLineError (showSDoc msg))
-
mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
- = case lookupModuleEnv hpt modl of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not a home module "
- ++ showSDoc (pprModule modl)))
+ = case lookupUFM hpt (moduleName modl) of
+ Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
+ showSDoc (ppr modl)))
Just details ->
case mi_globals (hm_iface details) of
Nothing ->
throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (pprModule modl)))
+ ++ showSDoc (ppr modl)))
Just env -> return env
-- | Get the interactive evaluation context, consisting of a pair of the
@@ -1896,9 +1923,11 @@ getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
-- its full top-level scope available.
moduleIsInterpreted :: Session -> Module -> IO Bool
moduleIsInterpreted s modl = withSession s $ \h ->
- case lookupModuleEnv (hsc_HPT h) modl of
- Just details -> return (isJust (mi_globals (hm_iface details)))
- _not_a_home_module -> return False
+ if modulePackageId modl /= thisPackage (hsc_dflags h)
+ then return False
+ else case lookupUFM (hsc_HPT h) (moduleName modl) of
+ Just details -> return (isJust (mi_globals (hm_iface details)))
+ _not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
@@ -2076,7 +2105,7 @@ foreign import "rts_evalStableIO" {- safe -}
showModule :: Session -> ModSummary -> IO String
showModule s mod_summary = withSession s $ \hsc_env -> do
- case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of
+ case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
where
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 913ac33a33..847d193c28 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -19,8 +19,8 @@ import Lexer ( P(..), ParseResult(..), mkPState, pragState
, lexer, Token(..), PState(..) )
import FastString
import HsSyn ( ImportDecl(..), HsModule(..) )
-import Module ( Module, mkModule )
-import PrelNames ( gHC_PRIM )
+import Module ( ModuleName, moduleName )
+import PrelNames ( gHC_PRIM, mAIN_NAME )
import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
, appendStringBuffers )
import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan )
@@ -31,12 +31,10 @@ import Util
import Outputable
import Pretty ()
import Panic
-import Bag ( unitBag, emptyBag, listToBag )
+import Bag ( emptyBag, listToBag )
import Distribution.Compiler
-import TRACE
-
import EXCEPTION ( throwDyn )
import IO
import List
@@ -55,13 +53,13 @@ openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
-- we can end up with a large number of open handles before the garbage
-- collector gets around to closing them.
getImportsFromFile :: DynFlags -> FilePath
- -> IO ([Located Module], [Located Module], Located Module)
+ -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
getImportsFromFile dflags filename = do
buf <- hGetStringBuffer filename
getImports dflags buf filename
getImports :: DynFlags -> StringBuffer -> FilePath
- -> IO ([Located Module], [Located Module], Located Module)
+ -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
getImports dflags buf filename = do
let loc = mkSrcLoc (mkFastString filename) 1 0
case unP parseHeader (mkPState buf loc dflags) of
@@ -71,10 +69,10 @@ getImports dflags buf filename = do
L _ (HsModule mod _ imps _ _) ->
let
mod_name | Just located_mod <- mod = located_mod
- | otherwise = L noSrcSpan (mkModule "Main")
+ | otherwise = L noSrcSpan mAIN_NAME
(src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
source_imps = map getImpMod src_idecls
- ordinary_imps = filter ((/= gHC_PRIM) . unLoc)
+ ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
(map getImpMod ord_idecls)
-- GHC.Prim doesn't exist physically, so don't go looking for it.
in
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 182391034c..e5b7026eb5 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -68,7 +68,6 @@ import TidyPgm ( tidyProgram, mkBootModDetails )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
-import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
@@ -87,7 +86,7 @@ import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
import FastString
-import Maybes ( expectJust )
+import UniqFM ( emptyUFM )
import Bag ( unitBag )
import Monad ( unless )
import IO
@@ -107,7 +106,8 @@ newHscEnv dflags
= do { eps_var <- newIORef initExternalPackageState
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
- ; fc_var <- newIORef emptyModuleEnv
+ ; fc_var <- newIORef emptyUFM
+ ; mlc_var <- newIORef emptyModuleEnv
; return (HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
@@ -116,6 +116,7 @@ newHscEnv dflags
hsc_EPS = eps_var,
hsc_NC = nc_var,
hsc_FC = fc_var,
+ hsc_MLC = mlc_var,
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
@@ -579,7 +580,6 @@ hscCompile cgguts
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
- cg_home_mods = home_mods,
cg_dep_pkgs = dependencies } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
@@ -595,10 +595,10 @@ hscCompile cgguts
----------------- Convert to STG ------------------
(stg_binds, cost_centre_info)
<- {-# SCC "CoreToStg" #-}
- myCoreToStg dflags home_mods this_mod prepd_binds
+ myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
abstractC <- {-# SCC "CodeGen" #-}
- codeGen dflags home_mods this_mod data_tycons
+ codeGen dflags this_mod data_tycons
foreign_stubs dir_imps cost_centre_info
stg_binds
------------------ Code output -----------------------
@@ -696,7 +696,7 @@ hscFileCheck hsc_env mod_summary = do {
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
- maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
+ maybe_cmm <- parseCmmFile dflags filename
case maybe_cmm of
Nothing -> return False
Just cmm -> do
@@ -739,13 +739,13 @@ myParseModule dflags src_filename maybe_src_buf
}}
-myCoreToStg dflags home_mods this_mod prepd_binds
+myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
- coreToStg home_mods prepd_binds
+ coreToStg (thisPackage dflags) prepd_binds
(stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
- stg2stg dflags home_mods this_mod stg_binds
+ stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
\end{code}
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e67de3bd36..a200bf99ca 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -7,7 +7,7 @@
module HscTypes (
-- * Sessions and compilation state
Session(..), HscEnv(..), hscEPS,
- FinderCache, FinderCacheEntry,
+ FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
@@ -24,10 +24,10 @@ module HscTypes (
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
- lookupIface, lookupIfaceByModule, emptyModIface,
+ lookupIfaceByModule, emptyModIface,
InteractiveContext(..), emptyInteractiveContext,
- icPrintUnqual, unQualInScope,
+ icPrintUnqual, mkPrintUnqualified,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
@@ -67,8 +67,9 @@ import ByteCodeAsm ( CompiledByteCode )
#endif
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
- LocalRdrEnv, emptyLocalRdrEnv,
- GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName )
+ LocalRdrEnv, emptyLocalRdrEnv, GlobalRdrElt(..),
+ unQualOK, ImpDeclSpec(..), Provenance(..),
+ ImportSpec(..), lookupGlobalRdrEnv )
import Name ( Name, NamedThing, getName, nameOccName, nameModule )
import NameEnv
import NameSet
@@ -85,7 +86,7 @@ import Class ( Class, classSelIds, classTyCon )
import TyCon ( TyCon, tyConSelIds, tyConDataCons )
import DataCon ( dataConImplicitIds )
import PrelNames ( gHC_PRIM )
-import Packages ( PackageIdH, PackageId, PackageConfig, HomeModules )
+import Packages ( PackageId )
import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
import BasicTypes ( Version, initialVersion, IPName,
@@ -98,6 +99,7 @@ import CoreSyn ( CoreRule )
import Maybes ( orElse, expectJust )
import Outputable
import SrcLoc ( SrcSpan, Located )
+import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString ( FastString )
@@ -172,9 +174,11 @@ data HscEnv
-- sucking in interface files. They cache the state of
-- external interface files, in effect.
- hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
+ hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
+ hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache),
-- The finder's cache. This caches the location of modules,
-- so we don't have to search the filesystem multiple times.
+
hsc_global_rdr_env :: GlobalRdrEnv,
hsc_global_type_env :: TypeEnv
}
@@ -191,7 +195,7 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
data Target = Target TargetId (Maybe (StringBuffer,ClockTime))
data TargetId
- = TargetModule Module
+ = TargetModule ModuleName
-- ^ A module name: search for the file
| TargetFile FilePath (Maybe Phase)
-- ^ A filename: preprocess & parse it to find the module name.
@@ -206,16 +210,13 @@ pprTarget (Target id _) = pprTargetId id
pprTargetId (TargetModule m) = ppr m
pprTargetId (TargetFile f _) = text f
-type FinderCache = ModuleEnv FinderCacheEntry
-type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool))
- -- The finder's cache (see module Finder)
-
-type HomePackageTable = ModuleEnv HomeModInfo
+type HomePackageTable = ModuleNameEnv HomeModInfo
-- Domain = modules in the home package
+ -- "home" package name cached here for convenience
type PackageIfaceTable = ModuleEnv ModIface
-- Domain = modules in the imported packages
-emptyHomePackageTable = emptyModuleEnv
+emptyHomePackageTable = emptyUFM
emptyPackageIfaceTable = emptyModuleEnv
data HomeModInfo
@@ -232,40 +233,37 @@ data HomeModInfo
-- When re-linking a module (hscNoRecomp), we construct
-- the HomModInfo by building a new ModDetails from the
-- old ModIface (only).
-\end{code}
-Simple lookups in the symbol table.
-
-\begin{code}
-lookupIface :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
--- We often have two IfaceTables, and want to do a lookup
-lookupIface hpt pit mod
- = case lookupModuleEnv hpt mod of
- Just mod_info -> Just (hm_iface mod_info)
- Nothing -> lookupModuleEnv pit mod
-
-lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
--- We often have two IfaceTables, and want to do a lookup
-lookupIfaceByModule hpt pit mod
- = case lookupModuleEnv hpt mod of
- Just mod_info -> Just (hm_iface mod_info)
- Nothing -> lookupModuleEnv pit mod
+-- | Find the 'ModIface' for a 'Module'
+lookupIfaceByModule
+ :: DynFlags
+ -> HomePackageTable
+ -> PackageIfaceTable
+ -> Module
+ -> Maybe ModIface
+lookupIfaceByModule dflags hpt pit mod
+ -- in one-shot, we don't use the HPT
+ | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg
+ = fmap hm_iface (lookupUFM hpt (moduleName mod))
+ | otherwise
+ = lookupModuleEnv pit mod
+ where this_pkg = thisPackage dflags
\end{code}
\begin{code}
-hptInstances :: HscEnv -> (Module -> Bool) -> [Instance]
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> [Instance]
-- Find all the instance declarations that are in modules imported
-- by this one, directly or indirectly, and are in the Home Package Table
-- This ensures that we don't see instances from modules --make compiled
-- before this one, but which are not below this one
hptInstances hsc_env want_this_module
= [ ispec
- | mod_info <- moduleEnvElts (hsc_HPT hsc_env)
- , want_this_module (mi_module (hm_iface mod_info))
+ | mod_info <- eltsUFM (hsc_HPT hsc_env)
+ , want_this_module (moduleName (mi_module (hm_iface mod_info)))
, ispec <- md_insts (hm_details mod_info) ]
-hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [CoreRule]
+hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
-- Get rules from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
hptRules hsc_env deps
@@ -283,10 +281,10 @@ hptRules hsc_env deps
-- be in the HPT, because we never compile it; it's in the EPT
-- instead. ToDo: clean up, and remove this slightly bogus
-- filter:
- , mod /= gHC_PRIM
+ , mod /= moduleName gHC_PRIM
-- Look it up in the HPT
- , let mod_info = case lookupModuleEnv hpt mod of
+ , let mod_info = case lookupUFM hpt mod of
Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps)
Just x -> x
@@ -294,6 +292,47 @@ hptRules hsc_env deps
, rule <- md_rules (hm_details mod_info) ]
\end{code}
+%************************************************************************
+%* *
+\subsection{The Finder cache}
+%* *
+%************************************************************************
+
+\begin{code}
+-- | The 'FinderCache' maps home module names to the result of
+-- searching for that module. It records the results of searching for
+-- modules along the search path. On @:load@, we flush the entire
+-- contents of this cache.
+--
+-- Although the @FinderCache@ range is 'FindResult' for convenience ,
+-- in fact it will only ever contain 'Found' or 'NotFound' entries.
+--
+type FinderCache = ModuleNameEnv FindResult
+
+-- | The result of searching for an imported module.
+data FindResult
+ = Found ModLocation Module
+ -- the module was found
+ | NoPackage PackageId
+ -- the requested package was not found
+ | FoundMultiple [PackageId]
+ -- *error*: both in multiple packages
+ | PackageHidden PackageId
+ -- for an explicit source import: the package containing the module is
+ -- not exposed.
+ | ModuleHidden PackageId
+ -- for an explicit source import: the package containing the module is
+ -- exposed, but the module itself is hidden.
+ | NotFound [FilePath]
+ -- the module was not found, the specified places were searched.
+ | NotFoundInPackage PackageId
+ -- the module was not found in this package
+
+-- | Cache that remembers where we found a particular module. Contains both
+-- home modules and package modules. On @:load@, only home modules are
+-- purged from this cache.
+type ModLocationCache = ModuleEnv ModLocation
+\end{code}
%************************************************************************
%* *
@@ -313,7 +352,6 @@ the declarations into a single indexed map in the @PersistentRenamerState@.
\begin{code}
data ModIface
= ModIface {
- mi_package :: !PackageIdH, -- Which package the module comes from
mi_module :: !Module,
mi_mod_vers :: !Version, -- Module version: changes when anything changes
@@ -408,7 +446,6 @@ data ModGuts
mg_boot :: IsBootInterface, -- Whether it's an hs-boot module
mg_exports :: !NameSet, -- What it exports
mg_deps :: !Dependencies, -- What is below it, directly or otherwise
- mg_home_mods :: !HomeModules, -- For calling isHomeModule etc.
mg_dir_imps :: ![Module], -- Directly-imported modules; used to
-- generate initialisation code
mg_usages :: ![Usage], -- Version info for what it needed
@@ -458,7 +495,6 @@ data CgGuts
-- initialisation code
cg_foreign :: !ForeignStubs,
- cg_home_mods :: !HomeModules, -- for calling isHomeModule etc.
cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen
}
@@ -489,10 +525,9 @@ data ForeignStubs = NoStubs
\end{code}
\begin{code}
-emptyModIface :: PackageIdH -> Module -> ModIface
-emptyModIface pkg mod
- = ModIface { mi_package = pkg,
- mi_module = mod,
+emptyModIface :: Module -> ModIface
+emptyModIface mod
+ = ModIface { mi_module = mod,
mi_mod_vers = initialVersion,
mi_orphan = False,
mi_boot = False,
@@ -546,25 +581,32 @@ emptyInteractiveContext
ic_type_env = emptyTypeEnv }
icPrintUnqual :: InteractiveContext -> PrintUnqualified
-icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt)
+icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt)
\end{code}
-@unQualInScope@ returns a function that takes a @Name@ and tells whether
-its unqualified name is in scope. This is put as a boolean flag in
-the @Name@'s provenance to guide whether or not to print the name qualified
-in error messages.
+%************************************************************************
+%* *
+ Building a PrintUnqualified
+%* *
+%************************************************************************
\begin{code}
-unQualInScope :: GlobalRdrEnv -> PrintUnqualified
--- True if 'f' is in scope, and has only one binding,
--- and the thing it is bound to is the name we are looking for
--- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
---
--- [Out of date] Also checks for built-in syntax, which is always 'in scope'
-unQualInScope env mod occ
- = case lookupGRE_RdrName (mkRdrUnqual occ) env of
- [gre] -> nameModule (gre_name gre) == mod
- other -> False
+mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified
+mkPrintUnqualified env = (qual_name, qual_mod)
+ where
+ qual_name mod occ
+ | null gres = Just (moduleName mod)
+ -- it isn't in scope at all, this probably shouldn't happen,
+ -- but we'll qualify it by the original module anyway.
+ | any unQualOK gres = Nothing
+ | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is
+ = Just (is_as (is_decl idecl))
+ | otherwise = panic "mkPrintUnqualified"
+ where
+ gres = [ gre | gre <- lookupGlobalRdrEnv env occ,
+ nameModule (gre_name gre) == mod ]
+
+ qual_mod mod = Nothing -- For now...
\end{code}
@@ -637,11 +679,21 @@ extendTypeEnvList env things = foldl extendTypeEnv env things
\end{code}
\begin{code}
-lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing
-lookupType hpt pte name
- = case lookupModuleEnv hpt (nameModule name) of
- Just details -> lookupNameEnv (md_types (hm_details details)) name
- Nothing -> lookupNameEnv pte name
+lookupType :: DynFlags
+ -> HomePackageTable
+ -> PackageTypeEnv
+ -> Name
+ -> Maybe TyThing
+
+lookupType dflags hpt pte name
+ -- in one-shot, we don't use the HPT
+ | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg
+ = do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad
+ lookupNameEnv (md_types (hm_details hm)) name
+ | otherwise
+ = lookupNameEnv pte name
+ where mod = nameModule name
+ this_pkg = thisPackage dflags
\end{code}
@@ -809,7 +861,7 @@ type IsBootInterface = Bool
-- Invariant: the dependencies of a module M never includes M
-- Invariant: the lists are unordered, with no duplicates
data Dependencies
- = Deps { dep_mods :: [(Module,IsBootInterface)], -- Home-package module dependencies
+ = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies
dep_pkgs :: [PackageId], -- External package dependencies
dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg)
deriving( Eq )
@@ -819,7 +871,7 @@ noDependencies :: Dependencies
noDependencies = Deps [] [] []
data Usage
- = Usage { usg_name :: Module, -- Name of the module
+ = Usage { usg_name :: ModuleName, -- Name of the module
usg_mod :: Version, -- Module version
usg_entities :: [(OccName,Version)], -- Sorted by occurrence name
usg_exports :: Maybe Version, -- Export-list version, if we depend on it
@@ -859,14 +911,16 @@ type PackageInstEnv = InstEnv
data ExternalPackageState
= EPS {
- eps_is_boot :: !(ModuleEnv (Module, IsBootInterface)),
- -- In OneShot mode (only), home-package modules accumulate in the
- -- external package state, and are sucked in lazily.
- -- For these home-pkg modules (only) we need to record which are
- -- boot modules. We set this field after loading all the
- -- explicitly-imported interfaces, but before doing anything else
+ eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),
+ -- In OneShot mode (only), home-package modules
+ -- accumulate in the external package state, and are
+ -- sucked in lazily. For these home-pkg modules
+ -- (only) we need to record which are boot modules.
+ -- We set this field after loading all the
+ -- explicitly-imported interfaces, but before doing
+ -- anything else
--
- -- The Module part is not necessary, but it's useful for
+ -- The ModuleName part is not necessary, but it's useful for
-- debug prints, and it's convenient because this field comes
-- direct from TcRnTypes.ImportAvails.imp_dep_mods
@@ -957,13 +1011,13 @@ emptyMG = []
data ModSummary
= ModSummary {
- ms_mod :: Module, -- Name of the module
+ ms_mod :: Module, -- Identity of the module
ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core
ms_location :: ModLocation, -- Location
ms_hs_date :: ClockTime, -- Timestamp of source file
ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe
- ms_srcimps :: [Located Module], -- Source imports
- ms_imps :: [Located Module], -- Non-source imports
+ ms_srcimps :: [Located ModuleName], -- Source imports
+ ms_imps :: [Located ModuleName], -- Non-source imports
ms_hspp_file :: FilePath, -- Filename of preprocessed source.
ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE
-- and LANGUAGE pragmas.
@@ -1011,7 +1065,7 @@ showModMsg target recomp mod_summary
char ')'])
where
mod = ms_mod mod_summary
- mod_str = moduleString mod ++ hscSourceString (ms_hsc_src mod_summary)
+ mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
\end{code}
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index e19a10dbc5..bfd2f34496 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -6,14 +6,21 @@ module PackageConfig (
-- * PackageId
PackageId,
mkPackageId, stringToPackageId, packageIdString, packageConfigId,
- packageIdFS, fsToPackageId,
+ packageIdFS, fsToPackageId, unpackPackageId,
-- * The PackageConfig type: information about a package
PackageConfig,
InstalledPackageInfo(..), showPackageId,
Version(..),
PackageIdentifier(..),
- defaultPackageConfig
+ defaultPackageConfig,
+
+ -- * Wired-in PackageIds
+ basePackageId,
+ rtsPackageId,
+ haskell98PackageId,
+ thPackageId,
+ mainPackageId
) where
#include "HsVersions.h"
@@ -22,6 +29,7 @@ import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
import FastString
+import Text.ParserCombinators.ReadP ( readP_to_S )
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we
@@ -66,4 +74,40 @@ mkPackageId = stringToPackageId . showPackageId
packageConfigId :: PackageConfig -> PackageId
packageConfigId = mkPackageId . package
+unpackPackageId :: PackageId -> Maybe PackageIdentifier
+unpackPackageId p
+ = case [ pid | (pid,"") <- readP_to_S parsePackageId str ] of
+ [] -> Nothing
+ (pid:_) -> Just pid
+ where str = packageIdString p
+
+-- -----------------------------------------------------------------------------
+-- Package Ids that are wired in
+
+-- Certain packages are "known" to the compiler, in that we know about certain
+-- entities that reside in these packages, and the compiler needs to
+-- declare static Modules and Names that refer to these packages. Hence
+-- the wired-in packages can't include version numbers, since we don't want
+-- to bake the version numbers of these packages into GHC.
+--
+-- So here's the plan. Wired-in packages are still versioned as
+-- normal in the packages database, and you can still have multiple
+-- versions of them installed. However, for each invocation of GHC,
+-- only a single instance of each wired-in package will be recognised
+-- (the desired one is selected via -package/-hide-package), and GHC
+-- will use the unversioned PackageId below when referring to it,
+-- including in .hi files and object file symbols. Unselected
+-- versions of wired-in packages will be ignored, as will any other
+-- package that depends directly or indirectly on it (much as if you
+-- had used -ignore-package).
+
+basePackageId = fsToPackageId FSLIT("base")
+rtsPackageId = fsToPackageId FSLIT("rts")
+haskell98PackageId = fsToPackageId FSLIT("haskell98")
+thPackageId = fsToPackageId FSLIT("template-haskell")
+
+-- This is the package Id for the program. It is the default package
+-- Id if you don't specify a package name. We don't add this prefix
+-- to symbol name, since there can be only one main package per program.
+mainPackageId = fsToPackageId FSLIT("main")
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index ae6b18863e..22494111fb 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -12,16 +12,11 @@ module Packages (
extendPackageConfigMap, dumpPackages,
-- * Reading the package config, and processing cmdline args
- PackageIdH(..), isHomePackage,
PackageState(..),
- mkPackageState,
initPackages,
getPackageDetails,
- checkForPackageConflicts,
lookupModuleInAllPackages,
- HomeModules, mkHomeModules, isHomeModule,
-
-- * Inspecting the set of packages in scope
getPackageIncludePath,
getPackageCIncludes,
@@ -48,7 +43,6 @@ import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
import UniqFM
import Module
-import FiniteMap
import UniqSet
import Util
import Maybes ( expectJust, MaybeErr(..) )
@@ -67,6 +61,7 @@ import Distribution.Package
import Distribution.Version
import System.Directory ( doesFileExist, doesDirectoryExist,
getDirectoryContents )
+import Data.Maybe ( catMaybes )
import Control.Monad ( foldM )
import Data.List ( nub, partition, sortBy, isSuffixOf )
import FastString
@@ -91,9 +86,6 @@ import ErrUtils ( debugTraceMsg, putMsg, Message )
-- Let depExposedPackages be the transitive closure from exposedPackages of
-- their dependencies.
--
--- * It is an error for any two packages in depExposedPackages to provide the
--- same module.
---
-- * When searching for a module from an explicit import declaration,
-- only the exposed modules in exposedPackages are valid.
--
@@ -109,16 +101,6 @@ import ErrUtils ( debugTraceMsg, putMsg, Message )
-- contain any Haskell modules, and therefore won't be discovered
-- by the normal mechanism of dependency tracking.
-
--- One important thing that the package state provides is a way to
--- tell, for a given module, whether it is part of the current package
--- or not. We need to know this for two reasons:
---
--- * generating cross-DLL calls is different from intra-DLL calls
--- (see below).
--- * we don't record version information in interface files for entities
--- in a different package.
---
-- Notes on DLLs
-- ~~~~~~~~~~~~~
-- When compiling module A, which imports module B, we need to
@@ -143,29 +125,13 @@ data PackageState = PackageState {
-- The exposed flags are adjusted according to -package and
-- -hide-package flags, and -ignore-package removes packages.
- moduleToPkgConfAll :: ModuleEnv [(PackageConfig,Bool)],
+ moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping
-- Derived from pkgIdMap.
-- Maps Module to (pkgconf,exposed), where pkgconf is the
-- PackageConfig for the package containing the module, and
-- exposed is True if the package exposes that module.
-
- -- The PackageIds of some known packages
- basePackageId :: PackageIdH,
- rtsPackageId :: PackageIdH,
- haskell98PackageId :: PackageIdH,
- thPackageId :: PackageIdH
}
-data PackageIdH
- = HomePackage -- The "home" package is the package curently
- -- being compiled
- | ExtPackage PackageId -- An "external" package is any other package
-
-
-isHomePackage :: PackageIdH -> Bool
-isHomePackage HomePackage = True
-isHomePackage (ExtPackage _) = False
-
-- A PackageConfigMap maps a PackageId to a PackageConfig
type PackageConfigMap = UniqFM PackageConfig
@@ -194,8 +160,7 @@ getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkg
initPackages :: DynFlags -> IO DynFlags
initPackages dflags = do
pkg_map <- readPackageConfigs dflags;
- state <- mkPackageState dflags pkg_map
- return dflags{ pkgState = state }
+ mkPackageState dflags pkg_map
-- -----------------------------------------------------------------------------
-- Reading the package database(s)
@@ -297,7 +262,7 @@ mungePackagePaths top_dir ps = map munge_pkg ps
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.
-mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState
+mkPackageState :: DynFlags -> PackageConfigMap -> IO DynFlags
mkPackageState dflags orig_pkg_db = do
--
-- Modify the package database according to the command-line flags
@@ -317,10 +282,9 @@ mkPackageState dflags orig_pkg_db = do
case pick str pkgs of
Nothing -> missingPackageErr str
Just (p,ps) -> procflags (p':ps') expl' flags
- where pkgid = packageConfigId p
- p' = p {exposed=True}
+ where p' = p {exposed=True}
ps' = hideAll (pkgName (package p)) ps
- expl' = addOneToUniqSet expl pkgid
+ expl' = package p : expl
procflags pkgs expl (HidePackage str : flags) = do
case partition (matches str) pkgs of
([],_) -> missingPackageErr str
@@ -355,7 +319,7 @@ mkPackageState dflags orig_pkg_db = do
where maybe_hide p | pkgName (package p) == name = p {exposed=False}
| otherwise = p
--
- (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) emptyUniqSet flags
+ (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) [] flags
--
-- hide all packages for which there is also a later version
-- that is already exposed. This just makes it non-fatal to have two
@@ -377,11 +341,74 @@ mkPackageState dflags orig_pkg_db = do
let pkg = package p,
pkgName pkg == myname,
pkgVersion pkg > myversion ]
- a_later_version_is_exposed
- = not (null later_versions)
pkgs2 <- mapM maybe_hide pkgs1
--
+ -- Now we must find our wired-in packages, and rename them to
+ -- their canonical names (eg. base-1.0 ==> base).
+ --
+ let
+ wired_in_pkgids = [ basePackageId,
+ rtsPackageId,
+ haskell98PackageId,
+ thPackageId ]
+
+ wired_in_names = map packageIdString wired_in_pkgids
+
+ -- find which package corresponds to each wired-in package
+ -- delete any other packages with the same name
+ -- update the package and any dependencies to point to the new
+ -- one.
+ findWiredInPackage :: [PackageConfig] -> String
+ -> IO (Maybe PackageIdentifier)
+ findWiredInPackage pkgs wired_pkg =
+ case [ p | p <- pkgs, pkgName (package p) == wired_pkg,
+ exposed p ] of
+ [] -> do
+ debugTraceMsg dflags 2 $
+ ptext SLIT("wired-in package ")
+ <> text wired_pkg
+ <> ptext SLIT(" not found.")
+ return Nothing
+ [one] -> do
+ debugTraceMsg dflags 2 $
+ ptext SLIT("wired-in package ")
+ <> text wired_pkg
+ <> ptext SLIT(" mapped to ")
+ <> text (showPackageId (package one))
+ return (Just (package one))
+ more -> do
+ throwDyn (CmdLineError (showSDoc $
+ ptext SLIT("there are multiple exposed packages that match wired-in package ") <> text wired_pkg))
+
+ mb_wired_in_ids <- mapM (findWiredInPackage pkgs2) wired_in_names
+ let
+ wired_in_ids = catMaybes mb_wired_in_ids
+
+ deleteHiddenWiredInPackages pkgs = filter ok pkgs
+ where ok p = pkgName (package p) `notElem` wired_in_names
+ || exposed p
+
+ updateWiredInDependencies pkgs = map upd_pkg pkgs
+ where upd_pkg p = p{ package = upd_pid (package p),
+ depends = map upd_pid (depends p) }
+
+ upd_pid pid = case filter (== pid) wired_in_ids of
+ [] -> pid
+ (x:_) -> x{ pkgVersion = Version [] [] }
+
+ pkgs3 = deleteHiddenWiredInPackages pkgs2
+
+ pkgs4 = updateWiredInDependencies pkgs3
+
+ explicit1 = map upd_pid explicit
+
+ -- we must return an updated thisPackage, just in case we
+ -- are actually compiling one of the wired-in packages
+ Just old_this_pkg = unpackPackageId (thisPackage dflags)
+ new_this_pkg = mkPackageId (upd_pid old_this_pkg)
+
+ --
-- Eliminate any packages which have dangling dependencies (perhaps
-- because the package was removed by -ignore-package).
--
@@ -403,41 +430,23 @@ mkPackageState dflags orig_pkg_db = do
where dangling pid = pid `notElem` all_pids
all_pids = map package pkgs
--
- pkgs <- elimDanglingDeps pkgs2
+ pkgs <- elimDanglingDeps pkgs4
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
--
-- Find the transitive closure of dependencies of exposed
--
let exposed_pkgids = [ packageConfigId p | p <- pkgs, exposed p ]
dep_exposed <- closeDeps pkg_db exposed_pkgids
- --
- -- Look up some known PackageIds
- --
let
- lookupPackageByName :: FastString -> PackageIdH
- lookupPackageByName nm =
- case [ conf | p <- dep_exposed,
- Just conf <- [lookupPackage pkg_db p],
- nm == mkFastString (pkgName (package conf)) ] of
- [] -> HomePackage
- (p:ps) -> ExtPackage (mkPackageId (package p))
-
- -- Get the PackageIds for some known packages (we know the names,
- -- but we don't know the versions). Some of these packages might
- -- not exist in the database, so they are Maybes.
- basePackageId = lookupPackageByName basePackageName
- rtsPackageId = lookupPackageByName rtsPackageName
- haskell98PackageId = lookupPackageByName haskell98PackageName
- thPackageId = lookupPackageByName thPackageName
-
-- add base & rts to the explicit packages
- basicLinkedPackages = [basePackageId,rtsPackageId]
- explicit' = addListToUniqSet explicit
- [ p | ExtPackage p <- basicLinkedPackages ]
+ basicLinkedPackages = filter (flip elemUFM pkg_db)
+ [basePackageId,rtsPackageId]
+ explicit2 = addListToUniqSet (mkUniqSet (map mkPackageId explicit1))
+ basicLinkedPackages
--
-- Close the explicit packages with their dependencies
--
- dep_explicit <- closeDeps pkg_db (uniqSetToList explicit')
+ dep_explicit <- closeDeps pkg_db (uniqSetToList explicit2)
--
-- Build up a mapping from Module -> PackageConfig for all modules.
-- Discover any conflicts at the same time, and factor in the new exposed
@@ -445,107 +454,31 @@ mkPackageState dflags orig_pkg_db = do
--
let mod_map = mkModuleMap pkg_db dep_exposed
- return PackageState{ explicitPackages = dep_explicit,
- origPkgIdMap = orig_pkg_db,
- pkgIdMap = pkg_db,
- moduleToPkgConfAll = mod_map,
- basePackageId = basePackageId,
- rtsPackageId = rtsPackageId,
- haskell98PackageId = haskell98PackageId,
- thPackageId = thPackageId
- }
+ pstate = PackageState{ explicitPackages = dep_explicit,
+ origPkgIdMap = orig_pkg_db,
+ pkgIdMap = pkg_db,
+ moduleToPkgConfAll = mod_map
+ }
+
+ return dflags{ pkgState = pstate, thisPackage = new_this_pkg }
-- done!
-basePackageName = FSLIT("base")
-rtsPackageName = FSLIT("rts")
-haskell98PackageName = FSLIT("haskell98")
-thPackageName = FSLIT("template-haskell")
- -- Template Haskell libraries in here
mkModuleMap
:: PackageConfigMap
-> [PackageId]
- -> ModuleEnv [(PackageConfig, Bool)]
+ -> UniqFM [(PackageConfig, Bool)]
mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs
where
- extend_modmap pkgname modmap =
+ extend_modmap pkgid modmap =
addListToUFM_C (++) modmap
[(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
where
- pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname)
- exposed_mods = map mkModule (exposedModules pkg)
- hidden_mods = map mkModule (hiddenModules pkg)
- all_mods = exposed_mods ++ hidden_mods
-
--- -----------------------------------------------------------------------------
--- Check for conflicts in the program.
-
--- | A conflict arises if the program contains two modules with the same
--- name, which can arise if the program depends on multiple packages that
--- expose the same module, or if the program depends on a package that
--- contains a module also present in the program (the "home package").
---
-checkForPackageConflicts
- :: DynFlags
- -> [Module] -- modules in the home package
- -> [PackageId] -- packages on which the program depends
- -> MaybeErr Message ()
-
-checkForPackageConflicts dflags mods pkgs = do
- let
- state = pkgState dflags
- pkg_db = pkgIdMap state
- --
- dep_pkgs <- closeDepsErr pkg_db pkgs
-
- let
- extend_modmap pkgname modmap =
- addListToFM_C (++) modmap
- [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
- where
- pkg = expectJust "checkForPackageConflicts"
- (lookupPackage pkg_db pkgname)
- exposed_mods = map mkModule (exposedModules pkg)
- hidden_mods = map mkModule (hiddenModules pkg)
+ pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
+ exposed_mods = map mkModuleName (exposedModules pkg)
+ hidden_mods = map mkModuleName (hiddenModules pkg)
all_mods = exposed_mods ++ hidden_mods
- mod_map = foldr extend_modmap emptyFM pkgs
- mod_map_list :: [(Module,[(PackageConfig,Bool)])]
- mod_map_list = fmToList mod_map
-
- overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ]
- --
- if not (null overlaps)
- then Failed (pkgOverlapError overlaps)
- else do
-
- let
- overlap_mods = [ (mod,pkg)
- | mod <- mods,
- Just ((pkg,_):_) <- [lookupFM mod_map mod] ]
- -- will be only one package here
- if not (null overlap_mods)
- then Failed (modOverlapError overlap_mods)
- else do
-
- return ()
-
-pkgOverlapError overlaps = vcat (map msg overlaps)
- where
- msg (mod,pkgs) =
- text "conflict: module" <+> quotes (ppr mod)
- <+> ptext SLIT("is present in multiple packages:")
- <+> hsep (punctuate comma (map pprPkg pkgs))
-
-modOverlapError overlaps = vcat (map msg overlaps)
- where
- msg (mod,pkg) = fsep [
- text "conflict: module",
- quotes (ppr mod),
- ptext SLIT("belongs to the current program/library"),
- ptext SLIT("and also to package"),
- pprPkg pkg ]
-
pprPkg :: PackageConfig -> SDoc
pprPkg p = text (showPackageId (package p))
@@ -625,9 +558,9 @@ getPackageFrameworks dflags pkgs = do
-- | Takes a Module, and if the module is in a package returns
-- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package,
-- and exposed is True if the package exposes the module.
-lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)]
+lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
lookupModuleInAllPackages dflags m =
- case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of
+ case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of
Nothing -> []
Just ps -> ps
@@ -673,24 +606,11 @@ missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
-- -----------------------------------------------------------------------------
--- The home module set
-
-newtype HomeModules = HomeModules ModuleSet
-
-mkHomeModules :: [Module] -> HomeModules
-mkHomeModules = HomeModules . mkModuleSet
-
-isHomeModule :: HomeModules -> Module -> Bool
-isHomeModule (HomeModules set) mod = elemModuleSet mod set
-
--- Determining whether a Name refers to something in another package or not.
--- Cross-package references need to be handled differently when dynamically-
--- linked libraries are involved.
-isDllName :: HomeModules -> Name -> Bool
-isDllName pdeps name
+isDllName :: PackageId -> Name -> Bool
+isDllName this_pkg name
| opt_Static = False
- | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod)
+ | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
| otherwise = False -- no, it is not even an external name
-- -----------------------------------------------------------------------------
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 370e5326d0..c0d19df90a 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -8,8 +8,7 @@ module TidyPgm( mkBootModDetails, tidyProgram ) where
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), dopt )
-import Packages ( HomeModules )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
@@ -50,6 +49,7 @@ import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
)
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
+import PackageConfig ( PackageId )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Maybe ( isJust )
@@ -238,7 +238,6 @@ tidyProgram hsc_env
mg_binds = binds,
mg_rules = imp_rules,
mg_dir_imps = dir_imps, mg_deps = deps,
- mg_home_mods = home_mods,
mg_foreign = foreign_stubs })
= do { let dflags = hsc_dflags hsc_env
@@ -257,7 +256,7 @@ tidyProgram hsc_env
-- (It's a sort of mutual recursion.)
}
- ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
@@ -285,7 +284,6 @@ tidyProgram hsc_env
cg_binds = all_tidy_binds,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
- cg_home_mods = home_mods,
cg_dep_pkgs = dep_pkgs deps },
ModDetails { md_types = tidy_type_env,
@@ -535,7 +533,6 @@ findExternalRules binds non_local_rules ext_ids
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
tidyTopBinds :: HscEnv
- -> HomeModules
-> Module
-> TypeEnv
-> IdEnv Bool -- Domain = Ids that should be external
@@ -543,7 +540,7 @@ tidyTopBinds :: HscEnv
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
-tidyTopBinds hsc_env hmods mod type_env ext_ids binds
+tidyTopBinds hsc_env mod type_env ext_ids binds
= tidy init_env binds
where
nc_var = hsc_NC hsc_env
@@ -567,13 +564,15 @@ tidyTopBinds hsc_env hmods mod type_env ext_ids binds
-- since their names are "taken".
-- The type environment is a convenient source of such things.
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+
tidy env [] = return (env, [])
- tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b
+ tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b
; (env2, bs') <- tidy env1 bs
; return (env2, b':bs') }
------------------------
-tidyTopBind :: HomeModules
+tidyTopBind :: PackageId
-> Module
-> IORef NameCache -- For allocating new unique names
-> IdEnv Bool -- Domain = Ids that should be external
@@ -581,16 +580,16 @@ tidyTopBind :: HomeModules
-> TidyEnv -> CoreBind
-> IO (TidyEnv, CoreBind)
-tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
+tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
= do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
; subst2 = extendVarEnv subst1 bndr bndr'
; tidy_env2 = (occ_env2, subst2) }
; return (tidy_env2, NonRec bndr' rhs') }
where
- caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs
+ caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
-tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
+tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
= do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
names' prs
@@ -603,7 +602,7 @@ tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
-- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do).
caf_info
- | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs)
+ | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
| (bndr,rhs) <- prs ] = MayHaveCafRefs
| otherwise = NoCafRefs
@@ -779,13 +778,13 @@ it as a CAF. In these cases however, we would need to use an additional
CAF list to keep track of non-collectable CAFs.
\begin{code}
-hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
-hasCafRefs hmods p arity expr
+hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
+hasCafRefs this_pkg p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (arity > 0 || rhsIsStatic hmods expr)
+ is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
View Lorry Controller Status