Factor out common Ar functionality into the library
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Sat, 2 Sep 2017 23:38:06 +0000 (00:38 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Sat, 2 Sep 2017 23:38:06 +0000 (00:38 +0100)
See #347

hadrian.cabal
src/Builder.hs
src/Hadrian/Builder/Ar.hs [new file with mode: 0644]
src/Hadrian/Utilities.hs
src/Oracles/Setting.hs
src/Settings/Builders/Ar.hs [deleted file]
src/Settings/Default.hs

index 497bb67..3331f3e 100644 (file)
@@ -27,6 +27,7 @@ executable hadrian
                        , Flavour
                        , GHC
                        , Hadrian.Builder
+                       , Hadrian.Builder.Ar
                        , Hadrian.Expression
                        , Hadrian.Haskell.Cabal
                        , Hadrian.Haskell.Cabal.Parse
@@ -62,7 +63,6 @@ executable hadrian
                        , Rules.Wrappers
                        , Settings
                        , Settings.Builders.Alex
-                       , Settings.Builders.Ar
                        , Settings.Builders.Common
                        , Settings.Builders.Cc
                        , Settings.Builders.Configure
index 5ae541c..75f1628 100644 (file)
@@ -17,6 +17,7 @@ import Development.Shake.Classes
 import GHC.Generics
 import qualified Hadrian.Builder as H
 import Hadrian.Builder hiding (Builder)
+import Hadrian.Builder.Ar
 import Hadrian.Oracles.Path
 import Hadrian.Oracles.TextFile
 import Hadrian.Utilities
@@ -143,7 +144,10 @@ instance H.Builder Builder where
             case builder of
                 Ar _ -> do
                     if "//*.a" ?== output
-                    then arCmd path buildArgs
+                    then do
+                        useTempFile <- flag ArSupportsAtFile
+                        if useTempFile then runAr                path buildArgs
+                                       else runArWithoutTempFile path buildArgs
                     else do
                         top   <- topDirectory
                         echo  <- cmdEcho
@@ -230,40 +234,6 @@ systemBuilderPath builder = case builder of
 isSpecified :: Builder -> Action Bool
 isSpecified = fmap (not . null) . systemBuilderPath
 
--- This count includes arg "q" and arg file parameters in arBuilderArgs.
--- Update this value appropriately when changing arBuilderArgs.
-arFlagsCount :: Int
-arFlagsCount = 2
-
--- | Invoke 'Ar' builder given a path to it and a list of arguments. Take care
--- not to exceed the limit on command line length, which differs across
--- supported operating systems (see 'cmdLineLengthLimit'). 'Ar' needs to be
--- handled in a special way because we sometimes need to archive __a lot__ of
--- files (in Cabal package, for example, command line length can reach 2MB!).
--- To work around the limit on the command line length we pass the list of files
--- to be archived via a temporary file, or alternatively, we split argument list
--- into chunks and call 'Ar' multiple times (when passing arguments via a
--- temporary 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 useSuccessiveInvocations path flagArgs fileArgs
-
-useAtFile :: FilePath -> [String] -> [String] -> Action ()
-useAtFile path flagArgs fileArgs = withTempFile $ \tmp -> do
-    writeFile' tmp $ unwords fileArgs
-    cmd [path] flagArgs ('@' : tmp)
-
-useSuccessiveInvocations :: FilePath -> [String] -> [String] -> Action ()
-useSuccessiveInvocations path flagArgs fileArgs = do
-    maxChunk <- cmdLineLengthLimit
-    forM_ (chunksOfSize maxChunk fileArgs) $ \argsChunk ->
-        unit . cmd [path] $ flagArgs ++ argsChunk
-
 -- | Apply a patch by executing the 'Patch' builder in a given directory.
 applyPatch :: FilePath -> FilePath -> Action ()
 applyPatch dir patch = do
diff --git a/src/Hadrian/Builder/Ar.hs b/src/Hadrian/Builder/Ar.hs
new file mode 100644 (file)
index 0000000..a8bf834
--- /dev/null
@@ -0,0 +1,57 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Builder.Ar
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Support for invoking the archiving utility @ar@. We take care not to exceed
+-- the limit on command line length, which differs across supported operating
+-- systems (see 'cmdLineLengthLimit'). We need to handle @ar@ in a special way
+-- because we sometimes archive __a lot__ of files (in the Cabal library, for
+-- example, command line length can reach 2MB!). To work around the limit on the
+-- command line length we pass the list of files to be archived via a temporary
+-- file (see 'runAr'), or alternatively, we split the argument list into chunks
+-- and call @ar@ multiple times, e.g. when passing arguments via a temporary
+-- file is not supported (see 'runArWithoutTempFile').
+-----------------------------------------------------------------------------
+module Hadrian.Builder.Ar (args, runAr, runArWithoutTempFile) where
+
+import Control.Monad
+import Development.Shake
+import Hadrian.Expression
+import Hadrian.Utilities
+
+-- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'.
+-- | Default command line arguments for invoking the archiving utility @ar@.
+args :: (ShakeValue c, ShakeValue b) => Args c b
+args = mconcat [ arg "q", arg =<< getOutput, getInputs ]
+
+-- This count includes "q" and the output file argumentes in 'args'.
+arFlagsCount :: Int
+arFlagsCount = 2
+
+-- | Invoke @ar@ given a path to it and a list of arguments. The list of files
+-- to be archived is passed via a temporary file. Passing arguments via a
+-- temporary file is not supported by some versions of @ar@, in which case you
+-- should use 'runArWithoutTempFile' instead.
+runAr :: FilePath -> [String] -> Action ()
+runAr arPath argList = withTempFile $ \tmp -> do
+    writeFile' tmp $ unwords fileArgs
+    cmd [arPath] flagArgs ('@' : tmp)
+  where
+    flagArgs = take arFlagsCount argList
+    fileArgs = drop arFlagsCount argList
+
+-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
+-- will be called multiple times if the list of files to be archived is too
+-- long and doesn't fit into the command line length limit. This function is
+-- typically much slower than 'runAr'.
+runArWithoutTempFile :: FilePath -> [String] -> Action ()
+runArWithoutTempFile arPath argList =
+    forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk ->
+        unit . cmd [arPath] $ flagArgs ++ argsChunk
+  where
+    flagArgs = take arFlagsCount argList
+    fileArgs = drop arFlagsCount argList
index 9534645..8f6f4cc 100644 (file)
@@ -29,7 +29,7 @@ module Hadrian.Utilities (
     RuleResult,
 
     -- * Miscellaneous
-    (<&>), (%%>),
+    (<&>), (%%>), cmdLineLengthLimit,
 
     -- * Useful re-exports
     Dynamic, fromDynamic, toDyn, TypeRep, typeOf
@@ -46,6 +46,7 @@ import Development.Shake hiding (Normal)
 import Development.Shake.Classes
 import Development.Shake.FilePath
 import System.Console.ANSI
+import System.Info.Extra
 
 import qualified Control.Exception.Base as IO
 import qualified Data.HashMap.Strict    as Map
@@ -137,6 +138,20 @@ p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
 
 infix 1 %%>
 
+-- | Build command lines can get very long; for example, when building the Cabal
+-- library, they can reach 2MB! Some operating systems do not support command
+-- lines of such length, and this function can be used to obtain a reasonable
+-- approximation of the limit. On Windows, it is theoretically 32768 characters
+-- (since Windows 7). In practice we use 31000 to leave some breathing space for
+-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
+-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
+-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
+-- we currently use the 4194304 setting.
+cmdLineLengthLimit :: Int
+cmdLineLengthLimit | isWindows = 31000
+                   | isMac     = 200000
+                   | otherwise = 4194304
+
 -- | Insert a value into Shake's type-indexed map.
 insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
 insertExtra value = Map.insert (typeOf value) (toDyn value)
index 4f61b8b..8af8f38 100644 (file)
@@ -186,23 +186,6 @@ ghcCanonVersion = do
     let leadingZero = [ '0' | length ghcMinorVersion == 1 ]
     return $ ghcMajorVersion ++ leadingZero ++ ghcMinorVersion
 
--- | Command lines have limited size on Windows. Since Windows 7 the limit is
--- 32768 characters (theoretically). In practice we use 31000 to leave some
--- breathing space for the builder's path & name, auxiliary flags, and other
--- overheads. Use this function to set limits for other OSs if necessary.
-cmdLineLengthLimit :: Action Int
-cmdLineLengthLimit = do
-    windows <- windowsHost
-    osx     <- osxHost
-    return $ case (windows, osx) of
-        -- Windows:
-        (True, False) -> 31000
-        -- On Mac OSX ARG_MAX is 262144, yet when using @xargs@ on OSX this is
-        -- reduced by over 20 000. Hence, 200 000 seems like a sensible limit.
-        (False, True) -> 200000
-        -- On all other systems, we try this:
-        _             -> 4194304 -- Cabal library needs a bit more than 2MB!
-
 -- ref: https://ghc.haskell.org/trac/ghc/wiki/Building/Installing#HowGHCfindsitsfiles
 -- | On Windows we normally build a relocatable installation, which assumes that
 -- the library directory @libdir@ is in a fixed location relative to the GHC
diff --git a/src/Settings/Builders/Ar.hs b/src/Settings/Builders/Ar.hs
deleted file mode 100644 (file)
index e8f533d..0000000
+++ /dev/null
@@ -1,8 +0,0 @@
-module Settings.Builders.Ar (arBuilderArgs) where
-
-import Settings.Builders.Common
-
-arBuilderArgs :: Args
-arBuilderArgs = builder Ar ? mconcat [ arg "q"
-                                     , arg =<< getOutput
-                                     , getInputs ]
index ca48931..3ecf6a9 100644 (file)
@@ -4,6 +4,8 @@ module Settings.Default (
     defaultFlavour, defaultSplitObjects
     ) where
 
+import qualified Hadrian.Builder.Ar
+
 import CommandLine
 import Expression
 import Flavour
@@ -12,7 +14,6 @@ import Oracles.PackageData
 import Oracles.Setting
 import Settings
 import Settings.Builders.Alex
-import Settings.Builders.Ar
 import Settings.Builders.DeriveConstants
 import Settings.Builders.Cc
 import Settings.Builders.Configure
@@ -138,7 +139,7 @@ defaultSplitObjects = do
 defaultBuilderArgs :: Args
 defaultBuilderArgs = mconcat
     [ alexBuilderArgs
-    , arBuilderArgs
+    , builder Ar ? Hadrian.Builder.Ar.args
     , ccBuilderArgs
     , configureBuilderArgs
     , deriveConstantsBuilderArgs