[commit: ghc] wip/nfs-locking: Add new mode for Ar builder: useAtFile (big performance increase). (6cde985)

[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/6cde9851e61a88b0773e07346752279129c87d41/ghc

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

commit 6cde9851e61a88b0773e07346752279129c87d41
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Thu Sep 24 23:44:34 2015 +0100

    Add new mode for Ar builder: useAtFile (big performance increase).


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

6cde9851e61a88b0773e07346752279129c87d41
 src/Rules/Actions.hs        | 23 ++++++++---------------
 src/Settings/Builders/Ar.hs | 31 ++++++++++++++++++++++++++++---
 2 files changed, 36 insertions(+), 18 deletions(-)

diff --git a/src/Rules/Actions.hs b/src/Rules/Actions.hs
index 8214112..5f15f3d 100644
--- a/src/Rules/Actions.hs
+++ b/src/Rules/Actions.hs
@@ -1,7 +1,6 @@
 module Rules.Actions (build, buildWithResources) where
 
 import Expression
-import Oracles
 import Oracles.ArgsHash
 import Settings
 import Settings.Args
@@ -18,19 +17,13 @@ buildWithResources rs target = do
     path    <- builderPath builder
     argList <- interpret target getArgs
     -- The line below forces the rule to be rerun if the args hash has changed
-    when trackBuildSystem $ checkArgsHash target
+    checkArgsHash target
     withResources rs $ do
-        putBuild $ "/--------\n" ++ "| Running "
-                 ++ show builder ++ " with arguments:"
+        putBuild $ "/--------\n| Running " ++ show builder ++ " with arguments:"
         mapM_ (putBuild . ("|   " ++)) $ interestingInfo builder argList
         putBuild $ "\\--------"
         quietly $ case builder of
-            Ar -> do -- Split argument list into chunks as otherwise Ar chokes up
-                maxChunk <- cmdLineLengthLimit
-                let persistentArgs = take arPersistentArgsCount argList
-                    remainingArgs  = drop arPersistentArgsCount argList
-                forM_ (chunksOfSize maxChunk remainingArgs) $ \argsChunk ->
-                    unit . cmd [path] $ persistentArgs ++ argsChunk
+            Ar -> arCmd path argList
 
             HsCpp -> do
                 let file = head $ Target.files target  -- TODO: ugly
@@ -63,14 +56,14 @@ interestingInfo builder ss = case builder of
     Haddock  -> prefixAndSuffix 1 0 ss
     Happy    -> prefixAndSuffix 0 3 ss
     Hsc2Hs   -> prefixAndSuffix 0 3 ss
+    HsCpp    -> prefixAndSuffix 0 1 ss
     Ld       -> prefixAndSuffix 4 0 ss
     _        -> ss
   where
     prefixAndSuffix n m list =
-        if length list <= n + m + 1
+        let len = length list in
+        if len <= n + m + 1
         then list
         else take n list
-             ++ ["... skipping "
-             ++ show (length list - n - m)
-             ++ " arguments ..."]
-             ++ drop (length list - m) list
+             ++ ["... skipping " ++ show (len - n - m) ++ " arguments ..."]
+             ++ drop (len - m) list
diff --git a/src/Settings/Builders/Ar.hs b/src/Settings/Builders/Ar.hs
index 082cbaf..7b6eb59 100644
--- a/src/Settings/Builders/Ar.hs
+++ b/src/Settings/Builders/Ar.hs
@@ -1,6 +1,7 @@
-module Settings.Builders.Ar (arArgs, arPersistentArgsCount) where
+module Settings.Builders.Ar (arArgs, arCmd) where
 
 import Expression
+import Oracles
 import Predicates (builder)
 
 arArgs :: Args
@@ -13,5 +14,29 @@ arArgs = builder Ar ? do
 
 -- This count includes arg "q" and arg file parameters in arArgs (see above).
 -- Update this value appropriately when changing arArgs.
-arPersistentArgsCount :: Int
-arPersistentArgsCount = 2
+arFlagsCount :: Int
+arFlagsCount = 2
+
+-- Ar needs to be invoked in a special way: we pass the list of files to be
+-- archived via a temporary file as otherwise Ar (or rather Windows command
+-- line) chokes up. Alternatively, we split argument list into chunks and call
+-- ar multiple times (when passing files via a separate file is not supported).
+arCmd :: FilePath -> [String] -> Action ()
+arCmd path argList = do
+    arSupportsAtFile <- flag ArSupportsAtFile
+    let flagArgs = take arFlagsCount argList
+        fileArgs = drop arFlagsCount argList
+    if arSupportsAtFile
+    then useAtFile path flagArgs fileArgs
+    else useSuccessiveInvokations path flagArgs fileArgs
+
+useAtFile :: FilePath -> [String] -> [String] -> Action ()
+useAtFile path flagArgs fileArgs = withTempFile $ \tmp -> do
+    writeFile' tmp $ unwords fileArgs
+    cmd [path] flagArgs ('@' : tmp)
+
+useSuccessiveInvokations :: FilePath -> [String] -> [String] -> Action ()
+useSuccessiveInvokations path flagArgs fileArgs = do
+    maxChunk <- cmdLineLengthLimit
+    forM_ (chunksOfSize maxChunk fileArgs) $ \argsChunk ->
+        unit . cmd [path] $ flagArgs ++ argsChunk