X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=f8f51da55f712a0e59641c916f312c547d8ab167;hb=e8f2142d81b97d8460f63ea0becf54a408b876b4;hp=97904a1093e927cc3728662138071502dcf60526;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 97904a1..f8f51da 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -11,9 +11,11 @@ module Finder ( findPackageModule, -- :: ModuleName -> Bool -> IO FindResult mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation - addHomeModuleToFinder, -- :: Module -> ModLocation -> IO () + addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () + uncacheModule, -- :: HscEnv -> Module -> IO () - findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + findObjectLinkableMaybe, + findObjectLinkable, cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc ) where @@ -21,8 +23,8 @@ module Finder ( #include "HsVersions.h" import Module -import UniqFM ( filterUFM ) -import HscTypes ( Linkable(..), Unlinked(..) ) +import UniqFM ( filterUFM, delFromUFM ) +import HscTypes import Packages import FastString import Util @@ -35,8 +37,8 @@ import Data.List import System.Directory import System.IO import Control.Monad -import Maybes ( MaybeErr(..) ) import Data.Maybe ( isNothing ) +import Time ( ClockTime ) type FileExt = String -- Filename extension @@ -50,34 +52,35 @@ type BaseName = String -- Basename of file -- source, interface, and object files for that module live. -- It does *not* know which particular package a module lives in. Use --- Packages.moduleToPackageConfig for that. +-- Packages.lookupModuleInAllPackages for that. -- ----------------------------------------------------------------------------- -- The finder's cache -GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv FinderCacheEntry) - -type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) - -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session. -flushFinderCache :: IO () -flushFinderCache = do +flushFinderCache :: IORef FinderCache -> IO () +flushFinderCache finder_cache = do fm <- readIORef finder_cache - writeIORef finder_cache (filterUFM (\(loc,m) -> isNothing m) fm) + writeIORef finder_cache $! filterUFM (\(loc,m) -> isNothing m) fm -addToFinderCache :: Module -> FinderCacheEntry -> IO () -addToFinderCache mod_name entry = do +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) + writeIORef finder_cache $! extendModuleEnv fm mod_name entry -lookupFinderCache :: Module -> IO (Maybe FinderCacheEntry) -lookupFinderCache mod_name = do +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 -- ----------------------------------------------------------------------------- --- Locating modules +-- The two external entry points -- This is the main interface to the finder, which maps ModuleNames to -- Modules and ModLocations. @@ -92,6 +95,8 @@ lookupFinderCache mod_name = do 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. @@ -101,74 +106,81 @@ data FindResult | NotFound [FilePath] -- the module was not found, the specified places were searched. -type LocalFindResult = MaybeErr [FilePath] FinderCacheEntry - -- LocalFindResult is used for internal functions which - -- return a more informative type; it's munged into - -- the external FindResult by 'cached' - -cached :: Bool - -> (DynFlags -> Module -> IO LocalFindResult) - -> DynFlags -> Module -> Bool -> IO FindResult -cached home_allowed wrapped_fn dflags name explicit - = do { -- First try the cache - mb_entry <- lookupFinderCache name - ; case mb_entry of { - Just old_entry -> return (found old_entry) ; - Nothing -> do - - { -- Now try the wrapped function - mb_entry <- wrapped_fn dflags name - ; case mb_entry of - Failed paths -> return (NotFound paths) - Succeeded new_entry -> do { addToFinderCache name new_entry - ; return (found new_entry) } - }}} - where +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 + + 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) + found :: FinderCacheEntry -> FindResult + found (loc, Nothing) | home_allowed = Found loc HomePackage | otherwise = NotFound [] - found (loc, Just (pkg, exposed_mod)) + 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))) + | otherwise = + Found loc (ExtPackage (mkPackageId (package pkg))) where pkg_name = packageConfigId pkg -addHomeModuleToFinder :: Module -> ModLocation -> IO () -addHomeModuleToFinder mod loc = addToFinderCache mod (loc, Nothing) - - --- ----------------------------------------------------------------------------- --- The two external entry points - - -findModule :: DynFlags -> Module -> Bool -> IO FindResult -findModule = cached True findModule' - -findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult -findPackageModule = cached False findPackageModule' + 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 -- ----------------------------------------------------------------------------- -- The internal workers -findModule' :: DynFlags -> Module -> IO LocalFindResult --- Find home or package module -findModule' dflags name = do - r <- findPackageModule' dflags name - case r of - Failed pkg_files -> do - j <- findHomeModule' dflags name - case j of - Failed home_files -> - return (Failed (home_files ++ pkg_files)) - other_result - -> return other_result - other_result - -> return other_result - findHomeModule' :: DynFlags -> Module -> IO LocalFindResult findHomeModule' dflags mod = do let home_path = importPaths dflags @@ -194,9 +206,10 @@ findHomeModule' dflags mod = do findPackageModule' :: DynFlags -> Module -> IO LocalFindResult findPackageModule' dflags mod - = case moduleToPackageConfig dflags mod of - Nothing -> return (Failed []) - Just pkg_info -> findPackageIface dflags mod pkg_info + = 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 @@ -259,21 +272,21 @@ searchPathExts paths mod exts | path <- paths, (ext,fn) <- exts, let base | path == "." = basename - | otherwise = path ++ '/':basename - file = base ++ '.':ext + | otherwise = path `joinFileName` basename + file = base `joinFileExt` ext ] - search [] = return (Failed (map fst to_search)) + search [] = return (CantFindAmongst (map fst to_search)) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { res <- mk_result; return (Succeeded res) } + then do { res <- mk_result; return (Ok res) } else search rest mkHomeModLocationSearched :: DynFlags -> Module -> FileExt -> FilePath -> BaseName -> IO FinderCacheEntry mkHomeModLocationSearched dflags mod suff path basename = do - loc <- mkHomeModLocation2 dflags mod (path ++ '/':basename) suff + loc <- mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff return (loc, Nothing) mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName @@ -337,16 +350,16 @@ mkHomeModLocation2 dflags mod src_basename ext = do obj_fn <- mkObjPath dflags src_basename mod_basename hi_fn <- mkHiPath dflags src_basename mod_basename - return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext), + return (ModLocation{ ml_hs_file = Just (src_basename `joinFileExt` ext), ml_hi_file = hi_fn, ml_obj_file = obj_fn }) hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation hiOnlyModLocation dflags path basename hisuf - = do let full_basename = path++'/':basename + = do let full_basename = path `joinFileName` basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename ++ '.':hisuf, + ml_hi_file = full_basename `joinFileExt` hisuf, -- Remove the .hi-boot suffix from -- hi_file, if it had one. We always -- want the name of the real .hi file @@ -366,10 +379,10 @@ mkObjPath dflags basename mod_basename odir = outputDir dflags osuf = objectSuf dflags - obj_basename | Just dir <- odir = dir ++ '/':mod_basename + obj_basename | Just dir <- odir = dir `joinFileName` mod_basename | otherwise = basename - return (obj_basename ++ '.':osuf) + return (obj_basename `joinFileExt` osuf) -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists @@ -383,30 +396,34 @@ mkHiPath dflags basename mod_basename hidir = hiDir dflags hisuf = hiSuf dflags - hi_basename | Just dir <- hidir = dir ++ '/':mod_basename + hi_basename | Just dir <- hidir = dir `joinFileName` mod_basename | otherwise = basename - return (hi_basename ++ '.':hisuf) + return (hi_basename `joinFileExt` hisuf) -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it -findLinkable :: Module -> ModLocation -> IO (Maybe Linkable) -findLinkable mod locn +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - obj_exist <- doesFileExist obj_fn - if not obj_exist - then return Nothing - else - do let stub_fn = case splitFilename3 obj_fn of - (dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o" - stub_exist <- doesFileExist stub_fn - obj_time <- getModificationTime obj_fn - if stub_exist - then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) - else return (Just (LM obj_time mod [DotO obj_fn])) + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = do + let stub_fn = case splitFilename3 obj_fn of + (dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o" + stub_exist <- doesFileExist stub_fn + if stub_exist + then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) + else return (LM obj_time mod [DotO obj_fn]) -- ----------------------------------------------------------------------------- -- Utils @@ -418,6 +435,11 @@ dots_to_slashes = map (\c -> if c == '.' then '/' else c) -- Error messages cantFindError :: DynFlags -> Module -> 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:"), + hsep (map (text.packageIdString) pkgs)] + ) cantFindError dflags mod_name find_result = hang (ptext SLIT("Could not find module") <+> quotes (ppr mod_name) <> colon) 2 more_info @@ -441,5 +463,5 @@ cantFindError dflags mod_name find_result -> hang (ptext SLIT("locations searched:")) 2 (vcat (map text files)) - Found _ _ -> panic "cantFindErr" + _ -> panic "cantFindErr" \end{code}