X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=fbde40f6ea261823652d8bd6b4fdc0a93dd6d6bc;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=83cf28c8f04ad9c48e369b2c17a843cc3b18c07d;hpb=c34157eadadf46a81b0ab7943da28748921b30ba;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 83cf28c..fbde40f 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,194 +5,495 @@ \begin{code} module Finder ( - initFinder, -- :: [PackageConfig] -> IO (), - findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) - findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath - -- -> IO ModuleLocation - emptyHomeDirCache, -- :: IO () - flushPackageCache -- :: [PackageConfig] -> IO () + flushFinderCache, -- :: IO () + 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 () + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc ) where #include "HsVersions.h" -import HscTypes ( ModuleLocation(..) ) -import Packages ( PackageConfig(..) ) -import DriverPhases -import DriverState -import DriverUtil import Module +import UniqFM ( filterUFM, delFromUFM ) +import HscTypes +import Packages import FastString -import Config +import Util +import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) +import Outputable +import Maybes ( expectJust ) -import IOExts -import List -import Directory -import IO -import Monad -\end{code} +import DATA_IOREF ( IORef, writeIORef, readIORef ) -The Finder provides a thin filesystem abstraction to the rest of the -compiler. For a given module, it knows (a) which package the module -lives in, so it can make a Module from a ModuleName, and (b) where the -source, interface, and object files for a module live. +import Data.List +import System.Directory +import System.IO +import Control.Monad +import Data.Maybe ( isNothing ) +import Time ( ClockTime ) + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllPackages for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- 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 + +-- ----------------------------------------------------------------------------- +-- 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 -\begin{code} -initFinder :: [PackageConfig] -> IO () -initFinder pkgs = return () - --- empty, and lazilly fill in the package cache -flushPackageCache :: [PackageConfig] -> IO () -flushPackageCache pkgs = return () - -emptyHomeDirCache :: IO () -emptyHomeDirCache = return () - -findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findModule name = findModuleDep name False - -findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) -findModuleDep name is_source - = do { j <- maybeHomeModule name is_source - ; case j of - Just home_module -> return (Just home_module) - Nothing -> findPackageMod name False - } - -maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) -maybeHomeModule mod_name is_source = do - home_path <- readIORef v_Import_paths - hisuf <- readIORef v_Hi_suf - - let mod_str = moduleNameUserString mod_name - basename = map (\c -> if c == '.' then '/' else c) mod_str - - std_exts = - [ ("hs", \ _ fName path -> mkHomeModuleLocn mod_name path fName) - , ("lhs", \ _ fName path -> mkHomeModuleLocn mod_name path fName) - , (hisuf, \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) - ] - -- look for the .hi file last, because if there's a source file about - -- we want to find it. - - -- last chance: .hi-boot- and .hi-boot - hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion - - boot_exts = - [ (hi_boot_ver, \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) - , ("hi-boot", \ _ fName path -> mkHiOnlyModuleLocn mod_name fName) - ] - - searchPathExts - (map ((,) undefined) home_path) - basename - (if is_source then (boot_exts++std_exts) else std_exts ++ boot_exts) - -- for SOURCE imports, check the hi-boot extensions - -- before the source/iface ones, to avoid - -- creating circ Makefile deps. - -mkHiOnlyModuleLocn mod_name hi_file = - return - ( mkHomeModule mod_name - , ModuleLocation{ ml_hspp_file = Nothing - , ml_hs_file = Nothing - , ml_hi_file = hi_file - , ml_obj_file = Nothing - } - ) - --- The .hi file always follows the module name, whereas the object --- file may follow the name of the source file in the case where the --- two differ (see summariseFile in compMan/CompManager.lhs). - -mkHomeModuleLocn mod_name - basename -- everything but the extension - source_fn -- full path to the source (required) - = do - - hisuf <- readIORef v_Hi_suf - hidir <- readIORef v_Hi_dir - - -- take the *last* component of the module name (if a hierarchical name), - -- and append it to the directory to get the .hi file name. - let (_,mod_str) = split_longest_prefix (moduleNameUserString mod_name) (=='.') - hi_filename = mod_str ++ '.':hisuf - hi_path | Just d <- hidir = d - | otherwise = getdir basename - hi = hi_path ++ '/':hi_filename - - -- figure out the .o file name. It also lives in the same dir - -- as the source, but can be overriden by a -odir flag. - o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify - - return (mkHomeModule mod_name, - ModuleLocation{ ml_hspp_file = Nothing - , ml_hs_file = Just source_fn - , ml_hi_file = hi - , ml_obj_file = Just o_file - }) - -findPackageMod :: ModuleName - -> Bool - -> IO (Maybe (Module, ModuleLocation)) -findPackageMod mod_name hiOnly = do - pkgs <- getPackageInfo - - -- hi-suffix for packages depends on the build tag. - package_hisuf <- - do tag <- readIORef v_Build_tag - if null tag - then return "hi" - else return (tag ++ "_hi") - let imp_dirs = concatMap (\ pkg -> map ((,) pkg) (import_dirs pkg)) pkgs - mod_str = moduleNameUserString mod_name - basename = map (\c -> if c == '.' then '/' else c) mod_str - - mkPackageModule mod_name pkg mbFName path = - return ( mkModule mod_name (mkFastString (name pkg)) - , ModuleLocation{ ml_hspp_file = Nothing - , ml_hs_file = mbFName - , ml_hi_file = path ++ '.':package_hisuf - , ml_obj_file = Nothing - }) - - searchPathExts - imp_dirs basename - ((package_hisuf,\ pkg fName path -> mkPackageModule mod_name pkg Nothing path) : - -- can packages contain hi-boots? - (if hiOnly then [] else - [ ("hs", \ pkg fName path -> mkPackageModule mod_name pkg (Just fName) path) - , ("lhs", \ pkg fName path -> mkPackageModule mod_name pkg (Just fName) path) - ])) 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 + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule' :: DynFlags -> Module -> IO LocalFindResult +findHomeModule' dflags mod = do + let home_path = importPaths dflags + hisuf = hiSuf dflags + + let + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod "hs") + , ("lhs", mkHomeModLocationSearched dflags mod "lhs") + ] + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + + 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 + let + 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) ] + + source_exts = + [ ("hs", mkPackageModLocation dflags pkg_info package_hisuf) + , ("lhs", mkPackageModLocation dflags pkg_info package_hisuf) + ] + + -- mkdependHS needs to look for source files in packages too, so + -- that we can make dependencies between package before they have + -- been built. + exts + | MkDepend <- ghcMode dflags = hi_exts ++ source_exts + | 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. + + searchPathExts (importDirs pkg_conf) mod exts + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> Module -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO FinderCacheEntry -- action + ) + ] + -> IO LocalFindResult -findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -findPackageModule mod_name = findPackageMod mod_name True +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result -searchPathExts :: [(a, FilePath)] - -> String - -> [(String, a -> FilePath -> String -> IO (Module, ModuleLocation))] - -> IO (Maybe (Module, ModuleLocation)) -searchPathExts path basename exts = search exts where - search [] = return Nothing - search ((x,f):xs) = do - let fName = (basename ++ '.':x) - found <- findOnPath path fName - case found of - -- special case to avoid getting "./foo." all the time - Just (v,".") -> fmap Just (f v fName basename) - Just (v,path) -> fmap Just (f v (path ++ '/':fName) - (path ++ '/':basename)) - Nothing -> search xs - -findOnPath :: [(a,String)] -> String -> IO (Maybe (a, FilePath)) -findOnPath path s = loop path - where - loop [] = return Nothing - loop ((a,d):ds) = do - let file = d ++ '/':s - b <- doesFileExist file - if b then return (Just (a,d)) else loop ds + basename = dots_to_slashes (moduleString mod) + + to_search :: [(FilePath, IO FinderCacheEntry)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path `joinFileName` basename + file = base `joinFileExt` ext + ] + + search [] = return (CantFindAmongst (map fst to_search)) + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + 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 `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) + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): dots_to_slashes (moduleNameUserString mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitFilename src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> Module + -> 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) + + obj_fn <- mkObjPath dflags src_basename mod_basename + hi_fn <- mkHiPath dflags src_basename mod_basename + + 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 `joinFileName` basename + obj_fn <- mkObjPath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + 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 + -- in the ml_hi_file field. + ml_obj_file = obj_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> IO FilePath +mkObjPath dflags basename mod_basename + = do let + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir `joinFileName` mod_basename + | otherwise = basename + + 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 +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> IO FilePath +mkHiPath dflags basename mod_basename + = do let + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir `joinFileName` mod_basename + | otherwise = basename + + return (hi_basename `joinFileExt` hisuf) + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> Module + -> ModLocation + -> (FilePath,FilePath) + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = dots_to_slashes (moduleString mod) + src_basename = basenameOf (expectJust "mkStubPaths" + (ml_hs_file location)) + + stub_basename0 + | Just dir <- stubdir = dir `joinFileName` mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + (stub_basename `joinFileExt` "c", + stub_basename `joinFileExt` "h") + -- the _stub.o filename is derived from the ml_obj_file. + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + 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 + +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 + where + more_info + = case find_result of + PackageHidden pkg + -> ptext SLIT("it is a member of package") <+> ppr pkg <> comma + <+> ptext SLIT("which is hidden") + + ModuleHidden pkg + -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package") + <+> ppr pkg) + + NotFound files + | null files + -> ptext SLIT("it is not a module in the current program, or in any known package.") + | verbosity dflags < 3 + -> ptext SLIT("use -v to see a list of the files searched for") + | otherwise + -> hang (ptext SLIT("locations searched:")) + 2 (vcat (map text files)) + + _ -> panic "cantFindErr" \end{code}