X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=778f06dfdf3a30dec7e3c46c3dc7bef933e7177d;hb=19519dc35bad5649226a9f7015eaabb154722e54;hp=c255408fac0b41803eb3bbb3a6d7e666fd7c5392;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index c255408..778f06d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -7,28 +7,28 @@ module Finder ( flushFinderCache, -- :: IO () FindResult(..), - findModule, -- :: ModuleName -> Bool -> IO FindResult - findPackageModule, -- :: ModuleName -> Bool -> IO FindResult - mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation - findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + 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 () - hiBootExt, -- :: String - hiBootVerExt, -- :: String + findObjectLinkableMaybe, + findObjectLinkable, + cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc ) where #include "HsVersions.h" import Module import UniqFM ( filterUFM ) -import HscTypes ( Linkable(..), Unlinked(..), IfacePackage(..) ) +import HscTypes import Packages -import DriverState -import DriverUtil import FastString -import Config import Util -import CmdLineOpts ( DynFlags(..) ) +import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) +import Outputable import DATA_IOREF ( IORef, writeIORef, readIORef ) @@ -36,7 +36,13 @@ 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 +type BaseName = String -- Basename of file -- ----------------------------------------------------------------------------- -- The Finder @@ -44,31 +50,27 @@ import Data.Maybe ( isNothing ) -- 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.moduleToPackageConfig 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 +lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FinderCacheEntry) +lookupFinderCache finder_cache mod_name = do fm <- readIORef finder_cache return $! lookupModuleEnv fm mod_name @@ -86,7 +88,7 @@ lookupFinderCache mod_name = do -- that module: its source file, .hi file, object file, etc. data FindResult - = Found ModLocation IfacePackage + = Found ModLocation PackageIdH -- the module was found | PackageHidden PackageId -- for an explicit source import: the package containing the module is @@ -97,136 +99,132 @@ data FindResult | NotFound [FilePath] -- the module was not found, the specified places were searched. -findModule :: DynFlags -> Module -> Bool -> IO FindResult -findModule = cached findModule' +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) + -> HscEnv -> Module -> Bool -> IO FindResult +cached home_allowed wrapped_fn hsc_env name explicit + = do { -- First try the cache + let cache = hsc_FC hsc_env + ; mb_entry <- lookupFinderCache cache name + ; case mb_entry of { + Just old_entry -> return (found old_entry) ; + Nothing -> do + + { -- Now try the wrapped function + mb_entry <- wrapped_fn (hsc_dflags hsc_env) name + ; case mb_entry of + Failed paths -> return (NotFound paths) + Succeeded new_entry -> do { addToFinderCache cache name new_entry + ; return (found new_entry) } + }}} + where + -- 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 + +addHomeModuleToFinder :: HscEnv -> Module -> ModLocation -> IO () +addHomeModuleToFinder hsc_env mod loc + = addToFinderCache (hsc_FC hsc_env) mod (loc, Nothing) + + +-- ----------------------------------------------------------------------------- +-- The two external entry points + + +findModule :: HscEnv -> Module -> Bool -> IO FindResult +findModule = cached True findModule' -findModule' :: DynFlags -> Module -> Bool -> IO FindResult -findModule' dflags name explicit = do - j <- maybeHomeModule dflags name - case j of - NotFound home_files -> do - r <- findPackageModule' dflags name explicit - case r of - NotFound pkg_files - -> return (NotFound (home_files ++ pkg_files)) +findPackageModule :: HscEnv -> Module -> Bool -> IO FindResult +findPackageModule = cached False findPackageModule' + +-- ----------------------------------------------------------------------------- +-- 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 - -cached fn dflags name explicit = do - m <- lookupFinderCache name - case m of - Nothing -> fn dflags name explicit - Just (loc,maybe_pkg) - | Just err <- visible explicit maybe_pkg -> return err - | otherwise -> return (Found loc (pkgInfoToId maybe_pkg)) - -pkgInfoToId :: Maybe (PackageConfig,Bool) -> IfacePackage -pkgInfoToId (Just (pkg,_)) = ExternalPackage (mkPackageId (package pkg)) -pkgInfoToId Nothing = ThisPackage - --- Is a module visible or not? Returns Nothing if the import is ok, --- or Just err if there's a visibility error. -visible :: Bool -> Maybe (PackageConfig,Bool) -> Maybe FindResult -visible explicit maybe_pkg - | Nothing <- maybe_pkg = Nothing -- home module ==> YES - | not explicit = Nothing -- implicit import ==> YES - | Just (pkg, exposed_module) <- maybe_pkg - = case () of - _ | not exposed_module -> Just (ModuleHidden pkgname) - | not (exposed pkg) -> Just (PackageHidden pkgname) - | otherwise -> Nothing - where - pkgname = packageConfigId pkg - - -hiBootExt = "hi-boot" -hiBootVerExt = "hi-boot-" ++ cHscIfaceFileVersion + other_result + -> return other_result -maybeHomeModule :: DynFlags -> Module -> IO FindResult -maybeHomeModule dflags mod = do +findHomeModule' :: DynFlags -> Module -> IO LocalFindResult +findHomeModule' dflags mod = do let home_path = importPaths dflags - hisuf <- readIORef v_Hi_suf - mode <- readIORef v_GhcMode + hisuf = hiSuf dflags let source_exts = - [ ("hs", mkHomeModLocationSearched mod) - , ("lhs", mkHomeModLocationSearched mod) + [ ("hs", mkHomeModLocationSearched dflags mod "hs") + , ("lhs", mkHomeModLocationSearched dflags mod "lhs") ] - hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod) ] + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] - boot_exts = - [ (hiBootVerExt, mkHiOnlyModLocation hisuf mod) - , (hiBootExt, mkHiOnlyModLocation hisuf mod) - ] - -- 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. - -- - -- When generating dependencies, we're interested in either category. - -- - exts - | mode == DoMkDependHS = hi_exts ++ source_exts ++ boot_exts - | isCompManagerMode mode = source_exts - | otherwise {-one-shot-} = hi_exts ++ boot_exts + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts searchPathExts home_path mod exts --- ----------------------------------------------------------------------------- --- Looking for a package module - -findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult -findPackageModule = cached findPackageModule' - -findPackageModule' :: DynFlags -> Module -> Bool -> IO FindResult -findPackageModule' dflags mod explicit = do - mode <- readIORef v_GhcMode - - case moduleToPackageConfig dflags mod of - Nothing -> return (NotFound []) - pkg_info@(Just (pkg_conf, module_exposed)) - | Just err <- visible explicit pkg_info -> return err - | otherwise -> findPackageIface mode mod paths pkg_info - where - paths = importDirs pkg_conf - -findPackageIface - :: GhcMode - -> Module - -> [FilePath] - -> Maybe (PackageConfig,Bool) - -> IO FindResult -findPackageIface mode mod imp_dirs pkg_info = do - -- 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") - +findPackageModule' :: DynFlags -> Module -> IO LocalFindResult +findPackageModule' dflags mod + = case moduleToPackageConfig dflags mod of + Nothing -> return (Failed []) + Just pkg_info -> findPackageIface dflags mod pkg_info + +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 pkg_info package_hisuf mod) ] + mkPackageModLocation dflags pkg_info package_hisuf) ] source_exts = - [ ("hs", mkPackageModLocation pkg_info package_hisuf mod) - , ("lhs", mkPackageModLocation pkg_info package_hisuf mod) + [ ("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 - | mode == DoMkDependHS = hi_exts ++ source_exts - | otherwise = hi_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 imp_dirs mod exts + + searchPathExts (importDirs pkg_conf) mod exts -- ----------------------------------------------------------------------------- -- General path searching @@ -235,59 +233,60 @@ searchPathExts :: [FilePath] -- paths to search -> Module -- module name -> [ ( - String, -- suffix - String -> String -> String -> IO FindResult -- action + FileExt, -- suffix + FilePath -> BaseName -> IO FinderCacheEntry -- action ) ] - -> IO FindResult + -> IO LocalFindResult + +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 path mod exts = search to_search where basename = dots_to_slashes (moduleUserString mod) - to_search :: [(FilePath, IO FindResult)] - to_search = [ (file, fn p basename ext) - | p <- path, + to_search :: [(FilePath, IO FinderCacheEntry)] + to_search = [ (file, fn path basename) + | path <- paths, (ext,fn) <- exts, - let base | p == "." = basename - | otherwise = p ++ '/':basename + let base | path == "." = basename + | otherwise = path ++ '/':basename file = base ++ '.':ext ] - search [] = return (NotFound (map fst to_search)) - search ((file, result) : rest) = do + search [] = return (Failed (map fst to_search)) + search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then result + then do { res <- mk_result; return (Succeeded res) } else search rest --- ----------------------------------------------------------------------------- --- Building ModLocations +mkHomeModLocationSearched :: DynFlags -> Module -> FileExt + -> FilePath -> BaseName -> IO FinderCacheEntry +mkHomeModLocationSearched dflags mod suff path basename = do + loc <- mkHomeModLocation2 dflags mod (path ++ '/':basename) suff + return (loc, Nothing) -mkHiOnlyModLocation hisuf mod path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod) - loc <- hiOnlyModLocation path basename hisuf - addToFinderCache mod (loc, Nothing) - return (Found loc ThisPackage) +mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName + -> IO FinderCacheEntry +mkHiOnlyModLocation dflags hisuf path basename = do + loc <- hiOnlyModLocation dflags path basename hisuf + return (loc, Nothing) -mkPackageModLocation pkg_info hisuf mod path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod) - loc <- hiOnlyModLocation path basename hisuf - addToFinderCache mod (loc, pkg_info) - return (Found loc (pkgInfoToId pkg_info)) - -hiOnlyModLocation path basename hisuf - = do let full_basename = path++'/':basename - obj_fn <- mkObjPath full_basename basename - return ModLocation{ ml_hspp_file = Nothing, - ml_hs_file = Nothing, - ml_hi_file = full_basename ++ '.':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 - } +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 @@ -322,80 +321,129 @@ hiOnlyModLocation path basename hisuf -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation mod src_filename = do +mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do let (basename,extension) = splitFilename src_filename - mkHomeModLocation' mod basename extension - -mkHomeModLocationSearched mod path basename ext = do - loc <- mkHomeModLocation' mod (path ++ '/':basename) ext - return (Found loc ThisPackage) - -mkHomeModLocation' mod src_basename ext = do + 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 (moduleUserString mod) - obj_fn <- mkObjPath src_basename mod_basename - hi_fn <- mkHiPath src_basename mod_basename + obj_fn <- mkObjPath dflags src_basename mod_basename + hi_fn <- mkHiPath dflags src_basename mod_basename - let loc = ModLocation{ ml_hspp_file = Nothing, - ml_hs_file = Just (src_basename ++ '.':ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn } + return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) - addToFinderCache mod (loc, Nothing) - return loc +hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation +hiOnlyModLocation dflags path basename hisuf + = do let full_basename = path++'/':basename + obj_fn <- mkObjPath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename ++ '.':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 - :: FilePath -- the filename of the source file, minus the extension + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes -> IO FilePath -mkObjPath basename mod_basename - = do odir <- readIORef v_Output_dir - osuf <- readIORef v_Object_suf - - let obj_basename | Just dir <- odir = dir ++ '/':mod_basename - | otherwise = basename +mkObjPath dflags basename mod_basename + = do let + odir = outputDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir ++ '/':mod_basename + | otherwise = basename return (obj_basename ++ '.':osuf) -- | Constructs the filename of a .hi file for a given source file. -- Does /not/ check whether the .hi file exists mkHiPath - :: FilePath -- the filename of the source file, minus the extension + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension -> String -- the module name with dots replaced by slashes -> IO FilePath -mkHiPath basename mod_basename - = do hidir <- readIORef v_Hi_dir - hisuf <- readIORef v_Hi_suf +mkHiPath dflags basename mod_basename + = do let + hidir = hiDir dflags + hisuf = hiSuf dflags - let hi_basename | Just dir <- hidir = dir ++ '/':mod_basename - | otherwise = basename + hi_basename | Just dir <- hidir = dir ++ '/':mod_basename + | otherwise = basename return (hi_basename ++ '.':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 dots_to_slashes = map (\c -> if c == '.' then '/' else c) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cantFindError :: DynFlags -> Module -> FindResult -> SDoc +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)) + + Found _ _ -> panic "cantFindErr" \end{code}