Commit 580d3972 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Improve performance by caching windows root lookup.

parent b2533979
......@@ -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
......
......@@ -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
......
......@@ -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'.
-- 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
......
{-# 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 ()
......@@ -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
......@@ -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
......
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