+++ /dev/null
-%
-% (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}
#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
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}
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}
-- 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
}
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
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
--- /dev/null
+-----------------------------------------------------------------------------
+-- $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
--
#include "HsVersions.h"
-import CmSummarise -- for mkdependHS stuff
import DriverState
import DriverUtil
import DriverMkDepend
"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
--
-- Herein is all the magic about which phases to run in which order, whether
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
-- 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 ""
--- /dev/null
+%
+% (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}
-- 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
projects / ghc-hetmet.git / commitdiff