diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index 07ad6ac31d8..223b0f10079 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -159,7 +159,15 @@ buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcP isGhcDynamic = isDynamic comp doingTH = usesTemplateHaskellOrQQ bi forceSharedLib = doingTH && isGhcDynamic - runGhcProg = runGHC verbosity ghcProg comp platform + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + buildTargetDir + verbosity + ghcProg + comp + platform buildAction sourceFile = do let baseSrcOpts = diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index d63e6a32bea..555a460a547 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -77,6 +77,7 @@ linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) ( lbi = localBuildInfo pbci bi = buildBI pbci clbi = buildCLBI pbci + responseFileDir = buildTargetDir -- ensure extra lib dirs exist before passing to ghc cleanedExtraLibDirs <- liftIO $ filterM doesDirectoryExist (extraLibDirs bi) @@ -152,10 +153,25 @@ linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) ( -- exports. when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules" - runReplOrWriteFlags ghcProg lbi replFlags replOpts (pkgName (PD.package pkg_descr)) target + runReplOrWriteFlags + ghcProg + lbi + replFlags + replOpts + (pkgName (PD.package pkg_descr)) + target + responseFileDir _otherwise -> let - runGhcProg = runGHC verbosity ghcProg comp platform + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + responseFileDir + verbosity + ghcProg + comp + platform platform = hostPlatform lbi comp = compiler lbi in @@ -622,14 +638,24 @@ runReplOrWriteFlags -> GhcOptions -> PackageName -> TargetInfo + -> FilePath -> 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 platform = hostPlatform lbi in case replOptionsFlagOutput (replReplOptions rflags) of - NoFlag -> runGHC (fromFlag $ replVerbosity rflags) ghcProg comp platform ghcOpts + NoFlag -> + runGHCWithResponseFile + "ghc.rsp" + Nothing + responseFileDir + (fromFlag $ replVerbosity rflags) + ghcProg + comp + platform + ghcOpts Flag out_dir -> do src_dir <- getCurrentDirectory let uid = componentUnitId clbi diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs index 0a6c408ee4b..fb1ce514c9a 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -139,7 +139,15 @@ buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir wantedWays pbci = d (inputFiles, inputModules) <- componentInputs buildTargetDir pkg_descr pbci let - runGhcProg = runGHC verbosity ghcProg comp platform + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + buildTargetDir + verbosity + ghcProg + comp + platform platform = hostPlatform lbi -- See Note [Building Haskell Modules accounting for TH] diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index 71a32c4f50c..cf41ecfbf3c 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -14,6 +14,7 @@ module Distribution.Simple.Program.GHC , ghcInvocation , renderGhcOptions , runGHC + , runGHCWithResponseFile , packageDbArgsDb , normaliseGhcArgs ) where @@ -30,13 +31,16 @@ 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, infoNoWrap) import Distribution.System import Distribution.Types.ComponentId import Distribution.Utils.NubList import Distribution.Verbosity import Distribution.Version +import GHC.IO.Encoding (TextEncoding) import Language.Haskell.Extension import Data.List (stripPrefix) @@ -44,11 +48,12 @@ import qualified Data.Map as Map import Data.Monoid (All (..), Any (..), Endo (..)) import qualified Data.Set as Set import Distribution.Types.ParStrat +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]) @@ -158,18 +163,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 = @@ -638,6 +634,67 @@ runGHC runGHC verbosity ghcProg comp platform opts = do runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts +runGHCWithResponseFile + :: FilePath + -> Maybe TextEncoding + -> FilePath + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> GhcOptions + -> IO () +runGHCWithResponseFile fileNameTemplate encoding responseFileDir verbosity ghcProg comp platform opts = do + invocation <- ghcInvocation verbosity ghcProg comp platform 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 + responseFileDir + 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 @@ -939,6 +996,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