Magnus pushed to branch wip/mangoiv/27817 at Glasgow Haskell Compiler / GHC Commits: 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 04aecb97 by mangoiv at 2026-09-22T12:22:12+02:00 ci: move hadrian/ghci into the lint category so it can be picked up by more runners Fixes #27817 - - - - - a14b3f58 by mangoiv at 2026-09-22T12:22:14+02:00 ci: make lint-adjacent jobs into platform independent - move lint jobs into lint-anyarch tag - unify lint jobs under the same platform independent container - - - - - 18 changed files: - .gitlab-ci.yml - + changelog.d/25763-cmdline-opt - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Session.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/driver/all.T - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -137,15 +137,37 @@ workflow: .lint: stage: tool-lint tags: - - lint - before_script: - # Allow Git to read from the runner-owned checkout. This is needed - # for example by the lint-author job. - - git config --global --add safe.directory "$CI_PROJECT_DIR" + - lint-anyarch + image: debian:13 rules: - *drafts-can-fail-lint - when: always +.install-ghc-toolchain: &install-ghc-toolchain + - apt update + - apt install -qy build-essential curl libffi-dev libffi8 libgmp-dev libgmp10 libncurses-dev libncurses6 libtinfo6 pkg-config python3 cmake git happy alex autoconf automake python3 libgmp-dev libnuma-dev libncurses-dev + - curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh + - source /root/.ghcup/env + - ghcup --no-verbose install ghc --set --install-targets 'install_bin install_lib update_package_db' '9.10' + - ghcup --no-verbose install cabal --set + - ghc --info + - cabal --version + +# linting but we need a boot toolchain +.lint-ghc-toolchain: + extends: .lint + before_script: + - *install-ghc-toolchain + - git config --global --add safe.directory "$CI_PROJECT_DIR" + +# linting but we need python +.lint-python: + extends: .lint + before_script: + - apt update + - apt install -qy python3 mypy shellcheck git + - git config --global --add safe.directory "$CI_PROJECT_DIR" + .nightly: &nightly variables: XZ_OPT: "-9" @@ -217,11 +239,11 @@ not-interruptible: stage: not-interruptible script: "true" interruptible: false - image: "debian:13" + image: debian:13 variables: GIT_STRATEGY: none tags: - - lint + - lint-anyarch rules: # - if: '$CI_COMMIT_BRANCH == "master"' # when: always @@ -242,7 +264,6 @@ include: '.gitlab/jobs.yaml' ghc-linters: stage: tool-lint - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint-params variables: BUILD_FLAVOUR: default @@ -258,16 +279,11 @@ ghc-linters: # Skipped if the MR has the ~"no-changelog" label. lint-changelog: stage: tool-lint - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-ghc-toolchain variables: CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID" GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - - export PATH="/opt/toolchain/bin:$PATH" - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - .gitlab/ci.sh lint_changelog dependencies: [] @@ -279,42 +295,30 @@ lint-changelog: # Run mypy Python typechecker on linter scripts. lint-linters: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - mypy testsuite/tests/linters/regex-linters/*.py dependencies: [] # Check that .T files all parse by listing broken tests. lint-testsuite: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-ghc-toolchain variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - - make -Ctestsuite list_broken TEST_HC=$GHC + - make -Ctestsuite list_broken TEST_HC=$(which ghc) dependencies: [] # Run mypy Python typechecker on testsuite driver typecheck-testsuite: - image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_DEPTH: 1 GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - mypy testsuite/driver/runtests.py dependencies: [] @@ -323,7 +327,6 @@ typecheck-testsuite: # accommodate, e.g., haddock changes not yet upstream) but not on `master` or # Marge jobs. .lint-submods: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint-params variables: BUILD_FLAVOUR: default @@ -341,13 +344,9 @@ typecheck-testsuite: # Check that commits in an MR were not authored with the identity that CI uses # when it needs to create commits itself. This only needs Git history. lint-author: - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - extends: .lint + extends: .lint-python variables: GIT_SUBMODULE_STRATEGY: none - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" @@ -425,12 +424,9 @@ lint-submods-branch: .lint-params: needs: [] - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" extends: .lint before_script: - - export PATH="/opt/toolchain/bin:$PATH" - # workaround for docker permissions - - sudo chown ghc:ghc -R . + - *install-ghc-toolchain - .gitlab/ci.sh setup after_script: - .gitlab/ci.sh save_cache @@ -448,18 +444,13 @@ lint-submods-branch: hadrian-ghc-in-ghci: stage: quick-build + extends: .lint-ghc-toolchain needs: - job: lint-linters - job: lint-submods optional: true - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . variables: GHC_FLAGS: -Werror -Wwarn=unused-imports - tags: - - x86_64-linux script: - git clean -xdf && git submodule foreach git clean -xdf - . .gitlab/ci.sh setup @@ -493,9 +484,6 @@ hadrian-multi: optional: true dependencies: null image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . variables: GHC_FLAGS: "-Werror=-Wno-error=incomplete-record-selectors -Wwarn=deprecations -Wwarn=unused-imports" # -Wno-error=incomplete-record-selectors is present because -Wall now @@ -1055,9 +1043,6 @@ perf: image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" tags: - x86_64-linux-perf - before_script: - # workaround for docker permissions - - sudo chown ghc:ghc -R . script: - root=$(pwd)/ghc - | ===================================== changelog.d/25763-cmdline-opt ===================================== @@ -0,0 +1,19 @@ +section: compiler +synopsis: Speed up command line parser with a trie map +description: + Parsing flags is now faster when there are many flags to parse. + + There is a new trie implementation with String keys in ``GHC.Data.StringTrie``. + + Added a new abstract type ``FlagSpecTrie`` to represent tries of flags. + + ``GHC.Driver.Session`` gets ``flagsDynamic`` removed and ``flagsDynamicTrie`` + added with type ``FlagSpecTrie``. ``processCmdLineP`` and ``parseDynamicFlagsFull`` + now have a ``FlagSpecTrie`` parameter instead of a list. + + ``GHC.Driver.Session.Mode`` gets a value ``mode_flags_trie`` of type ``FlagSpecTrie``. + + ``GHC.Driver.CmdLine.processArgs`` now gets a ``FlagSpecTrie`` argument instead + of a list. +mrs: !16392 +issues: #25763 ===================================== compiler/GHC/Data/StringTrie.hs ===================================== @@ -0,0 +1,148 @@ +module GHC.Data.StringTrie + ( StringTrie(..) + , empty + , insert + , fromList + , fromListWithSparseness + , lookup + ) where + +import GHC.Prelude hiding (lookup) + +import Data.Array (Array, accumArray, assocs) +import Data.Maybe (fromMaybe) +import qualified Data.IntMap.Lazy as M + +-- | A trie mapping strings to values of type @a@. +-- +-- See #25763 and Note [Optimising the processing of command-line arguments] +-- in "GHC.Driver.Session". +data StringTrie a + = -- | A value and other children under the same path. + -- + -- The 'IntMap' can be empty. + STNode a (M.IntMap (StringTrie a)) + -- | There is no value at this path, but there are children under it + -- + -- The 'IntMap' must be non-empty, so 'STEmpty' remains the only way to + -- represent a trie with no values. + | STFork (M.IntMap (StringTrie a)) + -- | A trie with no values + | STEmpty + deriving (Eq, Show) + +-- | There are no key-value pairs in this trie. +empty :: StringTrie a +empty = STEmpty + +-- | Inserts a key-value pair into the trie. When a value for the key is already +-- present, the new value replaces the old one. +insert :: forall a. String -> a -> StringTrie a -> StringTrie a +insert k0 v = go k0 + where + go :: String -> StringTrie a -> StringTrie a + go (x:xs) STEmpty = STFork $ M.singleton (fromEnum x) (go xs STEmpty) + go "" STEmpty = STNode v M.empty + go "" (STFork children) = STNode v children + go (x:xs) (STFork children) = + STFork (M.insert (fromEnum x) child children) + where + child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children) + + go "" (STNode _ children) = STNode v children + go (x:xs) (STNode vs children) = + STNode vs (M.insert (fromEnum x) child children) + where + child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children) + +-- | Returns the values associated with prefixes of a query string as well as +-- the non-matching suffix. The matches are returned ordered by suffix length. +-- +-- Examples: +-- +-- > lookup "abc" (fromList [("ab", 2), ("abc", 3), ("b", 4)]) == [(3, ""), (2, "c")] +-- > lookup "abc" (fromList [("ab", 2), ("ab", 3)]) == [(3, "c")] +-- > lookup "ba" (fromList [("ab", 2), ("abc", 3)]) == [] +-- +-- More formally: +-- +-- @(v, suffix)@ is in @lookup queryString t@ iff there is a string @k@ such that +-- * @(k, v)@ is in @t@, and +-- * @k ++ suffix == queryString@. +lookup + :: String + -> StringTrie a + -> [(a, String)] +lookup = go [] + where + go :: [(a, String)] -> String -> StringTrie a -> [(a, String)] + -- + -- In @lookup queryString t@ and @go acc unmatchedSuffix t'@, + -- + -- unmatchedSuffix is a suffix of queryString, and t' is the subtrie + -- of t at path @queryString - unmatchedSuffix@. + -- + -- (v, suffix) is in acc iff there is a k such that + -- * (k, v) is in t, and + -- * @k ++ suffix == queryString@, and + -- * @unmatchedSuffix /= suffix@. + go acc [] (STNode v _) = (v, "") : acc + go acc [] (STFork _) = acc + go acc _ STEmpty = acc + go acc unmatchedSuffix@(c:rest) (STNode v children) = + let acc' = (v, unmatchedSuffix) : acc + in maybe acc' (go acc' rest) (M.lookup (fromEnum c) children) + go acc (c:rest) (STFork children) = + maybe acc (go acc rest) (M.lookup (fromEnum c) children) + +-- | Constructs a trie from a list of key-value pairs. +-- +-- Later entries in the list will overwrite earlier ones with the same key. +-- +-- Equivalent to @foldl (\t (k, v) -> insert k v t) empty@, but lazier: the +-- subtrie for each first character is only built when demanded. +fromList :: [(String, a)] -> StringTrie a +fromList = fromListWithSparseness 32 + +-- | Like 'fromList', but allows the caller to specify a threshold for when to use +-- an array to sort the keys. +fromListWithSparseness :: Int -> [(String, a)] -> StringTrie a +fromListWithSparseness sparseness = go + where + go [] = STEmpty + go xs = + let revxs = reverse xs + valuesWithEmptyKeys = filter (null . fst) revxs + children = M.map go (headBuckets sparseness revxs) + in case valuesWithEmptyKeys of + (_, v) : _ -> STNode v children + _ -> STFork children + + -- Group the entries with a non-empty key by their first character (in reverse order). + -- + -- Discards entries with an empty key. Uses an array to sort the entries, unless the + -- entries are too sparse. + headBuckets :: Int -> [(String, a)] -> M.IntMap [(String, a)] + headBuckets sparseness kvs + -- Entries are too sparse if they are too few or if they span too large a range + -- of characters. + | null (drop sparseness kvs) || any non_ascii kvs + = M.fromListWith (++) [ (fromEnum c, [(cs, v)]) | (c:cs, v) <- kvs ] + | otherwise + = M.fromDistinctAscList + [ (i, group) | (i, group) <- assocs (bucketsArr kvs), not (null group) ] + + -- @(k, v)@ is in @bucketsArr kvs ! i@ iff @(tail k, v)@ is in @kvs@ and + -- @fromEnum (head k) == i@. + -- + -- Note: Discard entries with an empty key. + bucketsArr :: [(String, a)] -> Array Int [(String, a)] + bucketsArr kvs = + accumArray + (flip (:)) + [] + (0, 0x7f) + [ (fromEnum c, (cs, v)) | (c:cs, v) <- kvs ] + + non_ascii (c:_, _) = fromEnum c > 0x7f + non_ascii ([], _) = False ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -3,6 +3,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- -- | ===================================== compiler/GHC/Data/Word64Set/Internal.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- -- | ===================================== compiler/GHC/Driver/CmdLine.hs ===================================== @@ -1,8 +1,9 @@ +{-# LANGUAGE BangPatterns #-} ------------------------------------------------------------------------------- -- -- | Command-line parser -- --- This is an abstract command-line parser used by DynFlags. +-- This is a command-line parser used by DynFlags. -- -- (c) The University of Glasgow 2005 -- @@ -10,13 +11,26 @@ module GHC.Driver.CmdLine ( - processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..), - Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag, - errorsToGhcException, + processArgs, + + -- ** Flags + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + OptKind(..), GhcFlagMode(..), + + -- ** EwM monad + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, Err(..), Warn, warnsToMessages, - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM + -- ** FlagSpecTrie + FlagSpecTrie, mkFlagSpecTrie, extendFlagSpecTrie, + + -- ** State + CmdLineP(..), runCmdLineP, + getCmdLineState, putCmdLineState, + + -- ** Utils + parseResponseFile, errorsToGhcException ) where import GHC.Prelude @@ -24,6 +38,7 @@ import GHC.Prelude import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Bag +import qualified GHC.Data.StringTrie as StringTrie import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Error @@ -31,14 +46,16 @@ import GHC.Driver.Errors.Types import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage import GHC.Utils.Outputable (text) -import Data.Function -import Data.List (sortBy, intercalate, stripPrefix) +import Data.List (intercalate) import Data.Word import GHC.ResponseFile import Control.Exception (IOException, catch) import Control.Monad (ap) import Control.Monad.IO.Class +import Control.Monad.Trans.State (StateT) +import qualified Control.Monad.Trans.State as State +import Data.Functor.Identity (runIdentity) -------------------------------------------------------- -- The Flag and OptKind types @@ -62,24 +79,6 @@ 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 (Word64Suffix k) = Word64Suffix (\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 @@ -159,6 +158,9 @@ getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +hoistEwM :: (forall a. m a -> n a) -> EwM m b -> EwM n b +hoistEwM f (EwM g) = EwM $ \loc es ws -> f (g loc es ws) + warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage warnsToMessages diag_opts = foldr (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws) @@ -168,20 +170,70 @@ warnsToMessages diag_opts = foldr -- Processing arguments -------------------------------------------------------- -processArgs :: Monad m - => [Flag m] -- ^ cmdline parser spec - -> [Located String] -- ^ args - -> (FilePath -> EwM m [Located String]) -- ^ response file handler - -> m ( [Located String], -- spare args +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) + +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 + +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 $ State.runStateT k s0 + +-- | Flag specifications as a trie map +-- +-- No two flags with the same 'flagName' are allowed. +-- +-- See Note [Optimising the processing of command-line arguments] +-- in GHC.Driver.Session. +newtype FlagSpecTrie s = + -- | The key of each 'Flag' @f@ is @flagName f@. + FlagSpecTrie { unFlagSpecTrie :: StringTrie.StringTrie (Flag (CmdLineP s)) } + +-- | Construct a 'FlagSpecTrie' from a list of flags. +-- +-- Precondition: No two flags in the list have the same flag name. +mkFlagSpecTrie :: [Flag (CmdLineP s)] -> FlagSpecTrie s +mkFlagSpecTrie flags = + FlagSpecTrie $ StringTrie.fromList [ (flagName f, f) | !f <- flags ] +{-# INLINE mkFlagSpecTrie #-} + +-- | Add flags to an existing 'FlagSpecTrie'. +-- +-- Precondition: No two flags in the trie plus the list have the same flag name. +extendFlagSpecTrie :: FlagSpecTrie s -> [Flag (CmdLineP s)] -> FlagSpecTrie s +extendFlagSpecTrie (FlagSpecTrie t) flags = + FlagSpecTrie $ foldl' (\acc f -> StringTrie.insert (flagName f) f acc) t flags +{-# INLINE extendFlagSpecTrie #-} + +processArgs :: forall s m. Monad m + => FlagSpecTrie s -- ^ cmdline parser spec + -> [Located String] -- ^ args + -> (FilePath -> EwM (StateT s m) [Located String]) -- ^ response file handler + -> StateT s m + ( [Located String], -- spare args [Err], -- errors Warns ) -- warnings processArgs spec args handleRespFile = do (errs, warns, spare) <- runEwM action return (spare, bagToList errs, warns) where + getCmdLineP :: CmdLineP s a -> StateT s m a + getCmdLineP (CmdLineP k) = k + action = process args [] - -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process :: [Located String] -> [Located String] -> EwM (StateT s m) [Located String] process [] spare = return (reverse spare) process (L _ ('@' : resp_file) : args) spare = do @@ -189,7 +241,7 @@ processArgs spec args handleRespFile = do process (resp_args ++ args) spare process (locArg@(L _ ('-' : arg)) : args) spare = - case findArg spec arg of + case findArg (unFlagSpecTrie spec) arg of Just (rest, opt_kind) -> case processOneArg opt_kind rest arg args of Left err -> @@ -198,7 +250,7 @@ processArgs spec args handleRespFile = do Right (action,rest) -> let b = process rest spare - in (setArg locArg $ action) >> b + in setArg locArg (hoistEwM getCmdLineP action) >> b Nothing -> process args (locArg : spare) @@ -246,31 +298,38 @@ processOneArg opt_kind rest arg args OptPrefix f -> Right (f rest_no_eq, args) AnySuffix f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) -findArg spec arg = - case sortBy (compare `on` (length . fst)) -- prefer longest matching flag - [ (removeSpaces rest, optKind) - | flag <- spec, - let optKind = flagOptKind flag, - Just rest <- [stripPrefix (flagName flag) arg], - arg_ok optKind rest arg ] - of - [] -> Nothing - (one:_) -> Just one - -arg_ok :: OptKind t -> [Char] -> String -> Bool -arg_ok (NoArg _) rest _ = null rest -arg_ok (HasArg _) _ _ = True -arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t - -- to improve error message (#12625) -arg_ok (OptIntSuffix _) _ _ = True -arg_ok (IntSuffix _) _ _ = True -arg_ok (Word64Suffix _) _ _ = True -arg_ok (FloatSuffix _) _ _ = True -arg_ok (OptPrefix _) _ _ = True -arg_ok (PassFlag _) rest _ = null rest -arg_ok (AnySuffix _) _ _ = True +-- | Find a flag in the trie whose name is a prefix of the given string. +-- +-- The unmatched suffix of the string is returned along with the 'OptKind'. +-- +-- A flag is only returned if the suffix is valid for the 'OptKind' of the flag. +-- For example, a flag with 'NoArg' will only be returned if the suffix is +-- empty. More concretely, @-Wallx@ will produce an invalid suffix @"x"@ since +-- @-Wall@ has @OptKind@ 'NoArg'. +-- +-- If more than one flag name is a prefix of the string, the longest match with +-- a valid suffix is returned. +findArg :: StringTrie.StringTrie (Flag m) -> String -> Maybe (String, OptKind m) +findArg trie arg = + case filter (uncurry valid_flag_suffix) $ StringTrie.lookup arg trie of + [] -> Nothing + (flag, rest) : _ -> Just (removeSpaces rest, flagOptKind flag) + where + valid_flag_suffix :: Flag m -> String -> Bool + valid_flag_suffix flag rest = + case flagOptKind flag of + NoArg _ -> null rest + HasArg _ -> True + SepArg _ -> null rest + Prefix _ -> True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) + OptIntSuffix _ -> True + IntSuffix _ -> True + Word64Suffix _ -> True + FloatSuffix _ -> True + OptPrefix _ -> True + PassFlag _ -> null rest + AnySuffix _ -> True -- | Parse an Int -- ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -181,7 +181,8 @@ module GHC.Driver.Session ( -- ** Available DynFlags allNonDeprecatedFlags, flagsAll, - flagsDynamic, + flagsAllTrie, + flagsDynamicTrie, flagsPackage, flagsForCompletion, @@ -294,8 +295,7 @@ import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion ) import Data.IORef import Control.Arrow ((&&&)) import Control.Monad -import Control.Monad.Trans.State as State -import Data.Functor.Identity +import Control.Monad.Trans.State (runStateT) import Data.Ord import Data.Char @@ -391,6 +391,37 @@ import Language.Haskell.Syntax.Text -- -- See #4437 and #8176. +-- Note [Optimising the processing of command-line arguments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For each command line argument we need to search all the possible flag names to +-- find the correct command-line argument processor (of type `CmdLineP DynFlags`) +-- to complete parsing of the argument and modify the `DynFlags`. +-- +-- GHC has a LOT of flags, and occasionally, users give a LOT of command line +-- arguments. So in some cases it pays to optimize the search for a command-line +-- argument processor (#25763). +-- +-- An additional complication is that flag specs need to be looked up with a +-- string that may contain the flag key as a prefix. +-- +-- In general, the `=` sign is optional, and anything after the name of the flag, +-- if it doesn't start with `=`, is considered the argument. E.g. +-- `-odirsome/path`, or `-pgmFprogram`, or `-package-dbDiff`, or `-optc-DFOO`, +-- or `-Isome/path`, or `-fpluginLiquidHaskell`, or `-fplugin-optLiquidHaskell:--save`. +-- +-- To achieve this: +-- +-- * We build global lookup tables +-- * GHC.Driver.Session.flagsAllTrie :: FlagSpecTrie DynFlags +-- * GHC.Driver.Session.flagsDynamicTrie :: FlagSpecTrie DynFlags +-- * GHC.Driver.Session.Mode.mode_flags_trie :: FlagSpecTrie ModeMS +-- +-- These are implemented by a trie indexed by Strings, see GHC.Data.StringTrie. +-- +-- * As we process each command line argument, one by one, we +-- look up in the `FlagSpecTrie` to find which processor +-- to use. See `GHC.Driver.CmdLine.processArgs`. + -- ----------------------------------------------------------------------------- -- DynFlags @@ -837,7 +868,7 @@ parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAllTrie True -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags @@ -847,42 +878,19 @@ parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False - -newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) - deriving (Functor) - -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 - -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 +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamicTrie False -- | 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 + => FlagSpecTrie 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 + runStateT (processArgs activeFlags args parseResponseFile) s0 -- | 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 @@ -890,7 +898,7 @@ processCmdLineP activeFlags s0 args = -- arguments from the command line or from a file pragma. parseDynamicFlagsFull :: forall m. MonadIO m - => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + => FlagSpecTrie DynFlags -- ^ valid flags to match against -> Bool -- ^ are the arguments from the command line? -> Logger -- ^ logger -> DynFlags -- ^ current dynamic flags @@ -1012,14 +1020,22 @@ allFlagsDeps keepDeprecated = [ '-':flagName flag flagsAll :: [Flag (CmdLineP DynFlags)] flagsAll = map snd flagsAllDeps +-- | Same as 'flagsAll' but in trie form for fast lookup. +-- +-- See Note [Optimising the processing of command-line arguments] +flagsAllTrie :: FlagSpecTrie DynFlags +flagsAllTrie = extendFlagSpecTrie flagsDynamicTrie $ map snd package_flags_deps + -- All dynamic flags present in GHC with deprecation information. flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] flagsAllDeps = package_flags_deps ++ dynamic_flags_deps -- All dynamic flags, minus package flags, present in GHC. -flagsDynamic :: [Flag (CmdLineP DynFlags)] -flagsDynamic = map snd dynamic_flags_deps +-- +-- See Note [Optimising the processing of command-line arguments]. +flagsDynamicTrie :: FlagSpecTrie DynFlags +flagsDynamicTrie = mkFlagSpecTrie $ map snd dynamic_flags_deps -- ALl package flags present in GHC. flagsPackage :: [Flag (CmdLineP DynFlags)] @@ -2013,8 +2029,7 @@ dynamic_flags_deps = [ ++ ------ Warning flags ------------------------------------------------- - [ make_ord_flag defFlag "W" (NoArg (setWarningGroup W_extra)) - , make_ord_flag defFlag "Werror" + [ make_ord_flag defFlag "Werror" (NoArg (do { setGeneralFlag Opt_WarnIsError ; setFatalWarningGroup W_everything })) , make_ord_flag defFlag "Wwarn" @@ -2040,7 +2055,7 @@ dynamic_flags_deps = [ , (NotDeprecated, customOrUnrecognisedWarning "Werror=" setCustomWErrorFlag) , (NotDeprecated, customOrUnrecognisedWarning "Wwarn=" unSetCustomFatalWarningFlag) , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag) - , (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag) + , flagW , (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag) , (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag) ] @@ -2076,19 +2091,35 @@ warningControls set unset set_werror unset_fatal xs = ++ map (mkFlag turnOn "fwarn-" set . hideFlag) xs ++ map (mkFlag turnOff "fno-warn-" unset . hideFlag) xs +-- | The "W" flag is special in that it can mean enable extra warnings ('W_extra') +-- or enable a custom warning, if the suffix is non-empty. +flagW :: (Deprecation, Flag (CmdLineP DynFlags)) +flagW = + make_ord_flag defFlag "W" $ OptPrefix $ \suffix -> + if null suffix then do + -- Reject "-W=" instead of taking it to mean "-W". + arg <- getArg + if arg == "-W" then + setWarningGroup W_extra + else + addErr ("missing argument for flag: " ++ arg) + else + customOrUnrecognisedWarningAction "W" setCustomWarningFlag suffix + -- | This is where we handle unrecognised warning flags. If the flag is valid as -- an extended warning category, we call the supplied action. Otherwise, issue a -- warning if -Wunrecognised-warning-flags is set. See #11429 for context. -- See Note [Warning categories] in GHC.Unit.Module.Warnings. customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags) -customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) - where - action :: String -> DynP () - action flag +customOrUnrecognisedWarning prefix custom = + defHiddenFlag prefix $ Prefix $ customOrUnrecognisedWarningAction prefix custom + +customOrUnrecognisedWarningAction :: String -> (WarningCategory -> DynP ()) -> String -> DynP () +customOrUnrecognisedWarningAction prefix custom flag | validWarningCategory cat = custom cat | otherwise = unrecognised flag - where - cat = mkWarningCategory (packHText flag) + where + cat = mkWarningCategory (packHText flag) unrecognised flag = do -- #23402 and #12056 ===================================== compiler/ghc.cabal.in ===================================== @@ -474,6 +474,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.StringTrie GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== ghc/GHC/Driver/Session/Mode.hs ===================================== @@ -180,7 +180,7 @@ parseModeFlags :: [Located String] [Warn]) parseModeFlags args = do ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <- - processCmdLineP mode_flags (Nothing, [], [], []) args + processCmdLineP mode_flags_trie (Nothing, [], [], []) args let mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m @@ -191,10 +191,14 @@ parseModeFlags args = do return (mode, units, flags' ++ leftover, warns) -type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String]) +type ModeMS = (Maybe (Mode, String), [String], [String], [Located String]) +type ModeM = CmdLineP ModeMS -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. +mode_flags_trie :: FlagSpecTrie ModeMS +mode_flags_trie = mkFlagSpecTrie mode_flags + mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- ===================================== testsuite/tests/MiniQuickCheck.hs ===================================== @@ -28,6 +28,7 @@ module MiniQuickCheck , propertyCompare , propertyAnd , propertyTrue + , propertyEqWithContext , getCheck -- * QuickCheck test tree @@ -51,11 +52,15 @@ module MiniQuickCheck , nonZero , BoundedShiftAmount(..) , BoundedBy(..) + , BoundedList(..) + , BoundedChar(..) ) where -- base import Control.Exception ( SomeException, displayException, evaluate, try ) +import Control.Monad + ( replicateM ) import Control.Monad.IO.Class ( liftIO ) import Data.Bits @@ -64,8 +69,6 @@ import Data.Bits ) import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.IORef - ( newIORef, atomicModifyIORef' ) import Data.Kind ( Type ) import Data.List @@ -84,6 +87,8 @@ import System.Exit ( die, exitFailure ) import Text.Read ( readMaybe ) +import System.IO.Unsafe + ( unsafePerformIO ) -- transformers import Control.Monad.Trans.Reader @@ -141,6 +146,15 @@ propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b) (===) = propertyCompare "==" (==) infix 4 === +-- | Prints the given message when the two values are not equal. +propertyEqWithContext :: (Eq a, Show a) => String -> a -> a -> PropertyCheck +propertyEqWithContext msg = + propertyCompare + (intercalate "\n" $ + "is not the expected" : map (" " ++) (lines msg ++ ["expected:"]) + ) + (==) + -- | Conjunction of two property checks. propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck propertyAnd = PropertyAnd @@ -424,3 +438,28 @@ instance where n :: a n = fromIntegral $ natVal @n Proxy + +type BoundedList :: Nat -> Type -> Type +newtype BoundedList n a = BoundedList { getBoundedList :: [a] } + deriving (Eq, Ord, Show) + +instance + forall n a + . ( KnownNat n, Arbitrary a ) + => Arbitrary ( BoundedList n a ) where + arbitrary = do + x <- arbitrary + let n = (x :: Word64) `mod` fromIntegral (natVal @n Proxy + 1) + BoundedList <$> replicateM (fromIntegral n) arbitrary + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where + arbitrary = (,) <$> arbitrary <*> arbitrary + +type BoundedChar :: Nat -> Type +newtype BoundedChar n = BoundedChar { getBoundedChar :: Char } + deriving (Eq, Ord, Show) + +instance KnownNat n => Arbitrary (BoundedChar n) where + arbitrary = do + x <- getBoundedBy @_ @n <$> arbitrary + pure $ BoundedChar (['a'..] !! abs x) ===================================== testsuite/tests/driver/all.T ===================================== @@ -99,6 +99,8 @@ test('driver200', [extra_files(['A200.hs', 'B200/', 'D200.hs'])], makefile_test, test('T2566', normalise_fun(normalise_errmsg), makefile_test, []) +test('stringtrie', [mini_quickcheck], compile_and_run, ['-package ghc']) + test('pragma001', normal, compile, ['']) test('pragma002', normal, compile, ['']) ===================================== testsuite/tests/driver/stringtrie.hs ===================================== @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +import Data.Bifunctor (first) +import Data.Coerce +import Data.Function (on) +import Data.List (nubBy, sortOn, stripPrefix) +import GHC.Data.StringTrie as StringTrie +import MiniQuickCheck + +main :: IO () +main = do + runTestsMain (Iterations 1000) tests + -- runTests (Iterations 100) 9856592474076851907 tests + +tests :: Test +tests = Group "StringTrie" + [ Property "lookup_after_insert" prop_lookup_after_insert + , Property "fromList == foldl (flip $ uncurry insert) empty" prop_fromList_foldl + ] + +type BString4 = BoundedList 4 (BoundedChar 4) + +-- | @lookup qs (insert k v t)@ returns the values of matching keys ordered by +-- suffix length. +prop_lookup_after_insert + -- | query string as a bounded list + :: BoundedList 6 (BoundedChar 3) + -- | length of the key to insert in @t@ + -> BoundedBy Int 3 + -- | value to insert in @t@ + -> BoundedBy Int 9 + -- | list of key-value pairs to build the trie @t@ + -> BoundedList 6 (BString4, Int `BoundedBy` 9) + -> PropertyCheck +prop_lookup_after_insert bqs i0 v0 bkvs = + let kvs = coerce bkvs :: [(String, Int)] + t = fromList kvs + qs = coerce @_ @String bqs + i = min (abs (getBoundedBy i0)) (length qs) + k = take i qs + v = getBoundedBy v0 + -- (v1, sfx1) pairs where (k1, v1) is in t and k1 is a prefix of qs + expected = + [ (v1, sfx1) + | kv@(k1, v1) <- nubBy ((==) `on` fst) $ (k, v) : reverse kvs + , Just sfx1 <- [stripPrefix k1 qs] + ] + in + propertyEqWithContext + (unlines + [ "k = " ++ show k + , "v = " ++ show v + , "qs = " ++ show qs + , "kvs = " ++ show kvs + ] + ) + (StringTrie.lookup qs (insert k v t)) + (sortOn (length . snd) expected) + +-- | @fromList xs == foldl (flip $ uncurry insert) empty xs@ +prop_fromList_foldl + -- | list of key-value pairs to build the trie @t@ + :: Int `BoundedBy` 7 + -> BoundedList 6 (BString4, Int `BoundedBy` 9) + -> PropertyCheck +prop_fromList_foldl (BoundedBy sparseness) bkvs = + let kvs = map (first shiftString) $ coerce bkvs :: [(String, Int)] + in propertyEqWithContext + (unlines ["kvs = " ++ show kvs]) + (fromListWithSparseness (sparseness - 1) kvs) + (foldl (flip $ uncurry insert) empty kvs) + where + -- Bring characters next to the end of the ASCII range to test the + -- array-based implementation of fromList. + shiftString = map shiftChar + shiftChar = charPlus (126 - fromEnum 'a') + charPlus x c = toEnum (x + fromEnum c) ===================================== testsuite/tests/driver/stringtrie.stdout ===================================== @@ -0,0 +1,5 @@ +Group StringTrie + Running lookup_after_insert + Passed 1000 iterations + Running fromList == foldl (flip $ uncurry insert) empty + Passed 1000 iterations ===================================== testsuite/tests/perf/compiler/T25763.stderr ===================================== @@ -0,0 +1 @@ +[1 of 1] Compiling Main ( t25763.hs, nothing ) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -874,6 +874,16 @@ test ('T24984', compile, ['-O']) +# Performance regression test for the parser of command line arguments +test( + 'T25763', + [ + collect_compiler_runtime(5), + pre_cmd(f'seq 400000 | sed "s/.*/-XCPP/" > t25763.txt && echo "main = pure ()" > t25763.hs'), + ], + multimod_compile, + ['t25763', '@t25763.txt -c -fno-code']) + test('interpreter_steplocal', [ collect_compiler_stats('bytes allocated', 5) ], ===================================== testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr ===================================== @@ -0,0 +1,2 @@ +ghc: on the commandline: missing argument for flag: -W= +Usage: For basic information, try the `--help' option. ===================================== testsuite/tests/warnings/should_fail/all.T ===================================== @@ -15,6 +15,7 @@ test('CaretDiagnostics1', [normalise_whitespace_fun(normalise_whitespace_carefully)], compile_fail, ['-fdiagnostics-show-caret -ferror-spans']) +test('WExpectedNoArgError', normal, compile_fail, ['-W=']) test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret']) test('Colour', normal, compile_fail, ['-fdiagnostics-color=always']) test('T20263', normal, compile_fail, ['-Wunicode-bidirectional-format-characters -Werror']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/66ab9cb9471626c1292efadd2c8c35f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/66ab9cb9471626c1292efadd2c8c35f... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help