GitLab

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC

Commits:

aea1d1d8

by David Eichmann at 2026-06-02T12:27:26+01:00

Hadrian: avoid response files when command line is short enough

This replaces the logic of always using response files on Windows.
With the new condition based on command line lenght, reponse files
can be avoided in many more cases (on windows).

3 changed files:

hadrian/src/Builder.hs
hadrian/src/Hadrian/Builder/Ar.hs
hadrian/src/Hadrian/Utilities.hs

Changes:

hadrian/src/Builder.hs

@@ -304,7 +304,7 @@ instance H.Builder Builder where
              case builder of
                  Ar Pack stg -> do
                      useTempFile <- arSupportsAtFile stg
 -                    if useTempFile then runAr                path buildArgs buildInputs buildOptions
 +                    if useTempFile then runAr output         path buildArgs buildInputs buildOptions
                                     else runArWithoutTempFile path buildArgs buildInputs buildOptions
                  Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions
@@ -343,7 +343,7 @@ instance H.Builder Builder where
                      Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions
                      return ()
 -                Haddock BuildPackage -> runHaddock path buildArgs buildInputs
 +                Haddock BuildPackage -> runHaddock output path buildArgs buildInputs
                  Ghc _ _ ->
                    -- Use a response file for ghc invocations to avoid issues with command line
@@ -351,9 +351,11 @@ instance H.Builder Builder where
                    -- NB: we can't put the buildArgs in a response file, because some flags require
                    -- empty arguments (such as the -dep-suffix flag), but that isn't supported
                    -- yet due to #26560.
 -                  withResponseFileOnWindows
 -                    (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions)
 +                  withResponseFileIfLongCmd
 +                    output
 +                    (toCmdArgument path <> toCmdArgument buildArgs)
                      buildInputs
 +                    (toCmdArgument buildOptions)
                  HsCpp    -> captureStdout
@@ -389,13 +391,16 @@ instance H.Builder Builder where
  -- | Invoke @haddock@ given a path to it and a list of arguments. On Windows,
  -- the input file arguments are passed as a response file.
 -runHaddock :: FilePath    -- ^ path to @haddock@
 +runHaddock :: FilePath    -- ^ output file path
 +      -> FilePath    -- ^ path to @haddock@
        -> [String]
        -> [FilePath]  -- ^ input file paths
        -> Action ()
 -runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows
 -  (cmd [haddockPath] flagArgs)
 +runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd
 +  outputFilePath
 +  (toCmdArgument haddockPath <> toCmdArgument flagArgs)
    fileInputs
 +  (CmdArgument [])
  -- TODO: Some builders are required only on certain platforms. For example,
  -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform

hadrian/src/Hadrian/Builder/Ar.hs

@@ -35,12 +35,13 @@ instance NFData   ArMode
  -- to be archived is passed via a temporary response file. Passing arguments
  -- via a response file is not supported by some versions of @ar@, in which
  -- case you should use 'runArWithoutTempFile' instead.
 -runAr :: FilePath    -- ^ path to @ar@
 +runAr :: FilePath    -- ^ Output file path
 +      -> FilePath    -- ^ path to @ar@
        -> [String]    -- ^ other arguments
        -> [FilePath]  -- ^ input file paths
        -> [CmdOption] -- ^ Additional options
        -> Action ()
 -runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
 +runAr outputFile arPath flagArgs fileArgs buildOptions = withResponseFile outputFile $ \tmp -> do
      writeFile' tmp $ unwords fileArgs
      cmd [arPath] flagArgs ('@' : tmp) buildOptions

hadrian/src/Hadrian/Utilities.hs

 +{-# LANGUAGE ImpredicativeTypes #-}
  {-# LANGUAGE TypeFamilies #-}
++
  module Hadrian.Utilities (
      -- * List manipulation
      fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
@@ -14,7 +16,7 @@ module Hadrian.Utilities (
      -- * Paths
      BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
 -    KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows,
 +    KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileIfLongCmd,
      -- * File system operations
      copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -50,7 +52,6 @@ import Development.Shake.Classes
  import Development.Shake.FilePath
  import GHC.ResponseFile (escapeArgs)
  import System.Environment (lookupEnv)
 -import System.Info.Extra (isWindows)
  import System.IO (hClose, openTempFile)
  import System.IO.Error (isPermissionError)
@@ -61,6 +62,7 @@ import qualified System.Directory.Extra as IO
  import qualified System.Info.Extra      as IO
  import qualified System.IO              as IO
  import qualified System.FilePath.Posix  as Posix
 +import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument))
  -- | Extract a value from a singleton list, or terminate with an error message
  -- if the list does not contain exactly one value.
@@ -330,26 +332,33 @@ keepResponseFiles = do
      KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
      return keep
 --- | Run an action either with command arguments direcly or by, on Windows,
 --- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@.
 +-- | Run an command with the given arguments. If the command is too long then the
 +-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@.
  --
  -- With @--keep-response-files@, the file is left on disk (if used)
 -withResponseFileOnWindows ::
 -    ([String] -> Action a)  -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows)
 -    -> [String]             -- ^ Command arguments
 -    -> Action a
 -withResponseFileOnWindows action commandArgs = do
 -    if isWindows
 -        then withResponseFile $ \tmp -> do
 -                writeFile' tmp (escapeArgs commandArgs)
 -                action ['@' : tmp]
 -        else action commandArgs
 +withResponseFileIfLongCmd :: (CmdResult c) =>
 +    FilePath        -- ^ Output file path. The response file is kept next to this with extension .rsp.
 +    -> CmdArgument  -- ^ Command and arguments before the response file arguments.
 +    -> [String]     -- ^ Response file aruguments.
 +    -> CmdArgument  -- ^ Command arguments after the response file arguments.
 +    -> Action c
 +withResponseFileIfLongCmd outputFile argsPre argsResp argsPost = do
 +    let cmdLineLengh = sum
 +            [ length arg
 +            | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost
 +            , Right arg <- args
 +            ]
 +    if cmdLineLengh >= cmdLineLengthLimit
 +        then withResponseFile outputFile $ \tmp -> do
 +                writeFile' tmp (escapeArgs argsResp)
 +                cmd argsPre ('@' : tmp) argsPost
 +        else cmd argsPre argsResp argsPost
  -- | Run an action with a response file path.
  --
  -- With @--keep-response-files@, the file is left on disk.
 -withResponseFile :: (FilePath -> Action a) -> Action a
 -withResponseFile action = do
 +withResponseFile :: FilePath -> (FilePath -> Action a) -> Action a
 +withResponseFile outputFile action = do
      keep <- keepResponseFiles
      let putVerboseResponseFile tmp = do
              verbosity <- getVerbosity
@@ -358,7 +367,9 @@ withResponseFile action = do
                  putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent)
      if keep
          then do
 -            (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
 +            let dir = takeDirectory outputFile
 +                file = takeFileName outputFile <.> "rsp"
 +            (tmp, h) <- liftIO $ openTempFile dir file
              liftIO $ hClose h
              putInfo $ "Keeping response file: " ++ tmp
              result <- action tmp