diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 16 | ||||
| -rw-r--r-- | compiler/main/DriverMkDepend.hs | 29 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 56 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 25 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 404 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 265 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 16 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 20 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 208 | ||||
| -rw-r--r-- | compiler/main/PackageConfig.hs | 48 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 270 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 31 |
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 |