+    - lint-anyarch

+  image: debian:13

+.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"

+

+  image: debian:13

+    - lint-anyarch

+  extends: .lint-ghc-toolchain

+  extends: .lint-python

+  extends: .lint-ghc-toolchain

+    - make -Ctestsuite list_broken TEST_HC=$(which ghc)

+  extends: .lint-python

+  extends: .lint-python

+    - *install-ghc-toolchain

+  extends: .lint-ghc-toolchain

+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

+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

+-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)

+{-# OPTIONS_GHC -O2 #-}

+-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)

+{-# OPTIONS_GHC -O2 #-}

+-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)

+{-# OPTIONS_GHC -O2 #-}

+{-# LANGUAGE BangPatterns #-}

+-- This is a command-line parser used by DynFlags.

+      processArgs,

+

+      -- ** Flags

+      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,

+      OptKind(..), GhcFlagMode(..),

+

+      -- ** EwM monad

+      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,

+      -- ** FlagSpecTrie

+      FlagSpecTrie, mkFlagSpecTrie, extendFlagSpecTrie,

+

+      -- ** State

+      CmdLineP(..), runCmdLineP,

+      getCmdLineState, putCmdLineState,

+

+      -- ** Utils

+      parseResponseFile, errorsToGhcException

+import qualified GHC.Data.StringTrie as StringTrie

+import Data.List (intercalate)

+import Control.Monad.Trans.State (StateT)

+import qualified Control.Monad.Trans.State as State

+import Data.Functor.Identity (runIdentity)

+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)

+

+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

+    getCmdLineP :: CmdLineP s a -> StateT s m a

+    getCmdLineP (CmdLineP k) = k

+

+    process :: [Located String] -> [Located String] -> EwM (StateT s m) [Located String]

+        case findArg (unFlagSpecTrie spec) arg of

+                        in setArg locArg (hoistEwM getCmdLineP action) >> b

+-- | 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

+        flagsAllTrie,

+        flagsDynamicTrie,

+import Control.Monad.Trans.State (runStateT)

+-- 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`.

+

+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAllTrie True

+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamicTrie False

+    => FlagSpecTrie s          -- ^ valid flags to match against

+    runStateT (processArgs activeFlags args parseResponseFile) s0

+    => FlagSpecTrie DynFlags         -- ^ valid flags to match against

+-- | 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

+

+--

+-- See Note [Optimising the processing of command-line arguments].

+flagsDynamicTrie :: FlagSpecTrie DynFlags

+flagsDynamicTrie = mkFlagSpecTrie $ map snd dynamic_flags_deps