Commit 90fecc3b authored by simonmar's avatar simonmar
Browse files

[project @ 2000-10-16 15:16:59 by simonmar]

re-implement the finder using information from the driver.  The Finder
now has type

	ModuleName -> IO (Maybe (Module, ModuleLocation)

where
	data ModuleLocation  = ModuleLocation {
				hs_file  :: FilePath,
				hi_file  :: FilePath,
				obj_file :: FilePath
			      }

For a module in another package, the hs_file and obj_file components
are undefined.
parent 554977f7
%
% (c) The University of Glasgow, 2000
%
\section[CmFind]{Module finder for GHCI}
\begin{code}
module CmFind ( Finder, newFinder )
where
#include "HsVersions.h"
import IO ( hPutStr, stderr )
import List ( maximumBy )
import Maybe ( catMaybes )
import Time ( ClockTime )
import Directory ( doesFileExist, getModificationTime )
import Outputable
import Module ( Module, ModuleName, ModuleKind(..), PackageName,
mkModule, moduleNameUserString )
import CmStaticInfo ( Package(..), PackageConfigInfo(..) )
\end{code}
\begin{code}
type Finder = ModuleName -> IO (Maybe Module)
mkFinder :: [(ModuleName,PackageName,FilePath)] -> [FilePath] -> Finder
mkFinder pkg_ifaces home_dirs modnm
= do found <- mkFinderX pkg_ifaces home_dirs modnm
--putStrLn ("FINDER: request = " ++ modnm ++ "\n" ++
-- "FINDER: response = " ++ showSDoc (ppr found))
return found
mkFinderX :: [(ModuleName,PackageName,FilePath)] -> [FilePath] -> Finder
mkFinderX pkg_ifaces home_dirs modnm
-- If the module exists both as package and home, emit a warning
-- and (arbitrarily) choose the user's one.
= do home_maybe_found <- mapM (homeModuleExists modnm) home_dirs
:: IO [Maybe (Module, ClockTime)]
case (in_package, catMaybes home_maybe_found) of
([], [])
-> return Nothing
([], locs_n_times@(_:_))
-> return (Just (homeMod locs_n_times))
((pkgname,path):_, [])
-> return (Just (mkModule modnm (InPackage pkgname)))
(packages, locs_n_times)
-> do hPutStr stderr ( "GHCI: warning: module `"
++ moduleNameUserString modnm
++ "' appears as both a home and package module\n")
return (Just (homeMod locs_n_times))
where
in_package
= [(pkgname,path) | (modname,pkgname,path) <- pkg_ifaces,
modname == modnm]
homeMod :: [(Module, ClockTime)] -> Module
homeMod locs_n_times
= fst (maximumBy (\lt1 lt2 -> if snd lt1 > snd lt2 then lt1 else lt2)
locs_n_times)
-- See if a .hs or (.hi, .o) pair exist on the given path,
-- and return a Module for whichever is younger
homeModuleExists :: ModuleName -> FilePath -> IO (Maybe (Module, ClockTime))
homeModuleExists modname path
= do m_ths <- maybeTime nm_hs
m_thi <- maybeTime nm_hi
m_to <- maybeTime nm_o
return (
case (m_ths, m_thi, m_to) of
(Just ths, Just thi, Just to)
| thi >= ths && to >= ths -> object thi to
| otherwise -> source ths
(Just ths, _, _) -> source ths
(Nothing, Just thi, Just to) -> object thi to
(Nothing, _, _) -> Nothing
)
where
object thi to = Just (mkModule modname (ObjectCode nm_o nm_hi),
max thi to)
source ths = Just (mkModule modname (SourceOnly nm_hs),
ths)
nm = path ++ "/" ++ moduleNameUserString modname
nm_hs = nm ++ ".hs"
nm_hi = nm ++ ".hi"
nm_o = nm ++ ".o"
maybeTime :: String -> IO (Maybe ClockTime)
maybeTime f
= do -- putStrLn ("maybeTime: " ++ f)
exists <- doesFileExist f
if not exists
then do -- putStrLn " ... no"
return Nothing
else do tm <- getModificationTime f
-- putStrLn (" ... " ++ show tm)
return (Just tm)
newFinder :: FilePath{-temp debugging hack-}
-> PackageConfigInfo -> IO Finder
newFinder path pci
= return (mkFinder (pci_modtable pci) [path])
\end{code}
......@@ -9,20 +9,11 @@ where
#include "HsVersions.h"
import List ( nub )
import Char ( isUpper )
import Directory ( getDirectoryContents )
import Module ( ModuleName, mkModuleName, PackageName )
import Monad
\end{code}
\begin{code}
data PackageConfigInfo
= PackageConfigInfo {
pci_rawinfo :: [Package], -- contents of packages.conf
pci_modtable :: [(ModuleName, PackageName, FilePath)]
-- maps each available module to pkg and path
}
newtype PackageConfigInfo = PackageConfigInfo [Package]
-- copied from the driver
data Package
......@@ -42,41 +33,5 @@ data Package
deriving Read
mkPCI :: [Package] -> IO PackageConfigInfo
mkPCI raw_package_info
= do mtab <- mk_module_table raw_package_info
return (PackageConfigInfo { pci_rawinfo = raw_package_info,
pci_modtable = mtab })
mk_module_table :: [Package] -> IO [(ModuleName,PackageName,FilePath)]
mk_module_table raw_info
= do
-- the list of directories where package interfaces are
let -- p_i_dirs :: [(PkgName,Path)]
p_i_dirs = concatMap nm_and_paths raw_info
-- interface names in each directory
ifacess <- mapM ifaces_in_dir p_i_dirs
let -- iface_table :: [(ModName,PkgName,Path)]
iface_table = map fsifyStrings (concat ifacess)
-- ToDo: allow a range of home package directories
return iface_table
where
fsifyStrings (mod_str, pkg_str, path_str)
= (mkModuleName mod_str, _PK_ pkg_str, path_str)
-- nm_and_paths :: Package -> [(PkgName,Path)]
nm_and_paths package
= [(name package, path) | path <- nub (import_dirs package)]
-- ifaces_in_dir :: (PkgName,Path) -> IO [(ModName,PkgName,Path)]
ifaces_in_dir (pkgname,path)
= getDirectoryContents path >>= \ entries ->
return [(zap_hi if_nm, pkgname, path)
| if_nm <- entries, looks_like_iface_name if_nm]
looks_like_iface_name e
= not (null e) && isUpper (head e)
&& take 3 (reverse e) == "ih."
zap_hi
= reverse . drop 3 . reverse
mkPCI = return . PackageConfigInfo
\end{code}
......@@ -14,9 +14,10 @@ where
import List ( nub )
import Char ( ord, isAlphaNum )
import Finder
import FastTypes
import Module ( Module, mod_name, mod_kind,
ModuleName, mkModuleName, ModuleKind(..) )
import Module ( Module, ModuleName, mkModuleName)
import Outputable
\end{code}
......@@ -32,7 +33,8 @@ import Outputable
-- and let @compile@ read from that file on the way back up.
data ModSummary
= ModSummary {
ms_mod :: Module, -- location and kind
ms_mod :: Module, -- name, package
ms_location :: ModuleLocation, -- location
ms_ppsource :: (Maybe (FilePath, Fingerprint)), -- preprocessed and sig if .hs
ms_imports :: (Maybe [ModImport]) -- imports if .hs or .hi
}
......@@ -64,7 +66,7 @@ mi_name (MINormal nm) = nm
mi_name (MISource nm) = nm
name_of_summary :: ModSummary -> ModuleName
name_of_summary = mod_name . ms_mod
name_of_summary = moduleName . ms_mod
deps_of_summary :: ModSummary -> [ModuleName]
deps_of_summary = map mi_name . ms_get_imports
......@@ -93,15 +95,16 @@ summarise mod
fingerprint :: String -> Int
fingerprint s
= dofp s 3# 3#
= dofp s (_ILIT 3) (_ILIT 3)
where
-- Copied from hash() in Hugs' storage.c.
dofp :: String -> Int# -> Int# -> Int
dofp [] m fp = I# fp
dofp (c:cs) m fp = dofp cs (m +# 1#) (iabs (fp +# m *# unbox (ord c)))
unbox (I# i) = i
iabs :: Int# -> Int#
iabs n = if n <# 0# then 0# -# n else n
dofp :: String -> FastInt -> FastInt -> Int
dofp [] m fp = iBox fp
dofp (c:cs) m fp = dofp cs (m +# _ILIT 1)
(iabs (fp +# m *# iUnbox (ord c)))
iabs :: FastInt -> FastInt
iabs n = if n <# _ILIT 0 then (_ILIT 0) -# n else n
\end{code}
Collect up the imports from a Haskell source module. This is
......
-----------------------------------------------------------------------------
-- $Id: DriverPhases.hs,v 1.1 2000/10/16 15:16:59 simonmar Exp $
--
-- GHC Driver
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------
module DriverPhases (
Phase(..),
startPhase, -- :: String -> Phase
phaseInputExt, -- :: Phase -> String
haskellish_file,
haskellish_suffix,
cish_file,
cish_suffix
) where
import DriverUtil
-----------------------------------------------------------------------------
-- Phases
{-
Phase of the | Suffix saying | Flag saying | (suffix of)
compilation system | ``start here''| ``stop after''| output file
literate pre-processor | .lhs | - | -
C pre-processor (opt.) | - | -E | -
Haskell compiler | .hs | -C, -S | .hc, .s
C compiler (opt.) | .hc or .c | -S | .s
assembler | .s or .S | -c | .o
linker | other | - | a.out
-}
data Phase
= MkDependHS -- haskell dependency generation
| Unlit
| Cpp
| Hsc
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
| As
| Ln
deriving (Eq)
-- the first compilation phase for a given file is determined
-- by its suffix.
startPhase "lhs" = Unlit
startPhase "hs" = Cpp
startPhase "hc" = HCc
startPhase "c" = Cc
startPhase "raw_s" = Mangle
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
startPhase _ = Ln -- all unknown file types
-- the output suffix for a given phase is uniquely determined by
-- the input requirements of the next phase.
phaseInputExt Unlit = "lhs"
phaseInputExt Cpp = "lpp" -- intermediate only
phaseInputExt Hsc = "cpp" -- intermediate only
phaseInputExt HCc = "hc"
phaseInputExt Cc = "c"
phaseInputExt Mangle = "raw_s"
phaseInputExt SplitMangle = "split_s" -- not really generated
phaseInputExt As = "s"
phaseInputExt SplitAs = "split_s" -- not really generated
phaseInputExt Ln = "o"
phaseInputExt MkDependHS = "dep"
haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
cish_suffix = (`elem` [ "c", "s", "S" ]) -- maybe .cc et al.??
haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
cish_file f = cish_suffix suf where (_,suf) = splitFilename f
-----------------------------------------------------------------------------
-- $Id: DriverPipeline.hs,v 1.2 2000/10/11 16:26:04 simonmar Exp $
-- $Id: DriverPipeline.hs,v 1.3 2000/10/16 15:16:59 simonmar Exp $
--
-- GHC Driver
--
......@@ -16,7 +16,6 @@ module DriverPipeline (
#include "HsVersions.h"
import CmSummarise -- for mkdependHS stuff
import DriverState
import DriverUtil
import DriverMkDepend
......@@ -72,67 +71,6 @@ getGhcMode flags
throwDyn (OtherError
"only one of the flags -M, -E, -C, -S, -c, --make, --interactive is allowed")
-----------------------------------------------------------------------------
-- Phases
{-
Phase of the | Suffix saying | Flag saying | (suffix of)
compilation system | ``start here''| ``stop after''| output file
literate pre-processor | .lhs | - | -
C pre-processor (opt.) | - | -E | -
Haskell compiler | .hs | -C, -S | .hc, .s
C compiler (opt.) | .hc or .c | -S | .s
assembler | .s or .S | -c | .o
linker | other | - | a.out
-}
data Phase
= MkDependHS -- haskell dependency generation
| Unlit
| Cpp
| Hsc
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
| As
| Ln
deriving (Eq)
-- the first compilation phase for a given file is determined
-- by its suffix.
startPhase "lhs" = Unlit
startPhase "hs" = Cpp
startPhase "hc" = HCc
startPhase "c" = Cc
startPhase "raw_s" = Mangle
startPhase "s" = As
startPhase "S" = As
startPhase "o" = Ln
startPhase _ = Ln -- all unknown file types
-- the output suffix for a given phase is uniquely determined by
-- the input requirements of the next phase.
phase_input_ext Unlit = "lhs"
phase_input_ext Cpp = "lpp" -- intermediate only
phase_input_ext Hsc = "cpp" -- intermediate only
phase_input_ext HCc = "hc"
phase_input_ext Cc = "c"
phase_input_ext Mangle = "raw_s"
phase_input_ext SplitMangle = "split_s" -- not really generated
phase_input_ext As = "s"
phase_input_ext SplitAs = "split_s" -- not really generated
phase_input_ext Ln = "o"
phase_input_ext MkDependHS = "dep"
haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
cish_suffix = (`elem` [ "c", "s", "S" ]) -- maybe .cc et al.??
haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
cish_file f = cish_suffix suf where (_,suf) = splitFilename f
-----------------------------------------------------------------------------
-- genPipeline
--
......@@ -253,7 +191,7 @@ genPipeline todo stop_flag filename
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
annotatePipeline (phase:next_phase:ps) stop =
(phase, keep_this_output, phase_input_ext next_phase)
(phase, keep_this_output, phaseInputExt next_phase)
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
......@@ -470,7 +408,7 @@ run_phase Hsc basename suff input_fn output_fn
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
do_recomp <- readIORef recomp
todo <- readIORef v_GhcMode
o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
source_unchanged <-
if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
then return ""
......
%
% (c) The University of Glasgow, 2000
%
\section[Finder]{Module Finder}
\begin{code}
module Finder (
Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation))
newFinder, -- :: PackageConfigInfo -> IO Finder,
ModuleLocation(..)
) where
#include "HsVersions.h"
import CmStaticInfo
import DriverPhases
import DriverState
import Module
import FiniteMap
import Util
import Panic
import IOExts
import Directory
import List
import IO
import Monad
\end{code}
\begin{code}
type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation))
data ModuleLocation
= ModuleLocation {
hs_file :: FilePath,
hi_file :: FilePath,
obj_file :: FilePath
}
-- caches contents of package directories, never expunged
GLOBAL_VAR(pkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath)))
-- caches contents of home directories, expunged whenever we
-- create a new finder.
GLOBAL_VAR(homeDirCache, emptyFM, FiniteMap String FilePath)
-- caches finder mapping, expunged whenever we create a new finder.
GLOBAL_VAR(finderMapCache, emptyFM, FiniteMap ModuleName Module)
newFinder :: PackageConfigInfo -> IO Finder
newFinder (PackageConfigInfo pkgs) = do
-- expunge our caches
writeIORef homeDirCache emptyFM
writeIORef 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 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 homeDirCache home_map
-- populate the package cache, if necessary
pkg_cache <- readIORef 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 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 homeDirCache
let basename = moduleNameString mod_name
hs = basename ++ ".hs"
lhs = basename ++ ".lhs"
case lookupFM home_cache hs of {
Just path -> mkHomeModuleLocn mod_name basename path hs;
Nothing ->
case lookupFM home_cache lhs of {
Just path -> mkHomeModuleLocn mod_name basename path lhs;
Nothing -> return Nothing
}}
mkHomeModuleLocn mod_name basename path 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 output_hi
hisuf <- readIORef hi_suf
let hifile = case ohi of
Nothing -> path ++ '/':basename ++ hisuf
Just fn -> fn
-- 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 (path ++ '/':basename ++ '.':phaseInputExt Ln)
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 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.
package_hisuf <-
do tag <- readIORef 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 []
)
\end{code}
......@@ -394,16 +394,16 @@ data CompResult
-- generate Linkables.
data HscResult
= HscOK ModDetails -- new details (HomeSymbolTable additions)
(Maybe ModIFace) -- new iface (if any compilation was done)
(Maybe String) -- generated stub_h
(Maybe String) -- generated stub_c
PersistentCompilerState -- updated PCS
[SDoc] -- warnings
| HscErrs PersistentCompilerState -- updated PCS
[SDoc] -- errors
[SDoc] -- warnings
= HscOK ModDetails -- new details (HomeSymbolTable additions)
(Maybe ModIFace) -- new iface (if any compilation was done)
(Maybe String) -- generated stub_h filename (in /tmp)
(Maybe String) -- generated stub_c filename (in /tmp)
PersistentCompilerState -- updated PCS
[SDoc] -- warnings
| HscErrs PersistentCompilerState -- updated PCS
[SDoc] -- errors
[SDoc] -- warnings
-- These two are only here to avoid recursion between CmCompile and
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment