Merge pull request haskell#9367 from MercuryTechnologies/gabriella/re…

…sponse_files_2

Use response files for `ghc` invocations

Cabal/src/Distribution/Simple/GHC.hs

@@ -627,6 +627,8 @@ startInterpreter verbosity progdb comp platform packageDBs = do
           }
   checkPackageDbStack verbosity comp packageDBs
   (ghcProg, _) <- requireProgram verbosity ghcProgram progdb
+  -- This doesn't pass source file arguments to GHC, so we don't have to worry
+  -- about using a response file here.
   runGHC verbosity ghcProg comp platform Nothing replOpts
 
 -- -----------------------------------------------------------------------------

Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs

@@ -23,6 +23,7 @@ import Distribution.Simple.GHC.Build.Modules
 import Distribution.Simple.GHC.Build.Utils
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program.Types
+import Distribution.Simple.Setup.Common (commonSetupTempFileOptions)
 import Distribution.System (Arch (JavaScript), Platform (..))
 import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Utils.Path
@@ -176,7 +177,17 @@ buildExtraSources
         sources = viewSources (targetComponent targetInfo)
         comp = compiler lbi
         platform = hostPlatform lbi
-        runGhcProg = runGHC verbosity ghcProg comp platform
+        tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat
+        runGhcProg =
+          runGHCWithResponseFile
+            "ghc.rsp"
+            Nothing
+            tempFileOptions
+            verbosity
+            ghcProg
+            comp
+            platform
+            mbWorkDir
 
         buildAction :: SymbolicPath Pkg File -> IO ()
         buildAction sourceFile = do
@@ -219,7 +230,7 @@ buildExtraSources
               compileIfNeeded :: GhcOptions -> IO ()
               compileIfNeeded opts = do
                 needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts
-                when needsRecomp $ runGhcProg mbWorkDir opts
+                when needsRecomp $ runGhcProg opts
 
           createDirectoryIfMissingVerbose verbosity True (i odir)
           case targetComponent targetInfo of
@@ -251,6 +262,7 @@ buildExtraSources
                 DynWay -> compileIfNeeded sharedSrcOpts
                 ProfWay -> compileIfNeeded profSrcOpts
                 ProfDynWay -> compileIfNeeded profSharedSrcOpts
+
       -- build any sources
       if (null sources || componentIsIndefinite clbi)
         then return mempty

Cabal/src/Distribution/Simple/GHC/Build/Link.hs

@@ -98,6 +98,7 @@ linkOrLoadComponent
       clbi = buildCLBI pbci
       isIndef = componentIsIndefinite clbi
       mbWorkDir = mbWorkDirLBI lbi
+      tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what
 
       -- See Note [Symbolic paths] in Distribution.Utils.Path
       i = interpretSymbolicPathLBI lbi
@@ -188,10 +189,25 @@ linkOrLoadComponent
         -- exports.
         when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $
           warn verbosity "No exposed modules"
-        runReplOrWriteFlags ghcProg lbi replFlags replOpts_final (pkgName (PD.package pkg_descr)) target
+        runReplOrWriteFlags
+          ghcProg
+          lbi
+          replFlags
+          replOpts_final
+          (pkgName (PD.package pkg_descr))
+          target
       _otherwise ->
         let
-          runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir
+          runGhcProg =
+            runGHCWithResponseFile
+              "ghc.rsp"
+              Nothing
+              tempFileOptions
+              verbosity
+              ghcProg
+              comp
+              platform
+              mbWorkDir
           platform = hostPlatform lbi
           comp = compiler lbi
           get_rpaths ways =
@@ -730,8 +746,19 @@ runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target =
       common = configCommonFlags $ configFlags lbi
       mbWorkDir = mbWorkDirLBI lbi
       verbosity = fromFlag $ setupVerbosity common
+      tempFileOptions = commonSetupTempFileOptions common
    in case replOptionsFlagOutput (replReplOptions rflags) of
-        NoFlag -> runGHC verbosity ghcProg comp platform mbWorkDir ghcOpts
+        NoFlag ->
+          runGHCWithResponseFile
+            "ghc.rsp"
+            Nothing
+            tempFileOptions
+            verbosity
+            ghcProg
+            comp
+            platform
+            mbWorkDir
+            ghcOpts
         Flag out_dir -> do
           let uid = componentUnitId clbi
               this_unit = prettyShow uid

