Commit 06575d67 authored by simonmar's avatar simonmar

[project @ 2002-10-17 14:26:16 by simonmar]

Finder overhaul.

The finder had got pretty complicated; this commit is mainly a
cleanup, with one new feature:

  - the finder has a cache (again).  The cache may be flushed by
    calling flushFinderCache, which actually only flushes home modules
    from the cache, because package modules are assumed not to move.
    This change is apropos of some other changes which will result in
    the finder being called more often, so we think a cache is going
    to be worthwhile.

Also a couple of bugs were fixed:

  - the field ml_hi_file in a ModLocation is now *always* the name
    of the .hi file.  If you need a .hi-boot file, you have to make
    it up by changing the suffix of ml_hi_file.  (DriverMkDepend and
    RnHiFiles do this).  This was the cause of a bug, but I can't
    remember the details.

  - The -odir flag now works in a more reasonable way: hierarchical
    modules get put in subdirectories of the -odir directory.  eg.
    if your module is A.B.C, and -odir D is specified, then the object
    will be D/A/B/C.o; previously it would have been D/C.o.
parent 7370adc0
......@@ -455,7 +455,7 @@ cmCompileExpr cmstate dflags expr
cmUnload :: CmState -> DynFlags -> IO CmState
cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags
= do -- Throw away the old home dir cache
emptyHomeDirCache
flushFinderCache
-- Unload everything the linker knows about
cm_unload mode dflags []
......@@ -1224,12 +1224,12 @@ summariseFile file
= do hspp_fn <- preprocess file
(srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
let (path, basename, _ext) = splitFilename3 file
let (path, basename, ext) = splitFilename3 file
-- GHC.Prim doesn't exist physically, so don't go looking for it.
the_imps = filter (/= gHC_PRIM_Name) imps
(mod, location)
<- mkHomeModuleLocn mod_name (path ++ '/':basename) file
(mod, location) <- mkHomeModLocation mod_name True{-is a root-}
path basename ext
src_timestamp
<- case ml_hs_file location of
......
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.104 2002/10/13 10:55:06 wolfgang Exp $
-- $Id: DriverFlags.hs,v 1.105 2002/10/17 14:26:17 simonmar Exp $
--
-- Driver flags
--
......@@ -229,7 +229,7 @@ static_flags =
------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
, ( "o" , SepArg (writeIORef v_Output_file . Just) )
, ( "osuf" , HasArg (writeIORef v_Object_suf . Just) )
, ( "osuf" , HasArg (writeIORef v_Object_suf) )
, ( "hcsuf" , HasArg (writeIORef v_HC_suf . Just) )
, ( "hisuf" , HasArg (writeIORef v_Hi_suf) )
, ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) )
......
-----------------------------------------------------------------------------
-- $Id: DriverMkDepend.hs,v 1.24 2002/10/09 15:03:52 simonpj Exp $
-- $Id: DriverMkDepend.hs,v 1.25 2002/10/17 14:26:18 simonmar Exp $
--
-- GHC Driver
--
......@@ -12,13 +12,13 @@ module DriverMkDepend where
#include "HsVersions.h"
import DriverState
import DriverUtil ( add, softGetDirectoryContents )
import DriverUtil ( add, softGetDirectoryContents, replaceFilenameSuffix )
import DriverFlags
import SysTools ( newTempName )
import qualified SysTools
import Module ( ModuleName, ModLocation(..),
moduleNameUserString, isHomeModule )
import Finder ( findModuleDep )
import Finder ( findModule, hiBootExt, hiBootVerExt )
import Util ( global )
import Panic
......@@ -171,13 +171,33 @@ findDependency is_source src imp = do
if imp_mod `elem` excl_mods
then return Nothing
else do
r <- findModuleDep imp is_source
r <- findModule imp
case r of
Just (mod,loc)
| isHomeModule mod || include_prelude
-- not in this package: we don't need a dependency
| not (isHomeModule mod) && not include_prelude
-> return Nothing
-- normal import: just depend on the .hi file
| not is_source
-> return (Just (ml_hi_file loc, not is_source))
-- if it's a source import, we want to generate a dependency
-- on the .hi-boot file, not the .hi file
| otherwise
-> return Nothing
-> let hi_file = ml_hi_file loc
boot_hi_file = replaceFilenameSuffix hi_file hiBootExt
boot_ver_hi_file = replaceFilenameSuffix hi_file hiBootVerExt
in do
b <- doesFileExist boot_hi_file
if b
then return (Just (boot_hi_file, not is_source))
else do
b <- doesFileExist boot_ver_hi_file
if b
then return (Just (boot_ver_hi_file, not is_source))
else return (Just (hi_file, not is_source))
Nothing -> throwDyn (ProgramError
(src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'" ++
if is_source then " (SOURCE import)" else ""))
......@@ -461,9 +461,9 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
++ filename ++ "'" ++ show pipeline ++ show stop_phase)))
let
-- .o and .hc suffixes can be overriden by command-line options:
myPhaseInputExt Ln | Just s <- osuf = s
myPhaseInputExt HCc | Just s <- hcsuf = s
myPhaseInputExt other = phaseInputExt other
myPhaseInputExt Ln = osuf
myPhaseInputExt other = phaseInputExt other
annotatePipeline
:: [Phase] -- raw pipeline
......@@ -687,10 +687,7 @@ run_phase MkDependHS basename suff input_fn output_fn
deps_normals <- mapM (findDependency False orig_fn) import_normals
let deps = deps_sources ++ deps_normals
osuf_opt <- readIORef v_Object_suf
let osuf = case osuf_opt of
Nothing -> phaseInputExt Ln
Just s -> s
osuf <- readIORef v_Object_suf
extra_suffixes <- readIORef v_Dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
......@@ -749,7 +746,7 @@ run_phase Hsc basename suff input_fn output_fn
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the import path, since this is
-- what gcc does, and it's probably what you want.
let current_dir = getdir basename
let current_dir = directoryOf basename
paths <- readIORef v_Include_paths
writeIORef v_Include_paths (current_dir : paths)
......@@ -779,8 +776,8 @@ run_phase Hsc basename suff input_fn output_fn
getImportsFromFile input_fn
-- build a ModLocation to pass to hscMain.
(mod, location')
<- mkHomeModuleLocn mod_name basename (basename ++ '.':suff)
let (path,file) = splitFilenameDir basename
(mod, location') <- mkHomeModLocation mod_name True path file suff
-- take -ohi into account if present
ohi <- readIORef v_Output_hi
......@@ -993,8 +990,9 @@ run_phase SplitAs basename _suff _input_fn output_fn
let assemble_file n
= do let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
let output_o = newdir real_odir
let output_o = replaceFilenameDirectory
(basename ++ "__" ++ show n ++ ".o")
real_odir
real_o <- osuf_ify output_o
SysTools.runAs (map SysTools.Option as_opts ++
[ SysTools.Option "-c"
......
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.82 2002/09/13 15:02:34 simonpj Exp $
-- $Id: DriverState.hs,v 1.83 2002/10/17 14:26:18 simonmar Exp $
--
-- Settings for the driver
--
......@@ -161,7 +161,7 @@ verifyOutputFiles = do
show dir ++ " does not exist (used with " ++
show flg ++ " option.)"))
GLOBAL_VAR(v_Object_suf, Nothing, Maybe String)
GLOBAL_VAR(v_Object_suf, phaseInputExt Ln, String)
GLOBAL_VAR(v_HC_suf, Nothing, Maybe String)
GLOBAL_VAR(v_Hi_dir, Nothing, Maybe String)
GLOBAL_VAR(v_Hi_suf, "hi", String)
......@@ -173,14 +173,12 @@ odir_ify f = do
odir_opt <- readIORef v_Output_dir
case odir_opt of
Nothing -> return f
Just d -> return (newdir d f)
Just d -> return (replaceFilenameDirectory f d)
osuf_ify :: String -> IO String
osuf_ify f = do
osuf_opt <- readIORef v_Object_suf
case osuf_opt of
Nothing -> return f
Just s -> return (newsuf s f)
osuf <- readIORef v_Object_suf
return (replaceFilenameSuffix f osuf)
-----------------------------------------------------------------------------
-- Compiler optimisation options
......
-----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.34 2002/09/13 15:02:34 simonpj Exp $
-- $Id: DriverUtil.hs,v 1.35 2002/10/17 14:26:18 simonmar Exp $
--
-- Utils for the driver
--
......@@ -50,7 +50,7 @@ getOptionsFromSource file
| otherwise -> return []
matchOptions s
| Just s1 <- my_prefix_match "{-#" s,
| Just s1 <- my_prefix_match "{-#" s, -- -}
Just s2 <- my_prefix_match "OPTIONS" (remove_spaces s1),
Just s3 <- my_prefix_match "}-#" (reverse s2)
= Just (reverse s3)
......@@ -72,8 +72,7 @@ softGetDirectoryContents d
-- Verify that the 'dirname' portion of a FilePath exists.
--
doesDirNameExist :: FilePath -> IO Bool
doesDirNameExist fpath = doesDirectoryExist (getdir fpath)
doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
-----------------------------------------------------------------------------
-- Prefixing underscore to linker-level names
......@@ -148,6 +147,14 @@ splitFilename f = split_longest_prefix f (=='.')
getFileSuffix :: String -> Suffix
getFileSuffix f = drop_longest_prefix f (=='.')
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
splitFilenameDir :: String -> (String,String)
splitFilenameDir str
= let (dir, rest) = split_longest_prefix str isPathSeparator
real_dir | null dir = "."
| otherwise = dir
in (real_dir, rest)
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
......@@ -187,16 +194,17 @@ split_longest_prefix s pred
(_:pre) -> (reverse pre, reverse suf)
where (suf,pre) = break pred (reverse s)
newsuf :: String -> Suffix -> String
newsuf suf s = remove_suffix '.' s ++ suf
replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
replaceFilenameSuffix s suf = remove_suffix '.' s ++ suf
-- getdir strips the filename off the input string, returning the directory.
getdir :: String -> String
getdir s = if null dir then "." else init dir
where dir = take_longest_prefix s isPathSeparator
-- directoryOf strips the filename off the input string, returning
-- the directory.
directoryOf :: FilePath -> String
directoryOf = fst . splitFilenameDir
newdir :: String -> String -> String
newdir dir s = dir ++ '/':drop_longest_prefix s isPathSeparator
replaceFilenameDirectory :: FilePath -> String -> FilePath
replaceFilenameDirectory s dir
= dir ++ '/':drop_longest_prefix s isPathSeparator
remove_spaces :: String -> String
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
......
......@@ -6,154 +6,147 @@
\begin{code}
module Finder (
initFinder, -- :: [PackageConfig] -> IO (),
flushFinderCache, -- :: IO ()
findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath
findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
mkHomeModLocation, -- :: ModuleName -> String -> FilePath
-- -> IO ModLocation
emptyHomeDirCache, -- :: IO ()
flushPackageCache -- :: [PackageConfig] -> IO ()
hiBootExt, -- :: String
hiBootVerExt, -- :: String
) where
#include "HsVersions.h"
import Module ( Module, ModLocation(..), ModuleName,
moduleNameUserString, mkHomeModule, mkPackageModule
)
import Module
import UniqFM ( filterUFM )
import Packages ( PackageConfig(..) )
import DriverPhases
import DriverState
import DriverUtil
import DriverUtil ( split_longest_prefix )
import FastString
import Config
import Util
import DATA_IOREF ( readIORef )
import DATA_IOREF ( IORef, writeIORef, readIORef )
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) 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.
-- -----------------------------------------------------------------------------
-- The Finder
It does *not* know which particular package a module lives in, because
that information is only contained in the interface file.
-- The Finder provides a thin filesystem abstraction to the rest of the
-- 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 ()
-- -----------------------------------------------------------------------------
-- The finder's cache
GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv (Module,ModLocation))
-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session.
flushFinderCache :: IO ()
flushFinderCache = do
fm <- readIORef finder_cache
writeIORef finder_cache (filterUFM (not . isHomeModule . fst) fm)
addToFinderCache :: ModuleName -> (Module,ModLocation) -> IO ()
addToFinderCache mod_name stuff = do
fm <- readIORef finder_cache
writeIORef finder_cache (extendModuleEnvByName fm mod_name stuff)
lookupFinderCache :: ModuleName -> IO (Maybe (Module,ModLocation))
lookupFinderCache mod_name = do
fm <- readIORef finder_cache
return $! lookupModuleEnvByName fm mod_name
-- -----------------------------------------------------------------------------
-- Locating modules
-- 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.
findModule :: ModuleName -> IO (Maybe (Module, ModLocation))
findModule name = findModuleDep name False
findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
findModuleDep name is_source
= do { j <- maybeHomeModule name is_source
; case j of
Just home_module -> return (Just home_module)
Nothing -> findPackageMod name False is_source
}
maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
maybeHomeModule mod_name is_source = do
findModule name = do
r <- lookupFinderCache name
case r of
Just result -> return (Just result)
Nothing -> do
j <- maybeHomeModule name
case j of
Just home_module -> return (Just home_module)
Nothing -> findPackageMod name
findPackageModule :: ModuleName -> IO (Maybe (Module, ModLocation))
findPackageModule name = do
r <- lookupFinderCache name
case r of
Just result -> return (Just result)
Nothing -> findPackageMod name
hiBootExt = "hi-boot"
hiBootVerExt = "hi-boot-" ++ cHscIfaceFileVersion
maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModLocation))
maybeHomeModule mod_name = 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
let
source_exts =
[ ("hs", mkHomeModLocation mod_name False)
, ("lhs", mkHomeModLocation mod_name False)
]
hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod_name) ]
boot_exts =
[ (hiBootVerExt, mkHiOnlyModLocation hisuf mod_name)
, (hiBootExt, mkHiOnlyModLocation hisuf mod_name)
]
-- 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 = hi_exts
-- last chance: .hi-boot-<ver> and .hi-boot
hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion
| otherwise {-one-shot-} = hi_exts ++ boot_exts
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 else (std_exts ++ boot_exts))
-- for SOURCE imports, check the hi-boot extensions
-- before the source/iface ones, to avoid
-- creating circ Makefile deps.
searchPathExts home_path mod_name exts
-- -----------------------------------------------------------------------------
-- Looking for a package module
mkHiOnlyModuleLocn mod_name hi_file =
return
( mkHomeModule mod_name
, ModLocation{ 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,
ModLocation{ ml_hspp_file = Nothing
, ml_hs_file = Just source_fn
, ml_hi_file = hi
, ml_obj_file = Just o_file
})
findPackageMod :: ModuleName
-> Bool
-> Bool
-> IO (Maybe (Module, ModLocation))
findPackageMod mod_name hiOnly is_source = do
pkgs <- getPackageInfo
findPackageMod :: ModuleName -> IO (Maybe (Module, ModLocation))
findPackageMod mod_name = do
mode <- readIORef v_GhcMode
imp_dirs <- getPackageImportPath -- including the 'auto' ones
-- hi-suffix for packages depends on the build tag.
package_hisuf <-
......@@ -161,45 +154,45 @@ findPackageMod mod_name hiOnly is_source = do
if null tag
then return "hi"
else return (tag ++ "_hi")
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
, ModLocation{ ml_hspp_file = Nothing
, ml_hs_file = mbFName
, ml_hi_file = path ++ '.':package_hisuf
, ml_obj_file = Nothing
})
-- last chance: .hi-boot-<ver> 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
imp_dirs basename
(if is_source then boot_exts else
((package_hisuf,\ fName path -> retPackageModule mod_name Nothing path) :
(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, ModLocation))
findPackageModule mod_name = findPackageMod mod_name True False
searchPathExts :: [FilePath]
-> String
-> [(String, FilePath -> String -> IO (Module, ModLocation))]
-> IO (Maybe (Module, ModLocation))
searchPathExts path basename exts = search path
let
hi_exts =
[ (package_hisuf, mkPackageModLocation package_hisuf mod_name) ]
source_exts =
[ ("hs", mkPackageModLocation package_hisuf mod_name)
, ("lhs", mkPackageModLocation package_hisuf mod_name)
]
-- 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
-- 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_name exts
-- -----------------------------------------------------------------------------
-- General path searching
searchPathExts
:: [FilePath] -- paths to search
-> ModuleName -- module name
-> [ (
String, -- suffix
String -> String -> String -> IO (Module, ModLocation) -- action
)
]
-> IO (Maybe (Module, ModLocation))
searchPathExts path mod_name exts = search path
where
mod_str = moduleNameUserString mod_name
basename = map (\c -> if c == '.' then '/' else c) mod_str
search [] = return Nothing
search (p:ps) = loop exts
where
......@@ -210,6 +203,110 @@ searchPathExts path basename exts = search path
loop ((ext,fn):exts) = do
let file = base ++ '.':ext
b <- doesFileExist file
if b then Just `liftM` fn file base
if b then Just `liftM` fn p basename ext
else loop exts
-- -----------------------------------------------------------------------------
-- Building ModLocations
mkHiOnlyModLocation hisuf mod_name path basename extension = do
addToFinderCache mod_name result
return result
where
result = ( mkHomeModule mod_name, hiOnlyModLocation path basename hisuf )
mkPackageModLocation hisuf mod_name path basename _extension = do
addToFinderCache mod_name result
return result
where
result = ( mkPackageModule mod_name, hiOnlyModLocation path basename hisuf )
hiOnlyModLocation path basename hisuf =
ModLocation{ ml_hspp_file = Nothing,
ml_hs_file = Nothing,
-- 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_hi_file = path ++ '/':basename ++ '.':hisuf,
ml_obj_file = Nothing
}