X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FFinder.lhs;h=fc945b68beb3f9dfe372f3e8decf48587c78c7ff;hb=caac75c6a454396dadff0323162ed14adb4893cd;hp=de53eee0dbeaa6f3342ab6b3d41bb15bfd5a1993;hpb=266d38920b7292bd75d959b3c2c263a2b025da17;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index de53eee..fc945b6 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -5,169 +5,199 @@ \begin{code} module Finder ( - Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation)) - newFinder, -- :: PackageConfigInfo -> IO Finder, - ModuleLocation(..), - mkHomeModuleLocn + 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 () ) where #include "HsVersions.h" -import HscTypes ( Finder, ModuleLocation(..) ) -import CmStaticInfo +import HscTypes ( ModuleLocation(..) ) +import Packages ( PackageConfig(..) ) import DriverPhases import DriverState +import DriverUtil import Module -import FiniteMap -import Util -import Panic +import FastString +import Config import IOExts -import Directory import List +import Directory import IO import Monad \end{code} 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. +compiler. For a given module, it knows (a) whether the module lives +in the home package or in another package, so it can make a Module +from a ModuleName, and (b) where the source, interface, and object +files for a module live. + +It does *not* know which particular package a module lives in, because +that information is only contained in the interface file. \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 + mode <- readIORef v_GhcMode + + let mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str + + -- 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 files only. + -- + -- When generating dependencies, we're interested in either category. + -- + source_exts = + [ ("hs", \ fName path -> mkHomeModuleLocn mod_name path fName) + , ("lhs", \ fName path -> mkHomeModuleLocn mod_name path fName) + ] + hi_exts = [ (hisuf, \ fName path -> mkHiOnlyModuleLocn mod_name fName) ] + + std_exts + | mode == DoMkDependHS = hi_exts ++ source_exts + | isCompManagerMode mode = source_exts + | otherwise = hi_exts + + -- 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 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 --- caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath))) - --- caches contents of home directories, expunged whenever we --- create a new finder. -GLOBAL_VAR(v_HomeDirCache, emptyFM, FiniteMap String FilePath) - --- caches finder mapping, expunged whenever we create a new finder. -GLOBAL_VAR(v_FinderMapCache, emptyFM, FiniteMap ModuleName Module) - - -newFinder :: PackageConfigInfo -> IO Finder -newFinder (PackageConfigInfo pkgs) = do - -- expunge our caches - writeIORef v_HomeDirCache emptyFM - writeIORef v_FinderMapCache emptyFM - - -- populate the home dir cache, using the import path (the import path - -- is changed by -i flags on the command line, and defaults to ["."]). - home_imports <- readIORef v_Import_paths - let extendFM fm path = do - contents <- getDirectoryContents' path - return (addListToFM fm (zip contents (repeat path))) - home_map <- foldM extendFM emptyFM home_imports - writeIORef v_HomeDirCache home_map - - -- populate the package cache, if necessary - pkg_cache <- readIORef v_PkgDirCache - case pkg_cache of - Nothing -> do - - let extendFM fm pkg = do - let dirs = import_dirs pkg - pkg_name = _PK_ (name pkg) - let addDir fm dir = do - contents <- getDirectoryContents' dir - return (addListToFM fm (zip contents - (repeat (pkg_name,dir)))) - foldM addDir fm dirs - - pkg_map <- foldM extendFM emptyFM pkgs - writeIORef v_PkgDirCache (Just pkg_map) - - Just _ -> - return () - - -- and return the finder - return finder - - -finder :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -finder name = do - j <- maybeHomeModule name - case j of - Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name - -maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -maybeHomeModule mod_name = do - home_cache <- readIORef v_HomeDirCache - - let basename = moduleNameString mod_name - hs = basename ++ ".hs" - lhs = basename ++ ".lhs" - - case lookupFM home_cache hs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs; - Nothing -> - - case lookupFM home_cache lhs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs; - Nothing -> return Nothing - - }} - -mkHomeModuleLocn mod_name basename source_fn = do - - -- figure out the .hi file name: it lives in the same dir as the - -- source, unless there's a -ohi flag on the command line. - ohi <- readIORef v_Output_hi hisuf <- readIORef v_Hi_suf - let hifile = case ohi of - Nothing -> basename ++ '.':hisuf - Just fn -> fn + 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 (Just (mkHomeModule mod_name, - ModuleLocation{ - hs_file = source_fn, - hi_file = hifile, - obj_file = o_file - } - )) - -maybePackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) -maybePackageModule mod_name = do - maybe_pkg_cache <- readIORef v_PkgDirCache - case maybe_pkg_cache of { - Nothing -> panic "maybePackageModule: no pkg_cache"; - Just pkg_cache -> do - - -- hi-suffix for packages depends on the build tag. + 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 basename = moduleNameString mod_name - hi = basename ++ '.':package_hisuf - - case lookupFM pkg_cache hi of - Nothing -> return Nothing - Just (pkg_name,path) -> - return (Just (mkModule mod_name pkg_name, - ModuleLocation{ - hs_file = error "package module; no source", - hi_file = hi, - obj_file = error "package module; no object" - } - )) - - } - -getDirectoryContents' d - = IO.catch (getDirectoryContents d) - (\_ -> do hPutStr stderr - ("WARNING: error while reading directory " ++ d) - return [] - ) - + let imp_dirs = concatMap import_dirs pkgs + mod_str = moduleNameUserString mod_name + basename = map (\c -> if c == '.' then '/' else c) mod_str + + retPackageModule mod_name mbFName path = + return ( mkPackageModule mod_name + , 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,\ fName path -> retPackageModule mod_name Nothing path) : + -- can packages contain hi-boots? + (if hiOnly then [] else + [ ("hs", \ fName path -> retPackageModule mod_name (Just fName) path) + , ("lhs", \ fName path -> retPackageModule mod_name (Just fName) path) + ])) + where + +findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule mod_name = findPackageMod mod_name True + +searchPathExts :: [FilePath] + -> String + -> [(String, FilePath -> String -> IO (Module, ModuleLocation))] + -> IO (Maybe (Module, ModuleLocation)) +searchPathExts path basename exts = search path + where + search [] = return Nothing + search (p:ps) = loop exts + where + base | p == "." = basename + | otherwise = p ++ '/':basename + + loop [] = search ps + loop ((ext,fn):exts) = do + let file = base ++ '.':ext + b <- doesFileExist file + if b then Just `liftM` fn file base + else loop exts \end{code}