Cabal/src/Distribution/Simple/GHC/Build/Modules.hs

@@ -137,20 +137,29 @@ buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neede
       | BuildRepl{} <- what = True
       | otherwise = False
 
-  -- TODO: do we need to put hs-boot files into place for mutually recursive
-  -- modules?  FIX: what about exeName.hi-boot?
+    -- TODO: do we need to put hs-boot files into place for mutually recursive
+    -- modules?  FIX: what about exeName.hi-boot?
 
-  -- Determine if program coverage should be enabled and if so, what
-  -- '-hpcdir' should be.
-  let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi
-      hpcdir way
-        | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir </> extraCompilationArtifacts) way
-        | otherwise = mempty
+    -- Determine if program coverage should be enabled and if so, what
+    -- '-hpcdir' should be.
+    isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi
+    hpcdir way
+      | forRepl = mempty -- HPC is not supported in ghci
+      | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir </> extraCompilationArtifacts) way
+      | otherwise = mempty
 
-  let
     mbWorkDir = mbWorkDirLBI lbi
-    runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir
+    tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what
+    runGhcProg =
+      runGHCWithResponseFile
+        "ghc.rsp"
+        Nothing
+        tempFileOptions
+        verbosity
+        ghcProg
+        comp
+        platform
+        mbWorkDir
     platform = hostPlatform lbi
 
     (hsMains, scriptMains) =

Cabal/src/Distribution/Simple/Program/GHC.hs

@@ -16,6 +16,7 @@ module Distribution.Simple.Program.GHC
   , ghcInvocation
   , renderGhcOptions
   , runGHC
+  , runGHCWithResponseFile
   , packageDbArgsDb
   , normaliseGhcArgs
   ) where
@@ -32,8 +33,10 @@ import Distribution.Simple.Compiler
 import Distribution.Simple.Flag
 import Distribution.Simple.GHC.ImplInfo
 import Distribution.Simple.Program.Find (getExtraPathEnv)
+import Distribution.Simple.Program.ResponseFile
 import Distribution.Simple.Program.Run
 import Distribution.Simple.Program.Types
+import Distribution.Simple.Utils (TempFileOptions, infoNoWrap)
 import Distribution.System
 import Distribution.Types.ComponentId
 import Distribution.Types.ParStrat
@@ -42,17 +45,19 @@ import Distribution.Utils.Path
 import Distribution.Verbosity
 import Distribution.Version
 
+import GHC.IO.Encoding (TextEncoding)
 import Language.Haskell.Extension
 
 import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Data.Monoid (All (..), Any (..), Endo (..))
 import qualified Data.Set as Set
+import qualified System.Process as Process
 
 normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
 normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
   | ghcVersion `withinRange` supportedGHCVersions =
-      argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs
+      argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs
   where
     supportedGHCVersions :: VersionRange
     supportedGHCVersions = orLaterVersion (mkVersion [8, 0])
@@ -162,18 +167,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
       flagArgumentFilter
         ["-ghci-script", "-H", "-interactive-print"]
 
-    filterRtsOpts :: [String] -> [String]
-    filterRtsOpts = go False
-      where
-        go :: Bool -> [String] -> [String]
-        go _ [] = []
-        go _ ("+RTS" : opts) = go True opts
-        go _ ("-RTS" : opts) = go False opts
-        go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts
-          where
-            addOpt
-              | isRTSopts = id
-              | otherwise = (opt :)
+    -- \| Remove RTS arguments from a list.
+    filterRtsArgs :: [String] -> [String]
+    filterRtsArgs = snd . splitRTSArgs
 
     simpleFilters :: String -> Bool
     simpleFilters =
@@ -647,6 +643,81 @@ runGHC verbosity ghcProg comp platform mbWorkDir opts = do
   runProgramInvocation verbosity
     =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts
 
