diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index a8f15bc92da..ffd30bd5659 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -625,6 +625,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 -- ----------------------------------------------------------------------------- diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index 31aa92a3b2a..166f2a2ebc5 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -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 @@ -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 @@ -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 diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index 3f9f00c9d28..7b87092514f 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -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 @@ -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 = @@ -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 @@ -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 diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs index 2e8ba35ccb6..257d458cad1 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/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 + responseFileDir = coerceSymbolicPath buildTargetDir + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + responseFileDir + verbosity + ghcProg + comp + platform + mbWorkDir platform = hostPlatform lbi (hsMains, scriptMains) = diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index a0655793792..12027ce35c0 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/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 (defaultTempFileOptions) import Distribution.System import Distribution.Types.ComponentId import Distribution.Types.ParStrat @@ -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) @@ -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]) @@ -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 = @@ -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 @@ -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