Add xargs function and use it when linking.

When using GHC's --split-objs we end up with lots of files to link.
This can mean overflowing the maximum length of the command line
when invoking ar or ld. On windows the maximum length is 32k. On
other systems it's not a great deal more. GHC currently deals with
this problem by using xargs. This patch does more or less the same.

Distribution/Simple/GHC.hs

@@ -51,8 +51,9 @@ import Distribution.PackageDescription
 import Distribution.Simple.LocalBuildInfo
 				( LocalBuildInfo(..), autogenModulesDir,
 				  mkLibDir, mkIncludeDir )
-import Distribution.Simple.Utils( rawSystemExit, rawSystemPathExit, die,
-				  dirOf, moduleToFilePath,
+import Distribution.Simple.Utils( rawSystemExit, rawSystemPath,
+				  rawSystemVerbose, maybeExit, xargs,
+				  die, dirOf, moduleToFilePath,
 				  smartCopySources, findFile, copyFileVerbose,
                                   mkLibName, mkProfLibName, dotToSep )
 import Distribution.Package  	( PackageIdentifier(..), showPackageId )
@@ -76,8 +77,9 @@ import Language.Haskell.Extension (Extension(..))
 
 import Control.Monad		( unless, when )
 import Data.List		( isSuffixOf, nub )
-import System.Directory		( removeFile, getDirectoryContents,
-				  doesFileExist )
+import System.Directory		( removeFile, renameFile,
+				  getDirectoryContents, doesFileExist )
+import System.Exit              (ExitCode(..))
 
 #ifdef mingw32_HOST_OS
 import Distribution.Compat.FilePath ( splitFileName )
@@ -184,29 +186,51 @@ build pkg_descr lbi verbose = do
 	try (removeFile ghciLibName) -- first remove library if it exists
         let arArgs = ["q"++ (if verbose > 4 then "v" else "")]
                 ++ [libName]
-		++ hObjs
+            arObjArgs =
+		   hObjs
                 ++ map (pref `joinFileName`) cObjs
                 ++ stubObjs
             arProfArgs = ["q"++ (if verbose > 4 then "v" else "")]
                 ++ [profLibName]
-		++ hProfObjs
+            arProfObjArgs =
+		   hProfObjs
                 ++ stubProfObjs
 	    ldArgs = ["-r"]
                 ++ ["-x"] -- FIXME: only some systems's ld support the "-x" flag
-	        ++ ["-o", ghciLibName]
-		++ hObjs
+	        ++ ["-o", ghciLibName `joinFileExt` "tmp"]
+            ldObjArgs =
+		   hObjs
                 ++ map (pref `joinFileName`) cObjs
 		++ stubObjs
-        ifVanillaLib forceVanillaLib (rawSystemPathExit verbose "ar" arArgs)
-        ifProfLib (rawSystemPathExit verbose "ar" arProfArgs)
+
 #if defined(mingw32_TARGET_OS) || defined(mingw32_HOST_OS)
-        let (compilerDir, _) = splitFileName $ compilerPath (compiler lbi)
+            (compilerDir, _) = splitFileName $ compilerPath (compiler lbi)
             (baseDir, _)     = splitFileName compilerDir
             ld = baseDir `joinFileName` "gcc-lib\\ld.exe"
-        ifGHCiLib (rawSystemExit verbose ld ldArgs)
+            rawSystemLd = rawSystemVerbose
+            maxCommandLineSize = 32 * 1024
 #else
-        ifGHCiLib (rawSystemPathExit verbose "ld" ldArgs)
+            ld = "ld"
+            rawSystemLd = rawSystemPath
+             --TODO: discover this at configure time on unix
+            maxCommandLineSize = 32 * 1024
 #endif
+            runLd ld args = do
+              exists <- doesFileExist ghciLibName
+              status <- rawSystemLd verbose ld
+                          (args ++ if exists then [ghciLibName] else [])
+              when (status == ExitSuccess)
+                   (renameFile (ghciLibName `joinFileExt` "tmp") ghciLibName)
+              return status
+
+        ifVanillaLib False $ maybeExit $ xargs maxCommandLineSize
+          (rawSystemPath verbose) "ar" arArgs arObjArgs
+
+        ifProfLib $ maybeExit $ xargs maxCommandLineSize
+          (rawSystemPath verbose) "ar" arProfArgs arProfObjArgs
+
+        ifGHCiLib $ maybeExit $ xargs maxCommandLineSize
+          runLd ld ldArgs ldObjArgs
 
   -- build any executables
   withExe pkg_descr $ \ (Executable exeName' modPath exeBi) -> do

Distribution/Simple/Utils.hs

@@ -49,6 +49,7 @@ module Distribution.Simple.Utils (
         rawSystemVerbose,
 	rawSystemExit,
         maybeExit,
+        xargs,
         matchesDescFile,
 	rawSystemPathExit,
         smartCopySources,
@@ -86,7 +87,7 @@ import Distribution.Compat.RawSystem (rawSystem)
 import Distribution.Compat.Exception (finally)
 
 import Control.Monad(when, filterM, unless)
-import Data.List (nub)
+import Data.List (nub, unfoldr)
 import System.Environment (getProgName)
 import System.IO (hPutStrLn, stderr, hFlush, stdout)
 import System.IO.Error
@@ -169,6 +170,36 @@ rawSystemPathExit :: Int -> String -> [String] -> IO ()
 rawSystemPathExit verbose prog args = do
   maybeExit $ rawSystemPath verbose prog args
 
+-- | Like the unix xargs program. Useful for when we've got very long command
+-- lines that might overflow an OS limit on command line length and so you
+-- need to invoke a command multiple times to get all the args in.
+--
+-- Use it with either of the rawSystem variants above. For example:
+-- 
+-- > xargs (32*1024) (rawSystemPath verbose) prog fixedArgs bigArgs
+--
+xargs :: Int -> (FilePath -> [String] -> IO ExitCode)
+      -> FilePath -> [String] -> [String] -> IO ExitCode
+xargs maxSize rawSystem prog fixedArgs bigArgs =
+  let fixedArgSize = sum (map length fixedArgs)
+      chunkSize = maxSize - fixedArgSize
+      loop [] = return ExitSuccess
+      loop (args:remainingArgs) = do
+        status <- rawSystem prog (fixedArgs ++ args)
+        case status of
+          ExitSuccess -> loop remainingArgs
+          _           -> return status
+   in loop (chunks chunkSize bigArgs)
+
+  where chunks len = unfoldr $ \s ->
+          if null s then Nothing
+                    else Just (chunk [] len s)
+
+        chunk acc len []     = (reverse acc,[])
+        chunk acc len (s:ss)
+          | len' < len = chunk (s:acc) (len-len'-1) ss
+          | otherwise  = (reverse acc, s:ss)
+          where len' = length s
 
 -- ------------------------------------------------------------
 -- * File Utilities