From 90fecc3bb3600fc28662d090cb2218032689ed21 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 16 Oct 2000 15:16:59 +0000 Subject: [PATCH] [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. --- ghc/compiler/ghci/CmFind.lhs | 107 --------------------- ghc/compiler/ghci/CmStaticInfo.lhs | 51 +--------- ghc/compiler/ghci/CmSummarise.lhs | 25 ++--- ghc/compiler/main/DriverPhases.hs | 83 +++++++++++++++++ ghc/compiler/main/DriverPipeline.hs | 68 +------------- ghc/compiler/main/Finder.lhs | 174 +++++++++++++++++++++++++++++++++++ ghc/compiler/main/HscTypes.lhs | 20 ++-- 7 files changed, 287 insertions(+), 241 deletions(-) delete mode 100644 ghc/compiler/ghci/CmFind.lhs create mode 100644 ghc/compiler/main/DriverPhases.hs create mode 100644 ghc/compiler/main/Finder.lhs diff --git a/ghc/compiler/ghci/CmFind.lhs b/ghc/compiler/ghci/CmFind.lhs deleted file mode 100644 index ec4a250..0000000 --- a/ghc/compiler/ghci/CmFind.lhs +++ /dev/null @@ -1,107 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/ghci/CmStaticInfo.lhs b/ghc/compiler/ghci/CmStaticInfo.lhs index 6a4d00b..a4a7178 100644 --- a/ghc/compiler/ghci/CmStaticInfo.lhs +++ b/ghc/compiler/ghci/CmStaticInfo.lhs @@ -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} diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index 00c0eec..07a6607 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -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 diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs new file mode 100644 index 0000000..6bf8ad2 --- /dev/null +++ b/ghc/compiler/main/DriverPhases.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- $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 + diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 94d8b97..c569aec 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 @@ -73,67 +72,6 @@ getGhcMode flags "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 @@ -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 "" diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs new file mode 100644 index 0000000..8408501 --- /dev/null +++ b/ghc/compiler/main/Finder.lhs @@ -0,0 +1,174 @@ +% +% (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} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index a4e7544..9ebbbee 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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 -- 1.7.10.4