From ba3d4e1c43e6772f11f9a7105ef4bf3be8efb2df Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 28 Mar 2022 15:27:21 -0400
Subject: [PATCH] Basic response file support
Here we introduce support into our command-line parsing infrastructure
and driver for handling gnu-style response file arguments,
typically used to work around platform command-line length limitations.
Fixes #16476.
---
compiler/GHC.hs | 2 +-
compiler/GHC/Driver/CmdLine.hs | 74 ++++++++++++++++++--------------
compiler/GHC/Driver/Session.hs | 59 +++++++++++++++++++++----
docs/users_guide/9.4.1-notes.rst | 3 ++
docs/users_guide/using.rst | 11 +++++
ghc/Main.hs | 7 ++-
6 files changed, 111 insertions(+), 45 deletions(-)
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index b573f2769e0e..d3e9d3978d8b 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1900,7 +1900,7 @@ interpretPackageEnv logger dflags = do
Just envfile -> do
content <- readFile envfile
compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)
- let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
+ let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
where
diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs
index 539f27c53ed5..0c4ed95618f4 100644
--- a/compiler/GHC/Driver/CmdLine.hs
+++ b/compiler/GHC/Driver/CmdLine.hs
@@ -1,5 +1,4 @@
-
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE RankNTypes #-}
-------------------------------------------------------------------------------
--
@@ -13,9 +12,8 @@
module GHC.Driver.CmdLine
(
- processArgs, OptKind(..), GhcFlagMode(..),
- CmdLineP(..), getCmdLineState, putCmdLineState,
- Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
+ processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),
+ Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,
errorsToGhcException,
Err(..), Warn(..), WarnReason(..),
@@ -38,7 +36,10 @@ import GHC.Types.Error ( DiagnosticReason(..) )
import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
+import GHC.ResponseFile
+import Control.Exception (IOException, catch)
import Control.Monad (liftM, ap)
+import Control.Monad.IO.Class
--------------------------------------------------------
-- The Flag and OptKind types
@@ -62,6 +63,24 @@ defGhciFlag name optKind = Flag name optKind OnlyGhci
defHiddenFlag :: String -> OptKind m -> Flag m
defHiddenFlag name optKind = Flag name optKind HiddenFlag
+hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n
+hoistFlag f (Flag a b c) = Flag a (go b) c
+ where
+ go (NoArg k) = NoArg (go2 k)
+ go (HasArg k) = HasArg (\s -> go2 (k s))
+ go (SepArg k) = SepArg (\s -> go2 (k s))
+ go (Prefix k) = Prefix (\s -> go2 (k s))
+ go (OptPrefix k) = OptPrefix (\s -> go2 (k s))
+ go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))
+ go (IntSuffix k) = IntSuffix (\n -> go2 (k n))
+ go (WordSuffix k) = WordSuffix (\s -> go2 (k s))
+ go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))
+ go (PassFlag k) = PassFlag (\s -> go2 (k s))
+ go (AnySuffix k) = AnySuffix (\s -> go2 (k s))
+
+ go2 :: EwM m a -> EwM n a
+ go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws)
+
-- | GHC flag modes describing when a flag has an effect.
data GhcFlagMode
= OnlyGhc -- ^ The flag only affects the non-interactive GHC
@@ -130,6 +149,8 @@ instance Monad m => Applicative (EwM m) where
instance Monad m => Monad (EwM m) where
(EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
unEwM (k r) l e' w')
+instance MonadIO m => MonadIO (EwM m) where
+ liftIO = liftEwM . liftIO
runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
@@ -157,41 +178,18 @@ liftEwM :: Monad m => m a -> EwM m a
liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
---------------------------------------------------------
--- A state monad for use in the command-line parser
---------------------------------------------------------
-
--- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
-newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
- deriving (Functor)
-
-instance Applicative (CmdLineP s) where
- pure a = CmdLineP $ \s -> (a, s)
- (<*>) = ap
-
-instance Monad (CmdLineP s) where
- m >>= k = CmdLineP $ \s ->
- let (a, s') = runCmdLine m s
- in runCmdLine (k a) s'
-
-
-getCmdLineState :: CmdLineP s s
-getCmdLineState = CmdLineP $ \s -> (s,s)
-putCmdLineState :: s -> CmdLineP s ()
-putCmdLineState s = CmdLineP $ \_ -> ((),s)
-
-
--------------------------------------------------------
-- Processing arguments
--------------------------------------------------------
processArgs :: Monad m
- => [Flag m] -- cmdline parser spec
- -> [Located String] -- args
+ => [Flag m] -- ^ cmdline parser spec
+ -> [Located String] -- ^ args
+ -> (FilePath -> EwM m [Located String]) -- ^ response file handler
-> m ( [Located String], -- spare args
[Err], -- errors
[Warn] ) -- warnings
-processArgs spec args = do
+processArgs spec args handleRespFile = do
(errs, warns, spare) <- runEwM action
return (spare, bagToList errs, bagToList warns)
where
@@ -200,6 +198,10 @@ processArgs spec args = do
-- process :: [Located String] -> [Located String] -> EwM m [Located String]
process [] spare = return (reverse spare)
+ process (L _ ('@' : resp_file) : args) spare = do
+ resp_args <- handleRespFile resp_file
+ process (resp_args ++ args) spare
+
process (locArg@(L _ ('-' : arg)) : args) spare =
case findArg spec arg of
Just (rest, opt_kind) ->
@@ -319,6 +321,14 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
-- Utils
--------------------------------------------------------
+-- | Parse a response file into arguments.
+parseResponseFile :: MonadIO m => FilePath -> EwM m [Located String]
+parseResponseFile path = do
+ res <- liftIO $ fmap Right (readFile path) `catch`
+ \(e :: IOException) -> pure (Left e)
+ case res of
+ Left _err -> addErr "Could not open response file" >> return []
+ Right resp_file -> return $ map (mkGeneralLocated path) (unescapeArgs resp_file)
-- See Note [Handling errors when parsing command-line flags]
errorsToGhcException :: [(String, -- Location
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index c9a785b4f5ce..e6e055749264 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -160,6 +160,11 @@ module GHC.Driver.Session (
impliedOffGFlags,
impliedXFlags,
+ -- ** State
+ CmdLineP(..), runCmdLineP,
+ getCmdLineState, putCmdLineState,
+ processCmdLineP,
+
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
parseDynamicFilePragma,
@@ -262,6 +267,8 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
+import Control.Monad.Trans.State as State
+import Data.Functor.Identity
import Data.Ord
import Data.Char
@@ -1864,20 +1871,56 @@ parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]
-- list of warnings.
parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
+newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)
+
+instance Monad (CmdLineP s) where
+ CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)
+ return = pure
+
+instance Applicative (CmdLineP s) where
+ pure x = CmdLineP (pure x)
+ (<*>) = ap
+
+instance Functor (CmdLineP s) where
+ fmap f (CmdLineP k) = CmdLineP (fmap f k)
+
+getCmdLineState :: CmdLineP s s
+getCmdLineState = CmdLineP State.get
+
+putCmdLineState :: s -> CmdLineP s ()
+putCmdLineState x = CmdLineP (State.put x)
+
+runCmdLineP :: CmdLineP s a -> s -> (a, s)
+runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0
+
+-- | A helper to parse a set of flags from a list of command-line arguments, handling
+-- response files.
+processCmdLineP
+ :: forall s m. MonadIO m
+ => [Flag (CmdLineP s)] -- ^ valid flags to match against
+ -> s -- ^ current state
+ -> [Located String] -- ^ arguments to parse
+ -> m (([Located String], [Err], [Warn]), s)
+ -- ^ (leftovers, errors, warnings)
+processCmdLineP activeFlags s0 args =
+ runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0
+ where
+ getCmdLineP :: CmdLineP s a -> StateT s m a
+ getCmdLineP (CmdLineP k) = k
-- | Parses the dynamically set flags for GHC. This is the most general form of
-- the dynamic flag parser that the other methods simply wrap. It allows
-- saying which flags are valid flags and indicating if we are parsing
-- arguments from the command line or from a file pragma.
-parseDynamicFlagsFull :: MonadIO m
- => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
- -> Bool -- ^ are the arguments from the command line?
- -> DynFlags -- ^ current dynamic flags
- -> [Located String] -- ^ arguments to parse
- -> m (DynFlags, [Located String], [Warn])
+parseDynamicFlagsFull
+ :: forall m. MonadIO m
+ => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
+ -> Bool -- ^ are the arguments from the command line?
+ -> DynFlags -- ^ current dynamic flags
+ -> [Located String] -- ^ arguments to parse
+ -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
- let ((leftover, errs, warns), dflags1)
- = runCmdLine (processArgs activeFlags args) dflags0
+ ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args
-- See Note [Handling errors when parsing command-line flags]
let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index cea17cac60c4..027385917377 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -60,6 +60,9 @@ Language
Compiler
~~~~~~~~
+- The compiler now accepts arguments via GNU-style response files
+ (:ghc-ticket:`16476`).
+
- New :ghc-flag:`-Wredundant-strictness-flags` that checks for strictness flags
(``!``) applied to unlifted types, which are always strict.
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index 628dfab0f35e..ee61a89ce13b 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -85,6 +85,17 @@ all files; you cannot, for example, invoke
``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels
to the files ``Foo.hs`` and ``Bar.hs``.
+In addition to passing arguments via the command-line, arguments can be passed
+via GNU-style response files. For instance,
+
+.. code-block:: bash
+
+ $ cat response-file
+ -O1
+ Hello.hs
+ -o Hello
+ $ ghc @response-file
+
.. note::
.. index::
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 3cb71b77e80b..8e30d1a765bb 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -560,10 +560,9 @@ parseModeFlags :: [Located String]
[Located String],
[Warn])
parseModeFlags args = do
- let ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) =
- runCmdLine (processArgs mode_flags args)
- (Nothing, [], [], [])
- mode = case mModeFlag of
+ ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-
+ processCmdLineP mode_flags (Nothing, [], [], []) args
+ let mode = case mModeFlag of
Nothing -> doMakeMode
Just (m, _) -> m
--
GitLab