Fix gcc.exe: error: CreateProcess: No such file or directory

When GHC links binaries on windows, we pass a -L and -l flag
to gcc for each dependency in the transitive dependency
closure.  As this will usually overflow the command argument
limit on windows, we use response files to pass all arguments
to gcc.  gcc however internally passes only the -l flags via
a response file to the collect2 command, but puts the -L flags
on the command line. As such if we pass enough -L flags to
gcc--even via a response file--we will eventually overflow the
command line argument length limit due to gcc passing them
to collect2 without resorting to a response file.

To prevent this from happening we move all lirbaries into a
shared temporary folder, and only need to pass a single -L
flag to gcc.  Ideally however this was fixed in gcc.

Reviewers: bgamari, Phyx

Reviewed By: bgamari

Subscribers: erikd, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4762

4 files changed, 44 insertions, 2 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index e4a9fa2150..92e3455521 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1744,6 +1744,16 @@ linkBinary' staticLink dflags o_files dep_packages = do
               in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
          | otherwise = ["-L" ++ l]
 
+    pkg_lib_path_opts <-
+      if gopt Opt_SingleLibFolder dflags
+      then do
+        libs <- getLibs dflags dep_packages
+        tmpDir <- newTempDir dflags
+        sequence_ [ copyFile lib (tmpDir </> basename)
+                  | (lib, basename) <- libs]
+        return [ "-L" ++ tmpDir ]
+      else pure pkg_lib_path_opts
+
     let
       dead_strip
         | gopt Opt_WholeArchiveHsLibs dflags = []
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 77a6185e4c..b10740b56c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -557,6 +557,13 @@ data GeneralFlag
    | Opt_OptimalApplicativeDo
    | Opt_VersionMacros
    | Opt_WholeArchiveHsLibs
+   -- copy all libs into a single folder prior to linking binaries
+   -- this should elivate the excessive command line limit restrictions
+   -- on windows, by only requiring a single -L argument instead of
+   -- one for each dependency.  At the time of this writing, gcc
+   -- forwards all -L flags to the collect2 command without using a
+   -- response file and as such breaking apart.
+   | Opt_SingleLibFolder
 
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
@@ -2820,6 +2827,8 @@ dynamic_flags_deps = [
 #endif
   , make_ord_flag defGhcFlag "relative-dynlib-paths"
       (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))
+  , make_ord_flag defGhcFlag "copy-libs-when-linking"
+      (NoArg (setGeneralFlag Opt_SingleLibFolder))
   , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))
   , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))
 
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs
index 5150b81fd1..35bed6149b 100644
--- a/compiler/main/FileCleanup.hs
+++ b/compiler/main/FileCleanup.hs
@@ -3,7 +3,7 @@ module FileCleanup
   ( TempFileLifetime(..)
   , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
   , addFilesToClean, changeTempFilesLifetime
-  , newTempName, newTempLibName
+  , newTempName, newTempLibName, newTempDir
   , withSystemTempDirectory, withTempDirectory
   ) where
 
@@ -132,6 +132,21 @@ newTempName dflags lifetime extn
                         addFilesToClean dflags lifetime [filename]
                         return filename
 
+newTempDir :: DynFlags -> IO FilePath
+newTempDir dflags
+  = do d <- getTempDir dflags
+       findTempDir (d </> "ghc_")
+  where
+    findTempDir :: FilePath -> IO FilePath
+    findTempDir prefix
+      = do n <- newTempSuffix dflags
+           let filename = prefix ++ show n
+           b <- doesDirectoryExist filename
+           if b then findTempDir prefix
+                else do createDirectory filename
+                        -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename
+                        return filename
+
 newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
   -> IO (FilePath, FilePath, String)
 newTempLibName dflags lifetime extn
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index d9c198a432..71354b1463 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -50,7 +50,7 @@ module Packages (
 
         collectArchives,
         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
-        packageHsLibs,
+        packageHsLibs, getLibs,
 
         -- * Utils
         unwireUnitId,
@@ -1761,6 +1761,14 @@ collectArchives dflags pc =
   where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc
         libs        = packageHsLibs dflags pc ++ extraLibraries pc
 
+getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)]
+getLibs dflags pkgs = do
+  ps <- getPreloadPackagesAnd dflags pkgs
+  fmap concat . forM ps $ \p -> do
+    let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p]
+                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]
+    filterM (doesFileExist . fst) candidates
+
 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
   where