[commit: ghc] wip/nfs-locking: Improve performance by caching windows root lookup. (580d397)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/580d39722d627eb95eab63d374441d6c92276f9e/ghc

>---------------------------------------------------------------

commit 580d39722d627eb95eab63d374441d6c92276f9e
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Mon Jul 20 10:06:06 2015 +0100

    Improve performance by caching windows root lookup.


>---------------------------------------------------------------

580d39722d627eb95eab63d374441d6c92276f9e
 src/Builder.hs             |  6 +++---
 src/Oracles/PackageData.hs |  1 +
 src/Oracles/Setting.hs     |  8 +++-----
 src/Oracles/WindowsRoot.hs | 28 ++++++++++++++++++++++++++++
 src/Rules/Oracles.hs       | 10 +++++++---
 src/Settings/Args.hs       |  1 +
 6 files changed, 43 insertions(+), 11 deletions(-)

diff --git a/src/Builder.hs b/src/Builder.hs
index 0001fc4..91c6fa3 100644
--- a/src/Builder.hs
+++ b/src/Builder.hs
@@ -9,6 +9,7 @@ import Stage
 import Data.List
 import Oracles.Base
 import Oracles.Setting
+import Oracles.WindowsRoot
 import GHC.Generics
 
 -- A Builder is an external command invoked in separate process using Shake.cmd
@@ -58,7 +59,6 @@ builderPath builder = do
 specified :: Builder -> Action Bool
 specified = fmap (not . null) . builderPath
 
--- TODO: get rid of code duplication (windowsHost)
 -- On Windows: if the path starts with "/", prepend it with the correct path to
 -- the root, e.g: "/usr/local/bin/ghc.exe" => "C:/msys/usr/local/bin/ghc.exe".
 fixAbsolutePathOnWindows :: FilePath -> Action FilePath
@@ -67,8 +67,8 @@ fixAbsolutePathOnWindows path = do
     -- Note, below is different from FilePath.isAbsolute:
     if (windows && "/" `isPrefixOf` path)
     then do
-        Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
-        return . unifyPath $ dropWhileEnd isSpace out ++ drop 1 path
+        root <- windowsRoot
+        return . unifyPath $ root ++ drop 1 path
     else
         return path
 
diff --git a/src/Oracles/PackageData.hs b/src/Oracles/PackageData.hs
index f12b842..3b00cf8 100644
--- a/src/Oracles/PackageData.hs
+++ b/src/Oracles/PackageData.hs
@@ -39,6 +39,7 @@ data PackageDataList = Modules        FilePath
 newtype PackageDataKey = PackageDataKey (FilePath, String)
     deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
+-- TODO: is this needed?
 askPackageData :: FilePath -> String -> Action String
 askPackageData path key = do
     let fullKey = replaceSeparators '_' $ path ++ "_" ++ key
diff --git a/src/Oracles/Setting.hs b/src/Oracles/Setting.hs
index 02073e9..9694c00 100644
--- a/src/Oracles/Setting.hs
+++ b/src/Oracles/Setting.hs
@@ -12,8 +12,8 @@ import Oracles.Base
 -- setting TargetOs looks up the config file and returns "mingw32".
 --
 -- SettingList is used for multiple string values separated by spaces, such
--- as 'src-hc-args = -H32m -O'.
--- settingList SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
+-- as 'gmp-include-dirs = a b'.
+-- settingList GmpIncludeDirs therefore returns a list of strings ["a", "b"].
 data Setting = TargetOs
              | TargetArch
              | TargetPlatformFull
@@ -22,8 +22,7 @@ data Setting = TargetOs
              | ProjectVersion
              | GhcSourcePath
 
-data SettingList = SrcHcArgs
-                 | ConfCcArgs Stage
+data SettingList = ConfCcArgs Stage
                  | ConfGccLinkerArgs Stage
                  | ConfLdLinkerArgs Stage
                  | ConfCppArgs Stage
@@ -44,7 +43,6 @@ setting key = askConfig $ case key of
 
 settingList :: SettingList -> Action [String]
 settingList key = fmap words $ askConfig $ case key of
-    SrcHcArgs               -> "src-hc-args"
     ConfCcArgs        stage -> "conf-cc-args-stage"         ++ show stage
     ConfCppArgs       stage -> "conf-cpp-args-stage"        ++ show stage
     ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage" ++ show stage
diff --git a/src/Oracles/WindowsRoot.hs b/src/Oracles/WindowsRoot.hs
new file mode 100644
index 0000000..261ca93
--- /dev/null
+++ b/src/Oracles/WindowsRoot.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
+module Oracles.WindowsRoot (
+    windowsRoot, windowsRootOracle
+    ) where
+
+import Util
+import Oracles.Base
+import Data.List
+
+newtype WindowsRoot = WindowsRoot ()
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+-- Looks up cygwin/msys root on Windows
+windowsRoot :: Action String
+windowsRoot = askOracle $ WindowsRoot ()
+
+-- Oracle for windowsRoot. This operation requires caching as looking up
+-- the root is slow (at least the current implementation).
+windowsRootOracle :: Rules ()
+windowsRootOracle = do
+    root <- newCache $ \() -> do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
+        let root = dropWhileEnd isSpace out
+        putOracle $ "Detected root on Windows: " ++ root
+        return root
+    addOracle $ \WindowsRoot{} -> root ()
+    return ()
diff --git a/src/Rules/Oracles.hs b/src/Rules/Oracles.hs
index 7c646be..ba15031 100644
--- a/src/Rules/Oracles.hs
+++ b/src/Rules/Oracles.hs
@@ -5,9 +5,13 @@ module Rules.Oracles (
 import Oracles.Base
 import Oracles.ArgsHash
 import Oracles.PackageData
+import Oracles.WindowsRoot
 import Oracles.DependencyList
-import Data.Monoid
 
 oracleRules :: Rules ()
-oracleRules =
-    configOracle <> packageDataOracle <> dependencyListOracle <> argsHashOracle
+oracleRules = do
+    configOracle         -- see Oracles.Base
+    packageDataOracle    -- see Oracles.PackageData
+    dependencyListOracle -- see Oracles.DependencyList
+    argsHashOracle       -- see Oracles.ArgsHash
+    windowsRootOracle    -- see Oracles.WindowsRoot
diff --git a/src/Settings/Args.hs b/src/Settings/Args.hs
index 78b4f3d..3031093 100644
--- a/src/Settings/Args.hs
+++ b/src/Settings/Args.hs
@@ -11,6 +11,7 @@ args :: Args
 args = defaultArgs <> userArgs
 
 -- TODO: add all other settings
+-- TODO: add src-hc-args = -H32m -O
 defaultArgs :: Args
 defaultArgs = mconcat
     [ cabalArgs