[commit: ghc] wip/nfs-locking: Improve performance of getHsSources. (3122d3a)
git at git.haskell.org
git at git.haskell.org
Thu Oct 26 23:31:55 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/3122d3a2b9fe8ed79df55edd09b1cb12b1d9cdba/ghc
>---------------------------------------------------------------
commit 3122d3a2b9fe8ed79df55edd09b1cb12b1d9cdba
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Mon Jul 27 02:04:34 2015 +0100
Improve performance of getHsSources.
>---------------------------------------------------------------
3122d3a2b9fe8ed79df55edd09b1cb12b1d9cdba
src/Oracles/DependencyList.hs | 3 ---
src/Oracles/PackageData.hs | 2 +-
src/Package/Base.hs | 60 -------------------------------------------
src/Rules/Actions.hs | 2 +-
src/Settings/Util.hs | 32 +++++++++++++++++++++--
src/Util.hs | 7 ++++-
6 files changed, 38 insertions(+), 68 deletions(-)
diff --git a/src/Oracles/DependencyList.hs b/src/Oracles/DependencyList.hs
index 76d7eac..0ad9267 100644
--- a/src/Oracles/DependencyList.hs
+++ b/src/Oracles/DependencyList.hs
@@ -38,6 +38,3 @@ dependencyListOracle = do
addOracle $ \(DependencyListKey (file, obj)) ->
Map.lookup (unifyPath obj) <$> deps (unifyPath file)
return ()
-
-bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
-bimap f g (x, y) = (f x, g y)
diff --git a/src/Oracles/PackageData.hs b/src/Oracles/PackageData.hs
index fd30cc3..579312f 100644
--- a/src/Oracles/PackageData.hs
+++ b/src/Oracles/PackageData.hs
@@ -90,6 +90,6 @@ packageDataOracle = do
need [file]
putOracle $ "Reading " ++ file ++ "..."
liftIO $ readConfigFile file
- addOracle $ \(PackageDataKey (file, key)) ->
+ addOracle $ \(PackageDataKey (file, key)) -> do
Map.lookup key <$> pkgData (unifyPath file)
return ()
diff --git a/src/Package/Base.hs b/src/Package/Base.hs
index 3e2eb37..1f9d2c8 100644
--- a/src/Package/Base.hs
+++ b/src/Package/Base.hs
@@ -23,52 +23,6 @@ import Oracles
import Settings
import qualified System.Directory as S
---pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
---pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
-
--- prefixedPath :: String -> [Settings] -> Settings
--- prefixedPath prefix = argPrefix prefix . argConcatPath . sconcat
-
---includeGccArgs :: FilePath -> FilePath -> Args
---includeGccArgs path dist =
--- let pathDist = path </> dist
--- autogen = pathDist </> "build/autogen"
--- in args [ arg $ "-I" ++ unifyPath autogen
--- , pathArgs "-I" path $ IncludeDirs pathDist
--- , pathArgs "-I" path $ DepIncludeDirs pathDist ]
-
-
--- includeGccSettings :: Settings
--- includeGccSettings = mconcat
--- [ prefixedPath "-I" [argBuildPath, argBuildDir, arg "build", arg "autogen"]
--- , argPrefix "-I" $ argPaths ...
--- , prefixedPath "-I" [argBuildPath, argIncludeDirs ] -- wrong
--- , prefixedPath "-I" [argBuildPath, argDepIncludeDirs ]]
-
--- includeGhcSettings :: Settings
--- includeGhcSettings =
--- let buildDir = argBuildPath `fence` argSrcDirs
--- in arg "-i" `fence`
--- mconcat
--- [ argPathList "-i" [argBuildPath, argSrcDirs]
--- , argPath "-i" buildDir
--- , argPath "-I" buildDir
--- , argPathList "-i" [buildDir, arg "autogen"]
--- , argPathList "-I" [buildDir, arg "autogen"]
--- , argPathList "-I" [argBuildPath, argIncludeDirs]
--- , arg "-optP-include" -- TODO: Shall we also add -cpp?
--- , argPathList "-optP" [buildDir, arg "autogen/cabal_macros.h"] ]
-
-
--- pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
--- pkgHsSources path dist = do
--- let pathDist = path </> dist
--- autogen = pathDist </> "build/autogen"
--- dirs <- map (path </>) <$> args (SrcDirs pathDist)
--- findModuleFiles pathDist (autogen:dirs) [".hs", ".lhs"]
-
--- TODO: look for non-{hs,c} objects too
-
-- Find Haskell objects we depend on (we don't want to depend on split objects)
pkgDepHsObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
pkgDepHsObjects path dist way = do
@@ -101,20 +55,6 @@ pkgLibHsObjects path dist stage way = do
findModuleFiles pathDist [buildDir] [suffix]
else do return depObjs
--- findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
--- findModuleFiles pathDist directories suffixes = do
--- modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
--- fileList <- forM [ dir </> modPath ++ suffix
--- | dir <- directories
--- , modPath <- modPaths
--- , suffix <- suffixes
--- ] $ \file -> do
--- let dir = takeDirectory file
--- dirExists <- liftIO $ S.doesDirectoryExist dir
--- when dirExists $ return $ unifyPath file
--- files <- getDirectoryFiles "" fileList
--- return $ map unifyPath files
-
-- The argument list has a limited size on Windows. Since Windows 7 the limit
-- is 32768 (theoretically). In practice we use 31000 to leave some breathing
-- space for the builder's path & name, auxiliary flags, and other overheads.
diff --git a/src/Rules/Actions.hs b/src/Rules/Actions.hs
index 2730c55..d91cd84 100644
--- a/src/Rules/Actions.hs
+++ b/src/Rules/Actions.hs
@@ -50,7 +50,7 @@ interestingInfo builder ss = case builder of
Gcc _ -> prefixAndSuffix 0 4 ss
GccM _ -> prefixAndSuffix 0 1 ss
Ghc _ -> prefixAndSuffix 0 4 ss
- GhcM _ -> prefixAndSuffix 1 1 ss
+ --GhcM _ -> prefixAndSuffix 1 1 ss
GhcPkg _ -> prefixAndSuffix 3 0 ss
GhcCabal -> prefixAndSuffix 3 0 ss
_ -> ss
diff --git a/src/Settings/Util.hs b/src/Settings/Util.hs
index 1e7585e..1901a8c 100644
--- a/src/Settings/Util.hs
+++ b/src/Settings/Util.hs
@@ -26,6 +26,8 @@ import Oracles.Setting
import Oracles.PackageData
import Settings.User
import Settings.TargetDirectory
+import Data.List
+import Data.Function
-- A single argument.
arg :: String -> Args
@@ -76,8 +78,34 @@ getHsSources = do
path <- getTargetPath
pkgPath <- getPackagePath
srcDirs <- getPkgDataList SrcDirs
- let paths = (path -/- "build/autogen") : map (pkgPath -/-) srcDirs
- getSourceFiles paths [".hs", ".lhs"]
+ modules <- getPkgDataList Modules
+ let buildPath = path -/- "build"
+ autogenPath = buildPath -/- "autogen"
+ dirs = autogenPath : map (pkgPath -/-) srcDirs
+ decodedMods = sort $ map decodeModule modules
+ modDirFiles = map (bimap head sort . unzip)
+ $ groupBy ((==) `on` fst) decodedMods
+
+ result <- lift . fmap concat . forM dirs $ \dir -> do
+ todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
+ forM todo $ \(mDir, mFiles) -> do
+ let files = [ dir -/- mDir -/- mFile <.> "*hs" | mFile <- mFiles ]
+ found <- fmap (map unifyPath) $ getDirectoryFiles "" files
+ return (found, (mDir, map takeBaseName found))
+
+ let foundSources = concatMap fst result
+ foundMods = [ (d, f) | (d, fs) <- map snd result, f <- fs ]
+ leftMods = decodedMods \\ sort foundMods
+ genSources = map (\(d, f) -> buildPath -/- d -/- f <.> "hs") leftMods
+
+ return $ foundSources ++ genSources
+
+-- Given a module name extract the directory and file names, e.g.:
+-- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
+decodeModule :: String -> (FilePath, FilePath)
+decodeModule = splitFileName . replaceEq '.' '/'
+
+ -- getSourceFiles paths [".hs", ".lhs"]
-- Find all source files in specified paths and with given extensions
getSourceFiles :: [FilePath] -> [String] -> Expr [FilePath]
diff --git a/src/Util.hs b/src/Util.hs
index 7c5f786..fd33e73 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -5,7 +5,8 @@ module Util (
replaceIf, replaceEq, replaceSeparators,
unifyPath, (-/-),
chunksOfSize,
- putColoured, redError, redError_
+ putColoured, redError, redError_,
+ bimap
) where
import Data.Char
@@ -65,3 +66,7 @@ redError msg = do
redError_ :: String -> Action ()
redError_ = void . redError
+
+-- Depending on Data.Bifunctor only for this function seems an overkill
+bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
+bimap f g (x, y) = (f x, g y)
More information about the ghc-commits
mailing list