Skip to content

Commit

Permalink
Use response files for ghc invocations
Browse files Browse the repository at this point in the history
Before this change, `cabal` could fail with the following error message
when building very large Haskell packages:

```
ghc: createProcess: posix_spawnp: resource exhausted (Argument list too long)
```

This is because when the number of modules or dependencies grows large
enough, then the `ghc` command line can potentially exceed the
`ARG_MAX` command line length limit.

However, `ghc` supports response files in order to work around these
sorts of command line length limitations, so this change enables the
use of those response files.

Note that this requires taking a special precaution to not pass RTS
options to the response file because there's no way that `ghc` can
support RTS options via the response file.  The reason why is because
the Haskell runtime processes these options (not `ghc`), so if you
store the RTS options in the response file then `ghc`'s command line
parser won't know what to do with them.

This means that `ghc` commands can still potentially fail if the RTS
options get long enough, but this is less likely to occur in practice
since RTS options tend to be significantly smaller than non-RTS
options.

This also requires skipping the response file if the first argument
is `--interactive`.  See the corresponding code comment which explains
why in more detail.

Co-Authored-By: Gabriella Gonzales <GenuineGabriella@gmail.com>
  • Loading branch information
9999years and Gabriella439 committed Sep 3, 2024
1 parent 39b6924 commit b65eba1
Show file tree
Hide file tree
Showing 6 changed files with 153 additions and 31 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -34,4 +34,4 @@ md5CheckGenericPackageDescription proxy = md5Check proxy

md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
md5CheckLocalBuildInfo proxy = md5Check proxy
0x94827844fdb1afedee525061749fb16f
0xff829d7b383bcccb8192c5a61176c2e0
2 changes: 2 additions & 0 deletions Cabal/src/Distribution/Simple/GHC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

-- -----------------------------------------------------------------------------
Expand Down
15 changes: 13 additions & 2 deletions Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs
Original file line number Diff line number Diff line change
Expand Up @@ -176,7 +176,17 @@ buildExtraSources
sources = viewSources (targetComponent targetInfo)
comp = compiler lbi
platform = hostPlatform lbi
runGhcProg = runGHC verbosity ghcProg comp platform
responseFileDir = coerceSymbolicPath buildTargetDir
runGhcProg =
runGHCWithResponseFile
"ghc.rsp"
Nothing
responseFileDir
verbosity
ghcProg
comp
platform
mbWorkDir

buildAction :: SymbolicPath Pkg File -> IO ()
buildAction sourceFile = do
Expand Down Expand Up @@ -219,7 +229,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
Expand Down Expand Up @@ -251,6 +261,7 @@ buildExtraSources
DynWay -> compileIfNeeded sharedSrcOpts
ProfWay -> compileIfNeeded profSrcOpts
ProfDynWay -> compileIfNeeded profSharedSrcOpts

-- build any sources
if (null sources || componentIsIndefinite clbi)
then return mempty
Expand Down
36 changes: 32 additions & 4 deletions Cabal/src/Distribution/Simple/GHC/Build/Link.hs
Original file line number Diff line number Diff line change
Expand Up @@ -98,6 +98,7 @@ linkOrLoadComponent
clbi = buildCLBI pbci
isIndef = componentIsIndefinite clbi
mbWorkDir = mbWorkDirLBI lbi
responseFileDir = coerceSymbolicPath buildTargetDir

-- See Note [Symbolic paths] in Distribution.Utils.Path
i = interpretSymbolicPathLBI lbi
Expand Down Expand Up @@ -188,10 +189,26 @@ 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
responseFileDir
_otherwise ->
let
runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir
runGhcProg =
runGHCWithResponseFile
"ghc.rsp"
Nothing
responseFileDir
verbosity
ghcProg
comp
platform
mbWorkDir
platform = hostPlatform lbi
comp = compiler lbi
get_rpaths ways =
Expand Down Expand Up @@ -721,8 +738,9 @@ runReplOrWriteFlags
-> GhcOptions
-> PackageName
-> TargetInfo
-> SymbolicPath Pkg (Dir Response)
-> IO ()
runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target =
runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target responseFileDir =
let bi = componentBuildInfo $ targetComponent target
clbi = targetCLBI target
comp = compiler lbi
Expand All @@ -731,7 +749,17 @@ runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target =
mbWorkDir = mbWorkDirLBI lbi
verbosity = fromFlag $ setupVerbosity common
in case replOptionsFlagOutput (replReplOptions rflags) of
NoFlag -> runGHC verbosity ghcProg comp platform mbWorkDir ghcOpts
NoFlag ->
runGHCWithResponseFile
"ghc.rsp"
Nothing
responseFileDir
verbosity
ghcProg
comp
platform
mbWorkDir
ghcOpts
Flag out_dir -> do
let uid = componentUnitId clbi
this_unit = prettyShow uid
Expand Down
31 changes: 20 additions & 11 deletions Cabal/src/Distribution/Simple/GHC/Build/Modules.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
responseFileDir = coerceSymbolicPath buildTargetDir
runGhcProg =
runGHCWithResponseFile
"ghc.rsp"
Nothing
responseFileDir
verbosity
ghcProg
comp
platform
mbWorkDir
platform = hostPlatform lbi

(hsMains, scriptMains) =
Expand Down
98 changes: 85 additions & 13 deletions Cabal/src/Distribution/Simple/Program/GHC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ module Distribution.Simple.Program.GHC
, ghcInvocation
, renderGhcOptions
, runGHC
, runGHCWithResponseFile
, packageDbArgsDb
, normaliseGhcArgs
) where
Expand All @@ -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 (defaultTempFileOptions)
import Distribution.System
import Distribution.Types.ComponentId
import Distribution.Types.ParStrat
Expand All @@ -42,6 +45,7 @@ import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version

import GHC.IO.Encoding (TextEncoding)
import Language.Haskell.Extension

import Data.List (stripPrefix)
Expand All @@ -52,7 +56,7 @@ import qualified Data.Set as Set
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])
Expand Down Expand Up @@ -162,18 +166,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 =
Expand Down Expand Up @@ -646,6 +641,63 @@ runGHC verbosity ghcProg comp platform mbWorkDir opts = do
runProgramInvocation verbosity
=<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts

runGHCWithResponseFile
:: FilePath
-> Maybe TextEncoding
-> SymbolicPath Pkg (Dir Response)
-> Verbosity
-> ConfiguredProgram
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD (Dir Pkg))
-> GhcOptions
-> IO ()
runGHCWithResponseFile fileNameTemplate encoding responseFileDir verbosity ghcProg comp platform maybeWorkDir opts = do
invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts

-- 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.
case progInvokeArgs invocation of
"--interactive" : _ ->
runProgramInvocation verbosity invocation
args -> do
let (rtsArgs, otherArgs) = splitRTSArgs args

withResponseFile
verbosity
defaultTempFileOptions
maybeWorkDir
responseFileDir
fileNameTemplate
encoding
otherArgs
$ \responseFile -> do
let newInvocation =
invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs}

runProgramInvocation verbosity newInvocation

ghcInvocation
:: Verbosity
-> ConfiguredProgram
Expand Down Expand Up @@ -959,6 +1011,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

Expand Down

0 comments on commit b65eba1

Please sign in to comment.