+runGHCWithResponseFile
+  :: FilePath
+  -> Maybe TextEncoding
+  -> TempFileOptions
+  -> Verbosity
+  -> ConfiguredProgram
+  -> Compiler
+  -> Platform
+  -> Maybe (SymbolicPath CWD (Dir Pkg))
+  -> GhcOptions
+  -> IO ()
+runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do
+  invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts
+
+  let compilerSupportsResponseFiles =
+        case compilerCompatVersion GHC comp of
+          -- GHC 9.4 is the first version which supports response files.
+          Just version -> version >= mkVersion [9, 4]
+          Nothing -> False
+
+      args = progInvokeArgs invocation
+
+      -- Don't use response files if the first argument is `--interactive`, for
+      -- two related reasons.
+      --
+      -- `hie-bios` relies on a hack to intercept the command-line that `Cabal`
+      -- supplies to `ghc`.  Specifically, `hie-bios` creates a script around
+      -- `ghc` that detects if the first option is `--interactive` and if so then
+      -- instead of running `ghc` it prints the command-line that `ghc` was given
+      -- instead of running the command:
+      --
+      -- https://github.com/haskell/hie-bios/blob/ce863dba7b57ded20160b4f11a487e4ff8372c08/wrappers/cabal#L7
+      --
+      -- … so we can't store that flag in the response file, otherwise that will
+      -- break.  However, even if we were to add a special-case to keep that flag
+      -- out of the response file things would still break because `hie-bios`
+      -- stores the arguments to `ghc` that the wrapper script outputs and reuses
+      -- them later.  That breaks if you use a response file because it will
+      -- store an argument like `@…/ghc36000-0.rsp` which is a temporary path
+      -- that no longer exists after the wrapper script completes.
+      --
+      -- The work-around here is that we don't use a response file at all if the
+      -- first argument (and only the first argument) to `ghc` is
+      -- `--interactive`.  This ensures that `hie-bios` and all downstream
+      -- utilities (e.g. `haskell-language-server`) continue working.
+      --
+      --
+      useResponseFile =
+        case args of
+          "--interactive" : _ -> False
+          _ -> compilerSupportsResponseFiles
+
+  if not useResponseFile
+    then runProgramInvocation verbosity invocation
+    else do
+      let (rtsArgs, otherArgs) = splitRTSArgs args
+
+      withResponseFile
+        verbosity
+        tempFileOptions
+        fileNameTemplate
+        encoding
+        otherArgs
+        $ \responseFile -> do
+          let newInvocation =
+                invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs}
+
+          infoNoWrap verbosity $
+            "GHC response file arguments: "
+              <> case otherArgs of
+                [] -> ""
+                arg : args' -> Process.showCommandForUser arg args'
+
+          runProgramInvocation verbosity newInvocation
+
 ghcInvocation
   :: Verbosity
   -> ConfiguredProgram
@@ -960,6 +1031,26 @@ packageDbArgs implInfo
   | flagPackageConf implInfo = packageDbArgsConf
   | otherwise = packageDbArgsDb
 
+-- | Split a list of command-line arguments into RTS arguments and non-RTS
+-- arguments.
+splitRTSArgs :: [String] -> ([String], [String])
+splitRTSArgs args =
+  let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs)
+      addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs)
+
+      go _ [] = ([], [])
+      go isRTSArg (arg : rest) =
+        case arg of
+          "+RTS" -> addRTSArg arg $ go True rest
+          "-RTS" -> addRTSArg arg $ go False rest
+          "--RTS" -> ([arg], rest)
+          "--" -> ([], arg : rest)
+          _ ->
+            if isRTSArg
+              then addRTSArg arg $ go isRTSArg rest
+              else addNonRTSArg arg $ go isRTSArg rest
+   in go False args
+
 -- -----------------------------------------------------------------------------
 -- Boilerplate Monoid instance for GhcOptions
 

changelog.d/pr-9367

@@ -0,0 +1,21 @@
+---
+synopsis: "Use response files when calling `ghc`"
+packages: [Cabal]
+prs: 9367
+---
+
+Cabal now passes GHC arguments through a response file. This prevents an error
+where very large packages would fail to build due to the module names exceeding
+the `ARG_MAX` command-line length limit:
+
+```
+ghc: createProcess: posix_spawnp: resource exhausted (Argument list too long)
+```
+
+Notes:
+- Response files will not be used if the first argument to `ghc` is
+  `--interactive`.
+- RTS options (like `+RTS -H32m -S -RTS`) will not be included in response
+  files.
+- For reproducing commands after Cabal exits, `--keep-temp-files` can be used
+  to prevent the response files from being deleted.