Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

30 changed files:

Changes:

  • changelog.d/25763-cmdline-opt
    1 
    +section: compiler
    2 
    +synopsis: Speed up command line parser with a trie map
    3 
    +description:
    4 
    +  Parsing flags is now faster when there are many flags to parse.
    5 
    +
    6 
    +  There is a new trie implementation with String keys in ``GHC.Data.StringTrie``.
    7 
    +
    8 
    +  Added a new abstract type ``FlagSpecTrie`` to represent tries of flags.
    9 
    +
    10 
    +  ``GHC.Driver.Session`` gets ``flagsDynamic`` removed and ``flagsDynamicTrie``
    11 
    +  added with type ``FlagSpecTrie``. ``processCmdLineP`` and ``parseDynamicFlagsFull``
    12 
    +  now have a ``FlagSpecTrie`` parameter instead of a list.
    13 
    +
    14 
    +  ``GHC.Driver.Session.Mode`` gets a value ``mode_flags_trie`` of type ``FlagSpecTrie``.
    15 
    +
    16 
    +  ``GHC.Driver.CmdLine.processArgs`` now gets a ``FlagSpecTrie`` argument instead
    17 
    +  of a list.
    18 
    +mrs: !16392
    19 
    +issues: #25763

  • compiler/GHC/Data/StringTrie.hs
    1 
    +module GHC.Data.StringTrie
    2 
    +  ( StringTrie(..)
    3 
    +  , empty
    4 
    +  , insert
    5 
    +  , fromList
    6 
    +  , fromListWithSparseness
    7 
    +  , lookup
    8 
    +  ) where
    9 
    +
    10 
    +import GHC.Prelude hiding (lookup)
    11 
    +
    12 
    +import Data.Array (Array, accumArray, assocs)
    13 
    +import Data.Maybe (fromMaybe)
    14 
    +import qualified Data.IntMap.Lazy as M
    15 
    +
    16 
    +-- | A trie mapping strings to values of type @a@.
    17 
    +--
    18 
    +-- See #25763 and Note [Optimising the processing of command-line arguments]
    19 
    +-- in "GHC.Driver.Session".
    20 
    +data StringTrie a
    21 
    +    = -- | A value and other children under the same path.
    22 
    +      --
    23 
    +      -- The 'IntMap' can be empty.
    24 
    +      STNode a (M.IntMap (StringTrie a))
    25 
    +      -- | There is no value at this path, but there are children under it
    26 
    +      --
    27 
    +      -- The 'IntMap' must be non-empty, so 'STEmpty' remains the only way to
    28 
    +      -- represent a trie with no values.
    29 
    +    | STFork (M.IntMap (StringTrie a))
    30 
    +      -- | A trie with no values
    31 
    +    | STEmpty
    32 
    +  deriving (Eq, Show)
    33 
    +
    34 
    +-- | There are no key-value pairs in this trie.
    35 
    +empty :: StringTrie a
    36 
    +empty = STEmpty
    37 
    +
    38 
    +-- | Inserts a key-value pair into the trie. When a value for the key is already
    39 
    +-- present, the new value replaces the old one.
    40 
    +insert :: forall a. String -> a -> StringTrie a -> StringTrie a
    41 
    +insert k0 v = go k0
    42 
    +  where
    43 
    +    go :: String -> StringTrie a -> StringTrie a
    44 
    +    go (x:xs) STEmpty = STFork $ M.singleton (fromEnum x) (go xs STEmpty)
    45 
    +    go "" STEmpty = STNode v M.empty
    46 
    +    go "" (STFork children) = STNode v children
    47 
    +    go (x:xs) (STFork children) =
    48 
    +        STFork (M.insert (fromEnum x) child children)
    49 
    +      where
    50 
    +        child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children)
    51 
    +
    52 
    +    go "" (STNode _ children) = STNode v children
    53 
    +    go (x:xs) (STNode vs children) =
    54 
    +        STNode vs (M.insert (fromEnum x) child children)
    55 
    +      where
    56 
    +        child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children)
    57 
    +
    58 
    +-- | Returns the values associated with prefixes of a query string as well as
    59 
    +-- the non-matching suffix. The matches are returned ordered by suffix length.
    60 
    +--
    61 
    +-- Examples:
    62 
    +--
    63 
    +-- > lookup "abc" (fromList [("ab", 2), ("abc", 3), ("b", 4)]) == [(3, ""), (2, "c")]
    64 
    +-- > lookup "abc" (fromList [("ab", 2), ("ab", 3)]) == [(3, "c")]
    65 
    +-- > lookup "ba" (fromList [("ab", 2), ("abc", 3)]) == []
    66 
    +--
    67 
    +-- More formally:
    68 
    +--
    69 
    +-- @(v, suffix)@ is in @lookup queryString t@ iff there is a string @k@ such that
    70 
    +--     * @(k, v)@ is in @t@, and
    71 
    +--     * @k ++ suffix == queryString@.
    72 
    +lookup
    73 
    +    :: String
    74 
    +    -> StringTrie a
    75 
    +    -> [(a, String)]
    76 
    +lookup = go []
    77 
    +  where
    78 
    +    go :: [(a, String)] -> String -> StringTrie a -> [(a, String)]
    79 
    +    --
    80 
    +    -- In @lookup queryString t@ and @go acc unmatchedSuffix t'@,
    81 
    +    --
    82 
    +    -- unmatchedSuffix is a suffix of queryString, and t' is the subtrie
    83 
    +    -- of t at path @queryString - unmatchedSuffix@.
    84 
    +    --
    85 
    +    -- (v, suffix) is in acc iff there is a k such that
    86 
    +    --    * (k, v) is in t, and
    87 
    +    --    * @k ++ suffix == queryString@, and
    88 
    +    --    * @unmatchedSuffix /= suffix@.
    89 
    +    go acc [] (STNode v  _) = (v, "") : acc
    90 
    +    go acc [] (STFork _) = acc
    91 
    +    go acc _ STEmpty = acc
    92 
    +    go acc unmatchedSuffix@(c:rest) (STNode v children) =
    93 
    +      let acc' = (v, unmatchedSuffix) : acc
    94 
    +       in maybe acc' (go acc' rest) (M.lookup (fromEnum c) children)
    95 
    +    go acc (c:rest) (STFork children) =
    96 
    +      maybe acc (go acc rest) (M.lookup (fromEnum c) children)
    97 
    +
    98 
    +-- | Constructs a trie from a list of key-value pairs.
    99 
    +--
    100 
    +-- Later entries in the list will overwrite earlier ones with the same key.
    101 
    +--
    102 
    +-- Equivalent to @foldl (\t (k, v) -> insert k v t) empty@, but lazier: the
    103 
    +-- subtrie for each first character is only built when demanded.
    104 
    +fromList :: [(String, a)] -> StringTrie a
    105 
    +fromList = fromListWithSparseness 32
    106 
    +
    107 
    +-- | Like 'fromList', but allows the caller to specify a threshold for when to use
    108 
    +-- an array to sort the keys.
    109 
    +fromListWithSparseness :: Int -> [(String, a)] -> StringTrie a
    110 
    +fromListWithSparseness sparseness = go
    111 
    +  where
    112 
    +    go [] = STEmpty
    113 
    +    go xs =
    114 
    +      let revxs = reverse xs
    115 
    +          valuesWithEmptyKeys = filter (null . fst) revxs
    116 
    +          children = M.map go (headBuckets sparseness revxs)
    117 
    +       in case valuesWithEmptyKeys of
    118 
    +            (_, v) : _ -> STNode v children
    119 
    +            _          -> STFork children
    120 
    +
    121 
    +    -- Group the entries with a non-empty key by their first character (in reverse order).
    122 
    +    --
    123 
    +    -- Discards entries with an empty key. Uses an array to sort the entries, unless the
    124 
    +    -- entries are too sparse.
    125 
    +    headBuckets :: Int -> [(String, a)] -> M.IntMap [(String, a)]
    126 
    +    headBuckets sparseness kvs
    127 
    +        -- Entries are too sparse if they are too few or if they span too large a range
    128 
    +        -- of characters.
    129 
    +      | null (drop sparseness kvs) || any non_ascii kvs
    130 
    +      = M.fromListWith (++) [ (fromEnum c, [(cs, v)]) | (c:cs, v) <- kvs ]
    131 
    +      | otherwise
    132 
    +      = M.fromDistinctAscList
    133 
    +           [ (i, group) | (i, group) <- assocs (bucketsArr kvs), not (null group) ]
    134 
    +
    135 
    +    -- @(k, v)@ is in @bucketsArr kvs ! i@ iff @(tail k, v)@ is in @kvs@ and
    136 
    +    -- @fromEnum (head k) == i@.
    137 
    +    --
    138 
    +    -- Note: Discard entries with an empty key.
    139 
    +    bucketsArr :: [(String, a)] -> Array Int [(String, a)]
    140 
    +    bucketsArr kvs =
    141 
    +      accumArray
    142 
    +        (flip (:))
    143 
    +        []
    144 
    +        (0, 0x7f)
    145 
    +        [ (fromEnum c, (cs, v)) | (c:cs, v) <- kvs ]
    146 
    +
    147 
    +    non_ascii (c:_, _) = fromEnum c > 0x7f
    148 
    +    non_ascii ([],  _) = False

  • compiler/GHC/Data/Word64Map/Internal.hs
    ... ... @@ -3,6 +3,8 @@
    3 3
    4 4 
     {-# OPTIONS_HADDOCK not-home #-}
    5 5 
     {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
    6 
    +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)
    7 
    +{-# OPTIONS_GHC -O2 #-}
    6 8
    7 9
    8 10 
     -----------------------------------------------------------------------------

  • compiler/GHC/Data/Word64Map/Strict/Internal.hs
    1 1
    2 2 
     {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
    3 
    +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)
    4 
    +{-# OPTIONS_GHC -O2 #-}
    3 5
    4 6 
     -----------------------------------------------------------------------------
    5 7 
     -- |

  • compiler/GHC/Data/Word64Set/Internal.hs
    ... ... @@ -2,6 +2,8 @@
    2 2 
     {-# LANGUAGE TypeFamilies #-}
    3 3
    4 4 
     {-# OPTIONS_HADDOCK not-home #-}
    5 
    +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814)
    6 
    +{-# OPTIONS_GHC -O2 #-}
    5 7
    6 8 
     -----------------------------------------------------------------------------
    7 9 
     -- |

  • compiler/GHC/Driver/CmdLine.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    1 2 
     -------------------------------------------------------------------------------
    2 3 
     --
    3 4 
     -- | Command-line parser
    4 5 
     --
    5 
    --- This is an abstract command-line parser used by DynFlags.
    6 
    +-- This is a command-line parser used by DynFlags.
    6 7 
     --
    7 8 
     -- (c) The University of Glasgow 2005
    8 9 
     --
    ... ... @@ -10,13 +11,26 @@
    10 11
    11 12 
     module GHC.Driver.CmdLine
    12 13 
         (
    13 
    -      processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),
    14 
    -      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,
    15 
    -      errorsToGhcException,
    14 
    +      processArgs,
    15 
    +
    16 
    +      -- ** Flags
    17 
    +      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
    18 
    +      OptKind(..), GhcFlagMode(..),
    19 
    +
    20 
    +      -- ** EwM monad
    21 
    +      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,
    16 22
    17 23 
           Err(..), Warn, warnsToMessages,
    18 24
    19 
    -      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM
    25 
    +      -- ** FlagSpecTrie
    26 
    +      FlagSpecTrie, mkFlagSpecTrie, extendFlagSpecTrie,
    27 
    +
    28 
    +      -- ** State
    29 
    +      CmdLineP(..), runCmdLineP,
    30 
    +      getCmdLineState, putCmdLineState,
    31 
    +
    32 
    +      -- ** Utils
    33 
    +      parseResponseFile, errorsToGhcException
    20 34 
         ) where
    21 35
    22 36 
     import GHC.Prelude
    ... ... @@ -24,6 +38,7 @@ import GHC.Prelude
    24 38 
     import GHC.Utils.Misc
    25 39 
     import GHC.Utils.Panic
    26 40 
     import GHC.Data.Bag
    41 
    +import qualified GHC.Data.StringTrie as StringTrie
    27 42 
     import GHC.Types.SrcLoc
    28 43 
     import GHC.Types.Error
    29 44 
     import GHC.Utils.Error
    ... ... @@ -31,14 +46,16 @@ import GHC.Driver.Errors.Types
    31 46 
     import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage
    32 47 
     import GHC.Utils.Outputable (text)
    33 48
    34 
    -import Data.Function
    35 
    -import Data.List (sortBy, intercalate, stripPrefix)
    49 
    +import Data.List (intercalate)
    36 50 
     import Data.Word
    37 51
    38 52 
     import GHC.ResponseFile
    39 53 
     import Control.Exception (IOException, catch)
    40 54 
     import Control.Monad (ap)
    41 55 
     import Control.Monad.IO.Class
    56 
    +import Control.Monad.Trans.State (StateT)
    57 
    +import qualified Control.Monad.Trans.State as State
    58 
    +import Data.Functor.Identity (runIdentity)
    42 59
    43 60 
     --------------------------------------------------------
    44 61 
     --         The Flag and OptKind types
    ... ... @@ -62,24 +79,6 @@ defGhciFlag name optKind = Flag name optKind OnlyGhci
    62 79 
     defHiddenFlag :: String -> OptKind m -> Flag m
    63 80 
     defHiddenFlag name optKind = Flag name optKind HiddenFlag
    64 81
    65 
    -hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n
    66 
    -hoistFlag f (Flag a b c) = Flag a (go b) c
    67 
    -  where
    68 
    -      go (NoArg k)  = NoArg (go2 k)
    69 
    -      go (HasArg k) = HasArg (\s -> go2 (k s))
    70 
    -      go (SepArg k) = SepArg (\s -> go2 (k s))
    71 
    -      go (Prefix k) = Prefix (\s -> go2 (k s))
    72 
    -      go (OptPrefix k) = OptPrefix (\s -> go2 (k s))
    73 
    -      go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))
    74 
    -      go (IntSuffix k) = IntSuffix (\n -> go2 (k n))
    75 
    -      go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s))
    76 
    -      go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))
    77 
    -      go (PassFlag k) = PassFlag (\s -> go2 (k s))
    78 
    -      go (AnySuffix k) = AnySuffix (\s -> go2 (k s))
    79 
    -
    80 
    -      go2 :: EwM m a -> EwM n a
    81 
    -      go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws)
    82 
    -
    83 82 
     -- | GHC flag modes describing when a flag has an effect.
    84 83 
     data GhcFlagMode
    85 84 
         = OnlyGhc  -- ^ The flag only affects the non-interactive GHC
    ... ... @@ -159,6 +158,9 @@ getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
    159 158 
     liftEwM :: Monad m => m a -> EwM m a
    160 159 
     liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
    161 160
    161 
    +hoistEwM :: (forall a. m a -> n a) -> EwM m b -> EwM n b
    162 
    +hoistEwM f (EwM g) = EwM $ \loc es ws -> f (g loc es ws)
    163 
    +
    162 164 
     warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage
    163 165 
     warnsToMessages diag_opts = foldr
    164 166 
       (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws)
    ... ... @@ -168,20 +170,70 @@ warnsToMessages diag_opts = foldr
    168 170 
     --         Processing arguments
    169 171 
     --------------------------------------------------------
    170 172
    171 
    -processArgs :: Monad m
    172 
    -            => [Flag m]               -- ^ cmdline parser spec
    173 
    -            -> [Located String]       -- ^ args
    174 
    -            -> (FilePath -> EwM m [Located String]) -- ^ response file handler
    175 
    -            -> m ( [Located String],  -- spare args
    173 
    +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)
    174 
    +  deriving (Functor)
    175 
    +
    176 
    +instance Monad (CmdLineP s) where
    177 
    +    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)
    178 
    +    return = pure
    179 
    +
    180 
    +instance Applicative (CmdLineP s) where
    181 
    +    pure x = CmdLineP (pure x)
    182 
    +    (<*>) = ap
    183 
    +
    184 
    +getCmdLineState :: CmdLineP s s
    185 
    +getCmdLineState = CmdLineP State.get
    186 
    +
    187 
    +putCmdLineState :: s -> CmdLineP s ()
    188 
    +putCmdLineState x = CmdLineP (State.put x)
    189 
    +
    190 
    +runCmdLineP :: CmdLineP s a -> s -> (a, s)
    191 
    +runCmdLineP (CmdLineP k) s0 = runIdentity $ State.runStateT k s0
    192 
    +
    193 
    +-- | Flag specifications as a trie map
    194 
    +--
    195 
    +-- No two flags with the same 'flagName' are allowed.
    196 
    +--
    197 
    +-- See Note [Optimising the processing of command-line arguments]
    198 
    +-- in GHC.Driver.Session.
    199 
    +newtype FlagSpecTrie s =
    200 
    +    -- | The key of each 'Flag' @f@ is @flagName f@.
    201 
    +    FlagSpecTrie { unFlagSpecTrie :: StringTrie.StringTrie (Flag (CmdLineP s)) }
    202 
    +
    203 
    +-- | Construct a 'FlagSpecTrie' from a list of flags.
    204 
    +--
    205 
    +-- Precondition: No two flags in the list have the same flag name.
    206 
    +mkFlagSpecTrie :: [Flag (CmdLineP s)] -> FlagSpecTrie s
    207 
    +mkFlagSpecTrie flags =
    208 
    +  FlagSpecTrie $ StringTrie.fromList [ (flagName f, f) | !f <- flags ]
    209 
    +{-# INLINE mkFlagSpecTrie #-}
    210 
    +
    211 
    +-- | Add flags to an existing 'FlagSpecTrie'.
    212 
    +--
    213 
    +-- Precondition: No two flags in the trie plus the list have the same flag name.
    214 
    +extendFlagSpecTrie :: FlagSpecTrie s -> [Flag (CmdLineP s)] -> FlagSpecTrie s
    215 
    +extendFlagSpecTrie (FlagSpecTrie t) flags =
    216 
    +  FlagSpecTrie $ foldl' (\acc f -> StringTrie.insert (flagName f) f acc) t flags
    217 
    +{-# INLINE extendFlagSpecTrie #-}
    218 
    +
    219 
    +processArgs :: forall s m. Monad m
    220 
    +            => FlagSpecTrie s             -- ^ cmdline parser spec
    221 
    +            -> [Located String]           -- ^ args
    222 
    +            -> (FilePath -> EwM (StateT s m) [Located String]) -- ^ response file handler
    223 
    +            -> StateT s m
    224 
    +                 ( [Located String],  -- spare args
    176 225 
                        [Err],  -- errors
    177 226 
                        Warns ) -- warnings
    178 227 
     processArgs spec args handleRespFile = do
    179 228 
         (errs, warns, spare) <- runEwM action
    180 229 
         return (spare, bagToList errs, warns)
    181 230 
       where
    231 
    +    getCmdLineP :: CmdLineP s a -> StateT s m a
    232 
    +    getCmdLineP (CmdLineP k) = k
    233 
    +
    182 234 
         action = process args []
    183 235
    184 
    -    -- process :: [Located String] -> [Located String] -> EwM m [Located String]
    236 
    +    process :: [Located String] -> [Located String] -> EwM (StateT s m) [Located String]
    185 237 
         process [] spare = return (reverse spare)
    186 238
    187 239 
         process (L _ ('@' : resp_file) : args) spare = do
    ... ... @@ -189,7 +241,7 @@ processArgs spec args handleRespFile = do
    189 241 
             process (resp_args ++ args) spare
    190 242
    191 243 
         process (locArg@(L _ ('-' : arg)) : args) spare =
    192 
    -        case findArg spec arg of
    244 
    +        case findArg (unFlagSpecTrie spec) arg of
    193 245 
                 Just (rest, opt_kind) ->
    194 246 
                     case processOneArg opt_kind rest arg args of
    195 247 
                         Left err ->
    ... ... @@ -198,7 +250,7 @@ processArgs spec args handleRespFile = do
    198 250
    199 251 
                         Right (action,rest) ->
    200 252 
                             let b = process rest spare
    201 
    -                        in (setArg locArg $ action) >> b
    253 
    +                        in setArg locArg (hoistEwM getCmdLineP action) >> b
    202 254
    203 255 
                 Nothing -> process args (locArg : spare)
    204 256
    ... ... @@ -246,31 +298,38 @@ processOneArg opt_kind rest arg args
    246 298 
             OptPrefix f       -> Right (f rest_no_eq, args)
    247 299 
             AnySuffix f       -> Right (f dash_arg, args)
    248 300
    249 
    -findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
    250 
    -findArg spec arg =
    251 
    -    case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
    252 
    -           [ (removeSpaces rest, optKind)
    253 
    -           | flag <- spec,
    254 
    -             let optKind  = flagOptKind flag,
    255 
    -             Just rest <- [stripPrefix (flagName flag) arg],
    256 
    -             arg_ok optKind rest arg ]
    257 
    -    of
    258 
    -        []      -> Nothing
    259 
    -        (one:_) -> Just one
    260 
    -
    261 
    -arg_ok :: OptKind t -> [Char] -> String -> Bool
    262 
    -arg_ok (NoArg           _)  rest _   = null rest
    263 
    -arg_ok (HasArg          _)  _    _   = True
    264 
    -arg_ok (SepArg          _)  rest _   = null rest
    265 
    -arg_ok (Prefix          _)  _    _   = True -- Missing argument checked for in processOneArg t
    266 
    -                                            -- to improve error message (#12625)
    267 
    -arg_ok (OptIntSuffix    _)  _    _   = True
    268 
    -arg_ok (IntSuffix       _)  _    _   = True
    269 
    -arg_ok (Word64Suffix    _)  _    _   = True
    270 
    -arg_ok (FloatSuffix     _)  _    _   = True
    271 
    -arg_ok (OptPrefix       _)  _    _   = True
    272 
    -arg_ok (PassFlag        _)  rest _   = null rest
    273 
    -arg_ok (AnySuffix       _)  _    _   = True
    301 
    +-- | Find a flag in the trie whose name is a prefix of the given string.
    302 
    +--
    303 
    +-- The unmatched suffix of the string is returned along with the 'OptKind'.
    304 
    +--
    305 
    +-- A flag is only returned if the suffix is valid for the 'OptKind' of the flag.
    306 
    +-- For example, a flag with 'NoArg' will only be returned if the suffix is
    307 
    +-- empty. More concretely, @-Wallx@ will produce an invalid suffix @"x"@ since
    308 
    +-- @-Wall@ has @OptKind@ 'NoArg'.
    309 
    +--
    310 
    +-- If more than one flag name is a prefix of the string, the longest match with
    311 
    +-- a valid suffix is returned.
    312 
    +findArg :: StringTrie.StringTrie (Flag m) -> String -> Maybe (String, OptKind m)
    313 
    +findArg trie arg =
    314 
    +    case filter (uncurry valid_flag_suffix) $ StringTrie.lookup arg trie of
    315 
    +        []               -> Nothing
    316 
    +        (flag, rest) : _ -> Just (removeSpaces rest, flagOptKind flag)
    317 
    +  where
    318 
    +    valid_flag_suffix :: Flag m -> String -> Bool
    319 
    +    valid_flag_suffix flag rest =
    320 
    +      case flagOptKind flag of
    321 
    +        NoArg _        -> null rest
    322 
    +        HasArg _       -> True
    323 
    +        SepArg _       -> null rest
    324 
    +        Prefix _       -> True -- Missing argument checked for in processOneArg t
    325 
    +                               -- to improve error message (#12625)
    326 
    +        OptIntSuffix _ -> True
    327 
    +        IntSuffix _    -> True
    328 
    +        Word64Suffix _ -> True
    329 
    +        FloatSuffix _  -> True
    330 
    +        OptPrefix _    -> True
    331 
    +        PassFlag _     -> null rest
    332 
    +        AnySuffix _    -> True
    274 333
    275 334 
     -- | Parse an Int
    276 335 
     --

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -6,6 +6,8 @@
    6 6 
     {-# LANGUAGE BlockArguments #-}
    7 7 
     {-# LANGUAGE ViewPatterns #-}
    8 8
    9 
    +{-# OPTIONS_GHC -Wno-invalid-haddock #-}
    10 
    +
    9 11 
     -- | See Note [The ModuleGraph]
    10 12 
     module GHC.Driver.Downsweep
    11 13 
       ( downsweep
    ... ... @@ -54,7 +56,6 @@ import GHC.Runtime.Context
    54 56 
     import Language.Haskell.Syntax.ImpExp
    55 57 
     import GHC.Types.UnresolvedImport
    56 58
    57 
    -import GHC.Data.Graph.Directed
    58 59 
     import GHC.Data.FastString
    59 60 
     import GHC.Data.Maybe      ( expectJust )
    60 61 
     import qualified GHC.Data.Maybe as M
    ... ... @@ -71,12 +72,15 @@ import GHC.Utils.Logger
    71 72 
     import GHC.Utils.Fingerprint
    72 73 
     import GHC.Utils.TmpFs
    73 74 
     import GHC.Utils.Constants
    75 
    +import GHC.Utils.Monad (concatMapM)
    76 
    +import GHC.Utils.Monad.State.Strict
    74 77
    75 78 
     import GHC.Types.Error
    76 79 
     import GHC.Types.Target
    77 80 
     import GHC.Types.SourceFile
    78 81 
     import GHC.Types.SourceError
    79 82 
     import GHC.Types.SrcLoc
    83 
    +import GHC.Types.Unique.Set
    80 84 
     import GHC.Types.Unique.Map
    81 85 
     import GHC.Types.PkgQual
    82 86 
     import GHC.Types.Basic
    ... ... @@ -91,9 +95,12 @@ import GHC.Unit.Module.Graph
    91 95 
     import GHC.Unit.Module.Deps
    92 96 
     import qualified GHC.Unit.Home.Graph as HUG
    93 97 
     import GHC.Unit.Module.Stage
    98 
    +import GHC.Unit.External.Index (UnitAbiHash)
    94 99
    95 100 
     import Data.Either ( partitionEithers, lefts )
    101 
    +import Data.Map (Map)
    96 102 
     import qualified Data.Map as Map
    103 
    +import Data.Set (Set)
    97 104 
     import qualified Data.Set as Set
    98 105
    99 106 
     import Control.Concurrent.MVar
    ... ... @@ -101,7 +108,7 @@ import Control.Monad
    101 108 
     import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
    102 109 
     import qualified Control.Monad.Catch as MC
    103 110 
     import Data.Maybe
    104 
    -import Data.List (partition)
    111 
    +import Data.List (sort, partition)
    105 112 
     import Data.Time
    106 113 
     import Data.List (unfoldr)
    107 114 
     import Data.Bifunctor (first, bimap)
    ... ... @@ -933,52 +940,175 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
    933 940 
     -- * Check/validate properties and error out
    934 941 
     --------------------------------------------------------------------------------
    935 942
    936 
    --- | This function checks then important property that if both p and q are home units
    937 
    --- then any dependency of p, which transitively depends on q is also a home unit.
    943 
    +-- | Checks whether the given 'UnitEnv' has the closure property.
    938 944 
     --
    939 
    --- See Note [Multiple Home Units], section 'Closure Property'.
    940 
    -checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]
    941 
    -checkHomeUnitsClosed ue
    942 
    -    | Set.null bad_unit_ids = []
    943 
    -    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
    945 
    +--   See the section “Closure Property” in @Note [Multiple Home Units]@ for the
    946 
    +--   definition of the closure property and
    947 
    +--   @Note [Home unit closure property check]@ below for a discussion of the
    948 
    +--   algorithm used for this check, its justification, and a potential
    949 
    +--   alternative.
    950 
    +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
    951 
    +checkHomeUnitsClosed unit_env
    952 
    +  | null offenders = []
    953 
    +  | otherwise      = [
    954 
    +                        singleMessage                                $
    955 
    +                        mkPlainErrorMsgEnvelope error_source_span    $
    956 
    +                        DriverHomePackagesNotClosed (sort offenders)
    957 
    +                     ]
    944 958 
       where
    945 
    -    home_id_set = HUG.allUnits $ ue_home_unit_graph ue
    946 
    -    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
    947 
    -    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
    948 959
    949 
    -    downwards_closure :: Graph (Node UnitId UnitId)
    950 
    -    downwards_closure = graphFromEdgedVerticesUniq graphNodes
    960 
    +  -- | The 'UnitId' and 'HomeUnitEnv' of each home unit.
    961 
    +  home_unit_data :: [(UnitId, HomeUnitEnv)]
    962 
    +  home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
    963 
    +
    964 
    +  -- | The 'UnitId's of all home units.
    965 
    +  home_units :: UniqSet UnitId
    966 
    +  home_units = mkUniqSet (map fst home_unit_data)
    967 
    +
    968 
    +  -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is
    969 
    +  --   offending exactly if /u/ is an external unit reachable from a home unit
    970 
    +  --   and /v/ is a home unit. Each such dependency is represented in this list
    971 
    +  --   by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/.
    972 
    +  offenders :: [(UnitId, UnitId)]
    973 
    +  offenders
    974 
    +    = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data))
    975 
    +                emptyUniqMap
    976 
    +    where
    951 977
    952 
    -    inverse_closure = graphReachability $ transposeG downwards_closure
    978 
    +    -- | Collects offending dependencies.
    979 
    +    collect :: [UnitState]
    980 
    +               -- ^ The 'UnitState's of the home units from which to traverse
    981 
    +               --   the dependency graph.
    982 
    +            -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
    983 
    +               -- ^ A stateful computation that collects offending dependencies
    984 
    +               --   that have not yet been found. It uses its state, which is an
    985 
    +               --   efficent representation of a set of 'GlobalUnitKey's, to
    986 
    +               --   keep track of which units have already been considered as
    987 
    +               --   sources of offending dependencies.
    988 
    +    collect = concatMapM $ \ unit_state ->
    989 
    +              collect_for_home_unit
    990 
    +                (unitInfoMap unit_state)
    991 
    +                (map (toUnitId . fst) $ explicitUnits $ unit_state)
    992 
    +      where
    953 993
    954 
    -    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
    994 
    +      -- | Collects offending dependencies that are reachable from a particular
    995 
    +      --   home unit.
    996 
    +      collect_for_home_unit
    997 
    +        :: UnitInfoMap
    998 
    +           -- ^ The 'UnitInfoMap' of the home unit.
    999 
    +        -> [UnitId]
    1000 
    +           -- ^ The 'UnitId's of the units from which to traverse the dependency
    1001 
    +           --   graph.
    1002 
    +        -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
    1003 
    +           -- ^ A stateful computation that collects offending dependencies that
    1004 
    +           --   have not yet been found. It uses its state, which is an efficent
    1005 
    +           --   representation of a set of 'GlobalUnitKey's, to keep track of
    1006 
    +           --   which units have already been considered as sources of offending
    1007 
    +           --   dependencies.
    1008 
    +      collect_for_home_unit _ []
    1009 
    +        = return []
    1010 
    +      collect_for_home_unit unit_info_map (current_unit : remaining_units) = do
    1011 
    +        let
    1012 
    +
    1013 
    +          -- | The 'UnitInfo' of the current unit.
    1014 
    +          unit_info :: UnitInfo
    1015 
    +          unit_info
    1016 
    +            = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $
    1017 
    +              lookupUniqMap unit_info_map current_unit
    1018 
    +            where
    1019 
    +
    1020 
    +            -- | The message that says that a unit was not found.
    1021 
    +            unit_not_found_msg :: String
    1022 
    +            unit_not_found_msg = "Unit not found during closure property check"
    1023 
    +
    1024 
    +          -- | The ABI hash of the current unit.
    1025 
    +          unit_abi_hash :: UnitAbiHash
    1026 
    +          unit_abi_hash = unitAbiHash unit_info
    1027 
    +
    1028 
    +        has_been_processed <- gets $ maybe False (Set.member unit_abi_hash) .
    1029 
    +                                     (`lookupUniqMap` current_unit)
    1030 
    +        if has_been_processed
    1031 
    +          then collect_for_home_unit unit_info_map remaining_units
    1032 
    +          else do
    1033 
    +            modify $ \ processed -> addToUniqMap_C Set.union
    1034 
    +                                                   processed
    1035 
    +                                                   current_unit
    1036 
    +                                                   (Set.singleton unit_abi_hash)
    1037 
    +            let
    1038 
    +
    1039 
    +              -- | The 'UnitId's of the units that the current unit depends on.
    1040 
    +              needed_units :: [UnitId]
    1041 
    +              needed_units = unitDepends unit_info
    1042 
    +
    1043 
    +              -- | The offending dependencies of the current unit.
    1044 
    +              current_offenders :: [(UnitId, UnitId)]
    1045 
    +              current_offenders
    1046 
    +                | current_unit `elementOfUniqSet` home_units
    1047 
    +                  = []
    1048 
    +                | otherwise
    1049 
    +                  = map ((,) current_unit) $
    1050 
    +                    nonDetEltsUniqSet $
    1051 
    +                    mkUniqSet needed_units `intersectUniqSets` home_units
    1052 
    +
    1053 
    +            remaining_offenders <- collect_for_home_unit unit_info_map $
    1054 
    +                                   needed_units ++ remaining_units
    1055 
    +            return $ current_offenders ++ remaining_offenders
    1056 
    +
    1057 
    +  -- | A fake source span used for reporting violations of the closure property.
    1058 
    +  error_source_span :: SrcSpan
    1059 
    +  error_source_span = mkGeneralSrcSpan (fsLit "<command line>")
    955 1060
    956 
    -    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
    957 
    -    all_unit_direct_deps
    958 
    -      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
    959 
    -      where
    960 
    -        go rest this this_uis =
    961 
    -           plusUniqMap_C Set.union
    962 
    -             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
    963 
    -             rest
    964 
    -           where
    965 
    -             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
    966 
    -             this_units = homeUnitEnv_units this_uis
    967 
    -             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
    968 
    -
    969 
    -    graphNodes :: [Node UnitId UnitId]
    970 
    -    graphNodes = go Set.empty home_id_set
    971 
    -      where
    972 
    -        go done todo
    973 
    -          = case Set.minView todo of
    974 
    -              Nothing -> []
    975 
    -              Just (uid, todo')
    976 
    -                | Set.member uid done -> go done todo'
    977 
    -                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
    978 
    -                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
    979 
    -                    Just depends ->
    980 
    -                      let todo'' = (depends Set.\\ done) `Set.union` todo'
    981 
    -                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
    1061 
    +{-
    1062 
    +
    1063 
    +Note [Home unit closure property check]
    1064 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1065 
    +
    1066 
    +Per the definition in Note [Multiple Home Units], a unit environment has the
    1067 
    +closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the
    1068 
    +dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external
    1069 
    +unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for
    1070 
    +so-called offending dependencies, which are dependencies /e/ → /h/₂ that are
    1071 
    +part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a
    1072 
    +viable approach, consider the following:
    1073 
    +
    1074 
    +  * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂.
    1075 
    +
    1076 
    +  * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′,
    1077 
    +    where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be
    1078 
    +    constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂
    1079 
    +    and as /e/′ the, necessarily external, unit preceding it.
    1080 
    +
    1081 
    +Concretely, the algorithm picks one home unit after the other, determines what
    1082 
    +units it directly depends on, and, starting from them, follows unit dependencies
    1083 
    +to search for offending dependencies. It does not follow dependencies that have
    1084 
    +been followed before, possibly when processing another home unit. To achieve
    1085 
    +this, the algorithm tracks, across home units, from which units it has already
    1086 
    +followed dependencies. For this tracking, it identifies each unit by a 'UnitId'
    1087 
    +and an ABI hash. Using only a 'UnitId' would not work, because 'UnitId's are not
    1088 
    +always globally unique. Also using only an ABI hash is not an option, because an
    1089 
    +ABI hash is not necessarily an ABI hash: it can also be the string @"inline"@.
    1090 
    +
    1091 
    +The correctness of this algorithm rests on the, likely correct, assumption that,
    1092 
    +among the units mentioned in the 'UnitState' of a particular home unit, any unit
    1093 
    +can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only
    1094 
    +occur across the 'UnitState's of different home units.
    1095 
    +
    1096 
    +An alternative approach to finding offending dependencies would be to follow
    1097 
    +dependencies starting from all units that /any/ home unit directly depends on
    1098 
    +instead of considering the different home units separately. A corresponding
    1099 
    +algorithm could in principle find the dependencies of a particular unit
    1100 
    +independently of any home unit by fetching the 'UnitInfo' of that unit from the
    1101 
    +'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not
    1102 
    +only the 'UnitId' but also the ABI hash of the unit in question. Therefore,
    1103 
    +whenever following a dependency of a unit /u/ on a unit /v/, it would have to
    1104 
    +determine the ABI hash of /v/, so that it could later look up /v/’s
    1105 
    +dependencies. The ABI hashes of all units that /u/ depends on should be
    1106 
    +available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the
    1107 
    +time of writing, 'unitAbiDepends' never contained anything other than the empty
    1108 
    +list during GHC test runs, which indicated that this alternative solution was
    1109 
    +impossible to realize.
    1110 
    +
    1111 
    +-}
    982 1112
    983 1113 
     --------------------------------------------------------------------------------
    984 1114 
     -- * Enable Code Gen for Template Haskell
    ... ... @@ -1763,7 +1893,7 @@ data NodeRes v
    1763 1893 
     --
    1764 1894 
     -- See also Note [Downsweep Control Flow and Caching]
    1765 1895 
     dfsBuild :: (Ord k, Monad m)
    1766 
    -         => Maybe (Map.Map k (NodeRes v))
    1896 
    +         => Maybe (Map k (NodeRes v))
    1767 1897 
              -- ^ Base map, existing results. We won't re-expand any of the nodes
    1768 1898 
              -- already present in this map.
    1769 1899 
              -> [n]
    ... ... @@ -1773,7 +1903,7 @@ dfsBuild :: (Ord k, Monad m)
    1773 1903 
              -> (n -> m (NodeRes (v,[n])))
    1774 1904 
              -- ^ Expand this node into its payload result and into the list of
    1775 1905 
              -- children nodes to visit next.
    1776 
    -         -> m (Map.Map k (NodeRes v))
    1906 
    +         -> m (Map k (NodeRes v))
    1777 1907 
              -- ^ The result accumulates the payload of expanding the root nodes
    1778 1908 
              -- and all nodes transitively reachable from those roots.
    1779 1909 
     dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)

  • compiler/GHC/Driver/Errors/Ppr.hs
    ... ... @@ -235,10 +235,17 @@ instance Diagnostic DriverMessage where
    235 235 
                            "but no output will be generated.") $$
    236 236 
                            (text "There is no module named" <+>
    237 237 
                            quotes (ppr mod_name) <> text "."))
    238 
    -    DriverHomePackagesNotClosed needed_unit_ids
    239 
    -      -> mkSimpleDecorated $ vcat ([text "Home units are not closed."
    240 
    -                                  , text "It is necessary to also load the following units:" ]
    241 
    -                                  ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
    238 
    +    DriverHomePackagesNotClosed offending_dependencies
    239 
    +      -> mkSimpleDecorated $
    240 
    +         hang (text "Some units are not loaded but depend on loaded units.")
    241 
    +              4
    242 
    +              (vcat (map pprDependency offending_dependencies))
    243 
    +      where
    244 
    +
    245 
    +        pprDependency :: (UnitId, UnitId) -> SDoc
    246 
    +        pprDependency (external_unit, home_unit)
    247 
    +          = ppr external_unit <+> arrow <+> ppr home_unit
    248 
    +
    242 249 
         DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason
    243 250
    244 251 
         DriverInconsistentDynFlags msg

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -369,7 +369,7 @@ data DriverMessage where
    369 369
    370 370 
       DriverRedirectedNoMain :: !ModuleName -> DriverMessage
    371 371
    372 
    -  DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
    372 
    +  DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage
    373 373
    374 374 
       DriverInterfaceError :: !IfaceMessage -> DriverMessage
    375 375

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -181,7 +181,8 @@ module GHC.Driver.Session (
    181 181 
             -- ** Available DynFlags
    182 182 
             allNonDeprecatedFlags,
    183 183 
             flagsAll,
    184 
    -        flagsDynamic,
    184 
    +        flagsAllTrie,
    185 
    +        flagsDynamicTrie,
    185 186 
             flagsPackage,
    186 187 
             flagsForCompletion,
    187 188
    ... ... @@ -294,8 +295,7 @@ import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion )
    294 295 
     import Data.IORef
    295 296 
     import Control.Arrow ((&&&))
    296 297 
     import Control.Monad
    297 
    -import Control.Monad.Trans.State as State
    298 
    -import Data.Functor.Identity
    298 
    +import Control.Monad.Trans.State (runStateT)
    299 299
    300 300 
     import Data.Ord
    301 301 
     import Data.Char
    ... ... @@ -391,6 +391,37 @@ import Language.Haskell.Syntax.Text
    391 391 
     --
    392 392 
     --  See #4437 and #8176.
    393 393
    394 
    +-- Note [Optimising the processing of command-line arguments]
    395 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    396 
    +-- For each command line argument we need to search all the possible flag names to
    397 
    +-- find the correct command-line argument processor (of type `CmdLineP DynFlags`)
    398 
    +-- to complete parsing of the argument and modify the `DynFlags`.
    399 
    +--
    400 
    +-- GHC has a LOT of flags, and occasionally, users give a LOT of command line
    401 
    +-- arguments. So in some cases it pays to optimize the search for a command-line
    402 
    +-- argument processor (#25763).
    403 
    +--
    404 
    +-- An additional complication is that flag specs need to be looked up with a
    405 
    +-- string that may contain the flag key as a prefix.
    406 
    +--
    407 
    +-- In general, the `=` sign is optional, and anything after the name of the flag,
    408 
    +-- if it doesn't start with `=`, is considered the argument. E.g.
    409 
    +-- `-odirsome/path`, or `-pgmFprogram`, or `-package-dbDiff`, or `-optc-DFOO`,
    410 
    +-- or `-Isome/path`, or `-fpluginLiquidHaskell`, or `-fplugin-optLiquidHaskell:--save`.
    411 
    +--
    412 
    +-- To achieve this:
    413 
    +--
    414 
    +-- * We build global lookup tables
    415 
    +--     * GHC.Driver.Session.flagsAllTrie :: FlagSpecTrie DynFlags
    416 
    +--     * GHC.Driver.Session.flagsDynamicTrie :: FlagSpecTrie DynFlags
    417 
    +--     * GHC.Driver.Session.Mode.mode_flags_trie :: FlagSpecTrie ModeMS
    418 
    +--
    419 
    +--   These are implemented by a trie indexed by Strings, see GHC.Data.StringTrie.
    420 
    +--
    421 
    +-- * As we process each command line argument, one by one, we
    422 
    +--   look up in the `FlagSpecTrie` to find which processor
    423 
    +--   to use.  See `GHC.Driver.CmdLine.processArgs`.
    424 
    +
    394 425 
     -- -----------------------------------------------------------------------------
    395 426 
     -- DynFlags
    396 427
    ... ... @@ -837,7 +868,7 @@ parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]
    837 868 
                              -> m (DynFlags, [Located String], Messages DriverMessage)
    838 869 
                                 -- ^ Updated 'DynFlags', left-over arguments, and
    839 870 
                                 -- list of warnings.
    840 
    -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
    871 
    +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAllTrie True
    841 872
    842 873
    843 874 
     -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags
    ... ... @@ -847,42 +878,19 @@ parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]
    847 878 
                            -> m (DynFlags, [Located String], Messages DriverMessage)
    848 879 
                               -- ^ Updated 'DynFlags', left-over arguments, and
    849 880 
                               -- list of warnings.
    850 
    -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
    851 
    -
    852 
    -newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)
    853 
    -  deriving (Functor)
    854 
    -
    855 
    -instance Monad (CmdLineP s) where
    856 
    -    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)
    857 
    -    return = pure
    858 
    -
    859 
    -instance Applicative (CmdLineP s) where
    860 
    -    pure x = CmdLineP (pure x)
    861 
    -    (<*>) = ap
    862 
    -
    863 
    -getCmdLineState :: CmdLineP s s
    864 
    -getCmdLineState = CmdLineP State.get
    865 
    -
    866 
    -putCmdLineState :: s -> CmdLineP s ()
    867 
    -putCmdLineState x = CmdLineP (State.put x)
    868 
    -
    869 
    -runCmdLineP :: CmdLineP s a -> s -> (a, s)
    870 
    -runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0
    881 
    +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamicTrie False
    871 882
    872 883 
     -- | A helper to parse a set of flags from a list of command-line arguments, handling
    873 884 
     -- response files.
    874 885 
     processCmdLineP
    875 886 
         :: forall s m. MonadIO m
    876 
    -    => [Flag (CmdLineP s)]  -- ^ valid flags to match against
    887 
    +    => FlagSpecTrie s          -- ^ valid flags to match against
    877 888 
         -> s                    -- ^ current state
    878 889 
         -> [Located String]     -- ^ arguments to parse
    879 890 
         -> m (([Located String], [Err], [Warn]), s)
    880 891 
                                 -- ^ (leftovers, errors, warnings)
    881 892 
     processCmdLineP activeFlags s0 args =
    882 
    -    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0
    883 
    -  where
    884 
    -    getCmdLineP :: CmdLineP s a -> StateT s m a
    885 
    -    getCmdLineP (CmdLineP k) = k
    893 
    +    runStateT (processArgs activeFlags args parseResponseFile) s0
    886 894
    887 895 
     -- | Parses the dynamically set flags for GHC. This is the most general form of
    888 896 
     -- the dynamic flag parser that the other methods simply wrap. It allows
    ... ... @@ -890,7 +898,7 @@ processCmdLineP activeFlags s0 args =
    890 898 
     -- arguments from the command line or from a file pragma.
    891 899 
     parseDynamicFlagsFull
    892 900 
         :: forall m. MonadIO m
    893 
    -    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against
    901 
    +    => FlagSpecTrie DynFlags         -- ^ valid flags to match against
    894 902 
         -> Bool                          -- ^ are the arguments from the command line?
    895 903 
         -> Logger                        -- ^ logger
    896 904 
         -> DynFlags                      -- ^ current dynamic flags
    ... ... @@ -1012,14 +1020,22 @@ allFlagsDeps keepDeprecated = [ '-':flagName flag
    1012 1020 
     flagsAll :: [Flag (CmdLineP DynFlags)]
    1013 1021 
     flagsAll = map snd flagsAllDeps
    1014 1022
    1023 
    +-- | Same as 'flagsAll' but in trie form for fast lookup.
    1024 
    +--
    1025 
    +-- See Note [Optimising the processing of command-line arguments]
    1026 
    +flagsAllTrie :: FlagSpecTrie DynFlags
    1027 
    +flagsAllTrie = extendFlagSpecTrie flagsDynamicTrie $ map snd package_flags_deps
    1028 
    +
    1015 1029 
     -- All dynamic flags present in GHC with deprecation information.
    1016 1030 
     flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]
    1017 1031 
     flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps
    1018 1032
    1019 1033
    1020 1034 
     -- All dynamic flags, minus package flags, present in GHC.
    1021 
    -flagsDynamic :: [Flag (CmdLineP DynFlags)]
    1022 
    -flagsDynamic = map snd dynamic_flags_deps
    1035 
    +--
    1036 
    +-- See Note [Optimising the processing of command-line arguments].
    1037 
    +flagsDynamicTrie :: FlagSpecTrie DynFlags
    1038 
    +flagsDynamicTrie = mkFlagSpecTrie $ map snd dynamic_flags_deps
    1023 1039
    1024 1040 
     -- ALl package flags present in GHC.
    1025 1041 
     flagsPackage :: [Flag (CmdLineP DynFlags)]
    ... ... @@ -2013,8 +2029,7 @@ dynamic_flags_deps = [
    2013 2029 
      ++
    2014 2030
    2015 2031 
             ------ Warning flags -------------------------------------------------
    2016 
    -  [ make_ord_flag defFlag "W"       (NoArg (setWarningGroup W_extra))
    2017 
    -  , make_ord_flag defFlag "Werror"
    2032 
    +  [ make_ord_flag defFlag "Werror"
    2018 2033 
                    (NoArg (do { setGeneralFlag Opt_WarnIsError
    2019 2034 
                               ; setFatalWarningGroup W_everything }))
    2020 2035 
       , make_ord_flag defFlag "Wwarn"
    ... ... @@ -2040,7 +2055,7 @@ dynamic_flags_deps = [
    2040 2055 
         , (NotDeprecated, customOrUnrecognisedWarning "Werror="    setCustomWErrorFlag)
    2041 2056 
         , (NotDeprecated, customOrUnrecognisedWarning "Wwarn="     unSetCustomFatalWarningFlag)
    2042 2057 
         , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag)
    2043 
    -    , (NotDeprecated, customOrUnrecognisedWarning "W"          setCustomWarningFlag)
    2058 
    +    , flagW
    2044 2059 
         , (Deprecated,    customOrUnrecognisedWarning "fwarn-"     setCustomWarningFlag)
    2045 2060 
         , (Deprecated,    customOrUnrecognisedWarning "fno-warn-"  unSetCustomWarningFlag)
    2046 2061 
         ]
    ... ... @@ -2076,19 +2091,35 @@ warningControls set unset set_werror unset_fatal xs =
    2076 2091 
      ++ map (mkFlag turnOn  "fwarn-"     set   . hideFlag) xs
    2077 2092 
      ++ map (mkFlag turnOff "fno-warn-"  unset . hideFlag) xs
    2078 2093
    2094 
    +-- | The "W" flag is special in that it can mean enable extra warnings ('W_extra')
    2095 
    +-- or enable a custom warning, if the suffix is non-empty.
    2096 
    +flagW :: (Deprecation, Flag (CmdLineP DynFlags))
    2097 
    +flagW =
    2098 
    +  make_ord_flag defFlag "W" $ OptPrefix $ \suffix ->
    2099 
    +    if null suffix then do
    2100 
    +      -- Reject "-W=" instead of taking it to mean "-W".
    2101 
    +      arg <- getArg
    2102 
    +      if arg == "-W" then
    2103 
    +        setWarningGroup W_extra
    2104 
    +      else
    2105 
    +        addErr ("missing argument for flag: " ++ arg)
    2106 
    +    else
    2107 
    +      customOrUnrecognisedWarningAction "W" setCustomWarningFlag suffix
    2108 
    +
    2079 2109 
     -- | This is where we handle unrecognised warning flags. If the flag is valid as
    2080 2110 
     -- an extended warning category, we call the supplied action. Otherwise, issue a
    2081 2111 
     -- warning if -Wunrecognised-warning-flags is set. See #11429 for context.
    2082 2112 
     -- See Note [Warning categories] in GHC.Unit.Module.Warnings.
    2083 2113 
     customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags)
    2084 
    -customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action)
    2085 
    -  where
    2086 
    -    action :: String -> DynP ()
    2087 
    -    action flag
    2114 
    +customOrUnrecognisedWarning prefix custom =
    2115 
    +  defHiddenFlag prefix $ Prefix $ customOrUnrecognisedWarningAction prefix custom
    2116 
    +
    2117 
    +customOrUnrecognisedWarningAction :: String -> (WarningCategory -> DynP ()) -> String -> DynP ()
    2118 
    +customOrUnrecognisedWarningAction prefix custom flag
    2088 2119 
           | validWarningCategory cat = custom cat
    2089 2120 
           | otherwise = unrecognised flag
    2090 
    -      where
    2091 
    -        cat = mkWarningCategory (packHText flag)
    2121 
    +  where
    2122 
    +    cat = mkWarningCategory (packHText flag)
    2092 2123
    2093 2124 
         unrecognised flag = do
    2094 2125 
           -- #23402 and #12056

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -443,13 +443,14 @@ The flow:
    443 443 
     Closure Property
    444 444 
     ----------------
    445 445
    446 
    -You must perform a clean cut of the dependency graph.
    446 
    +A unit environment must have the closure property:
    447 447
    448 
    -> Any dependency which is not a home unit must not (transitively) depend on a home unit.
    448 
    +    No used external unit depends on a home unit.
    449 449
    450 
    -For example, if you have three packages p, q and r, then if p depends on q which
    451 
    -depends on r then it is illegal to load both p and r as home units but not q,
    452 
    -because q is a dependency of the home unit p which depends on another home unit r.
    450 
    +More concretely, a unit environment has the closure property exactly if no home
    451 
    +unit directly or indirectly depends on an external unit that directly or
    452 
    +indirectly depends on a home unit. 'GHC.Driver.Downsweep.checkHomeUnitsClosed'
    453 
    +checks whether a given unit environment indeed has this property.
    453 454
    454 455 
     Offsetting Paths
    455 456 
     ----------------

  • compiler/ghc.cabal.in
    ... ... @@ -474,6 +474,7 @@ Library
    474 474 
             GHC.Data.Stream
    475 475 
             GHC.Data.Strict
    476 476 
             GHC.Data.StringBuffer
    477 
    +        GHC.Data.StringTrie
    477 478 
             GHC.Data.TrieMap
    478 479 
             GHC.Data.Unboxed
    479 480 
             GHC.Data.UnionFind

  • ghc/GHC/Driver/Session/Mode.hs
    ... ... @@ -180,7 +180,7 @@ parseModeFlags :: [Located String]
    180 180 
                           [Warn])
    181 181 
     parseModeFlags args = do
    182 182 
       ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-
    183 
    -        processCmdLineP mode_flags (Nothing, [], [], []) args
    183 
    +        processCmdLineP mode_flags_trie (Nothing, [], [], []) args
    184 184 
       let mode = case mModeFlag of
    185 185 
                  Nothing     -> doMakeMode
    186 186 
                  Just (m, _) -> m
    ... ... @@ -191,10 +191,14 @@ parseModeFlags args = do
    191 191
    192 192 
       return (mode, units, flags' ++ leftover, warns)
    193 193
    194 
    -type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String])
    194 
    +type ModeMS = (Maybe (Mode, String), [String], [String], [Located String])
    195 
    +type ModeM = CmdLineP ModeMS
    195 196 
       -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
    196 197 
       -- so we collect the new ones and return them.
    197 198
    199 
    +mode_flags_trie :: FlagSpecTrie ModeMS
    200 
    +mode_flags_trie = mkFlagSpecTrie mode_flags
    201 
    +
    198 202 
     mode_flags :: [Flag ModeM]
    199 203 
     mode_flags =
    200 204 
       [  ------- help / version ----------------------------------------------

  • rts/include/stg/Prim.h
    ... ... @@ -59,16 +59,16 @@ StgWord hs_xchg32(StgWord x, StgWord val);
    59 59 
     StgWord64 hs_xchg64(StgWord x, StgWord64 val);
    60 60
    61 61 
     /* rts/prim/bswap.c */
    62 
    -StgWord16 hs_bswap16(StgWord16 x);
    63 
    -StgWord32 hs_bswap32(StgWord32 x);
    62 
    +StgWord hs_bswap16(StgWord x);
    63 
    +StgWord hs_bswap32(StgWord x);
    64 64 
     StgWord64 hs_bswap64(StgWord64 x);
    65 65
    66 66 
     /* rts/prim/bitrev.c
    67 67 
     This was done as part of issue #16164.
    68 68 
     See Note [Bit reversal primop] for more details about the implementation.*/
    69 69 
     StgWord hs_bitrev8(StgWord x);
    70 
    -StgWord16 hs_bitrev16(StgWord16 x);
    71 
    -StgWord32 hs_bitrev32(StgWord32 x);
    70 
    +StgWord hs_bitrev16(StgWord x);
    71 
    +StgWord hs_bitrev32(StgWord x);
    72 72 
     StgWord64 hs_bitrev64(StgWord64 x);
    73 73
    74 74 
     /* rts/prim/longlong.c */

  • rts/prim/bitrev.c
    ... ... @@ -36,8 +36,8 @@ hs_bitrev8(StgWord x)
    36 36 
       return x;
    37 37 
     }
    38 38
    39 
    -StgWord16
    40 
    -hs_bitrev16(StgWord16 x)
    39 
    +StgWord
    40 
    +hs_bitrev16(StgWord x)
    41 41 
     {
    42 42 
       x = ((x >> 1) & 0x5555) | ((x & 0x5555) << 1 );
    43 43 
       x = ((x >> 2) & 0x3333) | ((x & 0x3333) << 2 );
    ... ... @@ -46,14 +46,14 @@ hs_bitrev16(StgWord16 x)
    46 46 
       return x;
    47 47 
     }
    48 48
    49 
    -StgWord32
    50 
    -hs_bitrev32(StgWord32 x)
    49 
    +StgWord
    50 
    +hs_bitrev32(StgWord x)
    51 51 
     {
    52 
    -  x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 );
    53 
    -  x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 );
    54 
    -  x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 );
    55 
    -  x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 );
    56 
    -  x = ( x >> 16             ) | ( x << 16              );
    52 
    +  x = ((x >> 1)  & 0x55555555) | ((x & 0x55555555) << 1 );
    53 
    +  x = ((x >> 2)  & 0x33333333) | ((x & 0x33333333) << 2 );
    54 
    +  x = ((x >> 4)  & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 );
    55 
    +  x = ((x >> 8)  & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 );
    56 
    +  x = ((x >> 16) & 0x0000FFFF) | ((x & 0x0000FFFF) << 16);
    57 57 
       return x;
    58 58 
     }
    59 59

  • rts/prim/bswap.c
    1 1 
     #include "Rts.h"
    2 2
    3 
    -StgWord16
    4 
    -hs_bswap16(StgWord16 x)
    3 
    +StgWord
    4 
    +hs_bswap16(StgWord x)
    5 5 
     {
    6 
    -  return ((x >> 8) | (x << 8));
    6 
    +  x = (StgWord16)x;
    7 
    +  return (StgWord16)((x >> 8) | (x << 8));
    7 8 
     }
    8 9
    9 
    -StgWord32
    10 
    -hs_bswap32(StgWord32 x)
    10 
    +StgWord
    11 
    +hs_bswap32(StgWord x)
    11 12 
     {
    12 
    -  return ((x >> 24) | ((x >> 8) & 0xff00) |
    13 
    -          (x << 24) | ((x & 0xff00) << 8));
    13 
    +  x = (StgWord32)x;
    14 
    +  return (StgWord32)((x >> 24) | ((x >> 8) & 0xff00) |
    15 
    +                     (x << 24) | ((x & 0xff00) << 8));
    14 16 
     }
    15 17
    16 18 
     StgWord64

  • testsuite/tests/MiniQuickCheck.hs
    ... ... @@ -28,6 +28,7 @@ module MiniQuickCheck
    28 28 
       , propertyCompare
    29 29 
       , propertyAnd
    30 30 
       , propertyTrue
    31 
    +  , propertyEqWithContext
    31 32 
       , getCheck
    32 33
    33 34 
         -- * QuickCheck test tree
    ... ... @@ -51,11 +52,15 @@ module MiniQuickCheck
    51 52 
       , nonZero
    52 53 
       , BoundedShiftAmount(..)
    53 54 
       , BoundedBy(..)
    55 
    +  , BoundedList(..)
    56 
    +  , BoundedChar(..)
    54 57 
       ) where
    55 58
    56 59 
     -- base
    57 60 
     import Control.Exception
    58 61 
       ( SomeException, displayException, evaluate, try )
    62 
    +import Control.Monad
    63 
    +  ( replicateM )
    59 64 
     import Control.Monad.IO.Class
    60 65 
       ( liftIO )
    61 66 
     import Data.Bits
    ... ... @@ -64,8 +69,6 @@ import Data.Bits
    64 69 
       )
    65 70 
     import Data.Int
    66 71 
       ( Int8, Int16, Int32, Int64 )
    67 
    -import Data.IORef
    68 
    -  ( newIORef, atomicModifyIORef' )
    69 72 
     import Data.Kind
    70 73 
       ( Type )
    71 74 
     import Data.List
    ... ... @@ -84,6 +87,8 @@ import System.Exit
    84 87 
       ( die, exitFailure )
    85 88 
     import Text.Read
    86 89 
       ( readMaybe )
    90 
    +import System.IO.Unsafe
    91 
    +  ( unsafePerformIO )
    87 92
    88 93 
     -- transformers
    89 94 
     import Control.Monad.Trans.Reader
    ... ... @@ -141,6 +146,15 @@ propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b)
    141 146 
     (===) = propertyCompare "==" (==)
    142 147 
     infix 4 ===
    143 148
    149 
    +-- | Prints the given message when the two values are not equal.
    150 
    +propertyEqWithContext :: (Eq a, Show a) => String -> a -> a -> PropertyCheck
    151 
    +propertyEqWithContext msg =
    152 
    +  propertyCompare
    153 
    +    (intercalate "\n" $
    154 
    +      "is not the expected" : map ("    " ++) (lines msg ++ ["expected:"])
    155 
    +    )
    156 
    +    (==)
    157 
    +
    144 158 
     -- | Conjunction of two property checks.
    145 159 
     propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck
    146 160 
     propertyAnd = PropertyAnd
    ... ... @@ -424,3 +438,28 @@ instance
    424 438 
         where
    425 439 
           n :: a
    426 440 
           n = fromIntegral $ natVal @n Proxy
    441 
    +
    442 
    +type BoundedList :: Nat -> Type -> Type
    443 
    +newtype BoundedList n a = BoundedList { getBoundedList :: [a] }
    444 
    +  deriving (Eq, Ord, Show)
    445 
    +
    446 
    +instance
    447 
    +  forall n a
    448 
    +  . ( KnownNat n, Arbitrary a )
    449 
    +  => Arbitrary ( BoundedList n a ) where
    450 
    +  arbitrary = do
    451 
    +    x <- arbitrary
    452 
    +    let n = (x :: Word64) `mod` fromIntegral (natVal @n Proxy + 1)
    453 
    +    BoundedList <$> replicateM (fromIntegral n) arbitrary
    454 
    +
    455 
    +instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
    456 
    +  arbitrary = (,) <$> arbitrary <*> arbitrary
    457 
    +
    458 
    +type BoundedChar :: Nat -> Type
    459 
    +newtype BoundedChar n = BoundedChar { getBoundedChar :: Char }
    460 
    +  deriving (Eq, Ord, Show)
    461 
    +
    462 
    +instance KnownNat n => Arbitrary (BoundedChar n)  where
    463 
    +  arbitrary = do
    464 
    +    x <- getBoundedBy @_ @n <$> arbitrary
    465 
    +    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,
    99 99
    100 100 
     test('T2566', normalise_fun(normalise_errmsg), makefile_test, [])
    101 101
    102 
    +test('stringtrie', [mini_quickcheck], compile_and_run, ['-package ghc'])
    103 
    +
    102 104 
     test('pragma001', normal, compile, [''])
    103 105 
     test('pragma002', normal, compile, [''])
    104 106

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile
    ... ... @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 5 
     SETUP=../Setup -v0
    6 
    +CONFIGURE=configure \
    7 
    +	  $(CABAL_MINIMAL_BUILD) \
    8 
    +	  --with-ghc='$(TEST_HC)' \
    9 
    +	  --with-hc-pkg='$(GHC_PKG)' \
    10 
    +	  --ghc-options='$(TEST_HC_OPTS)' \
    11 
    +	  --package-db=../tmp.d
    12 
    +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp
    13 
    +ONLY_BASE=-hide-all-packages -package base
    6 14
    7 
    -mhu-closure: clean
    8 
    -	$(MAKE) -s --no-print-directory clean
    15 
    +mhu-closure: clean pkg-database
    16 
    +	! $(TEST_BUILD) -unit @unitP
    17 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ
    18 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR
    19 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR1
    20 
    +	$(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR
    21 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1
    22 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP
    23 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ
    24 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR
    25 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1
    26 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR
    27 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1
    28 
    +
    29 
    +.PHONY: pkg-database
    30 
    +pkg-database:
    9 31 
     	'$(GHC_PKG)' init tmp.d
    10 32 
     	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
    11 
    -	cd p && $(SETUP) clean
    12 
    -	cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    33 
    +	cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0
    13 34 
     	cd p && $(SETUP) build
    14 35 
     	cd p && $(SETUP) register --inplace
    15 
    -	cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=q-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    36 
    +	cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0
    16 37 
     	cd q && $(SETUP) build
    17 38 
     	cd q && $(SETUP) register --inplace
    18 
    -	cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=r-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    39 
    +	cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0
    19 40 
     	cd r && $(SETUP) build
    20 41 
     	cd r && $(SETUP) register --inplace
    21 
    -	# This should work
    22 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP
    23 
    -	# So should this
    24 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ
    25 
    -	# So should this
    26 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR
    27 
    -	# This should error with a closure message
    28 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR
    29 
    -	# This should work, even though r1 is not in the package db
    30 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1
    31 
    -	# This should fail, even though r1 is not in the package db
    32 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1
    33 42
    43 
    +.PHONY: clean
    44 
    +clean:
    45 
    +	$(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o
    34 46
    35 47 
     ifeq "$(CLEANUP)" "1"
    36 48 
     	$(MAKE) -s --no-print-directory clean
    37 49 
     endif
    38 
    -
    39 
    -clean :
    40 
    -	 $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
    41 
    -

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr
    1 1
    2 2 
     <command line>: error: [GHC-03271]
    3 
    -    Home units are not closed.
    4 
    -    It is necessary to also load the following units:
    5 
    -    - q-0.1.0.0
    3 
    +    Some units are not loaded but depend on loaded units.
    4 
    +        q-0.1.0.0 -> p-0.1.0.0
    6 5
    7 6 
     <command line>: error: [GHC-03271]
    8 
    -    Home units are not closed.
    9 
    -    It is necessary to also load the following units:
    10 
    -    - q-0.1.0.0
    7 
    +    Some units are not loaded but depend on loaded units.
    8 
    +        r-0.1.0.0 -> q-0.1.0.0
    9 
    +
    10 
    +<command line>: error: [GHC-03271]
    11 
    +    Some units are not loaded but depend on loaded units.
    12 
    +        q-0.1.0.0 -> p-0.1.0.0
    13 
    +
    14 
    +<command line>: error: [GHC-03271]
    15 
    +    Some units are not loaded but depend on loaded units.
    16 
    +        q-0.1.0.0 -> p-0.1.0.0
    17 
    +
    18 
    +<command line>: error: [GHC-03271]
    19 
    +    Some units are not loaded but depend on loaded units.
    20 
    +        r-0.1.0.0 -> q-0.1.0.0
    21 
    +
    22 
    +<command line>: error: [GHC-03271]
    23 
    +    Some units are not loaded but depend on loaded units.
    24 
    +        q-0.1.0.0 -> p-0.1.0.0
    25 
    +
    26 
    +<command line>: error: [GHC-03271]
    27 
    +    Some units are not loaded but depend on loaded units.
    28 
    +        q-0.1.0.0 -> p-0.1.0.0

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout
    1 
    +[1 of 3] Compiling P[p-0.1.0.0]
    2 
    +[2 of 3] Compiling Q[q-0.1.0.0]
    3 
    +[3 of 3] Compiling R[r-0.1.0.0]
    1 4 
     [1 of 1] Compiling P
    2 5 
     [1 of 2] Compiling P[p-0.1.0.0]
    3 6 
     [2 of 2] Compiling Q[q-0.1.0.0]

  • testsuite/tests/driver/stringtrie.hs
    1 
    +{-# LANGUAGE DataKinds #-}
    2 
    +{-# LANGUAGE TypeApplications #-}
    3 
    +{-# LANGUAGE TypeFamilies #-}
    4 
    +
    5 
    +import Data.Bifunctor (first)
    6 
    +import Data.Coerce
    7 
    +import Data.Function (on)
    8 
    +import Data.List (nubBy, sortOn, stripPrefix)
    9 
    +import GHC.Data.StringTrie as StringTrie
    10 
    +import MiniQuickCheck
    11 
    +
    12 
    +main :: IO ()
    13 
    +main = do
    14 
    +  runTestsMain (Iterations 1000) tests
    15 
    +  -- runTests (Iterations 100) 9856592474076851907 tests
    16 
    +
    17 
    +tests :: Test
    18 
    +tests = Group "StringTrie"
    19 
    +    [ Property "lookup_after_insert" prop_lookup_after_insert
    20 
    +    , Property "fromList == foldl (flip $ uncurry insert) empty" prop_fromList_foldl
    21 
    +    ]
    22 
    +
    23 
    +type BString4 = BoundedList 4 (BoundedChar 4)
    24 
    +
    25 
    +-- | @lookup qs (insert k v t)@ returns the values of matching keys ordered by
    26 
    +-- suffix length.
    27 
    +prop_lookup_after_insert
    28 
    +     -- | query string as a bounded list
    29 
    +  :: BoundedList 6 (BoundedChar 3)
    30 
    +     -- | length of the key to insert in @t@
    31 
    +  -> BoundedBy Int 3
    32 
    +     -- | value to insert in @t@
    33 
    +  -> BoundedBy Int 9
    34 
    +     -- | list of key-value pairs to build the trie @t@
    35 
    +  -> BoundedList 6 (BString4, Int `BoundedBy` 9)
    36 
    +  -> PropertyCheck
    37 
    +prop_lookup_after_insert bqs i0 v0 bkvs =
    38 
    +  let kvs = coerce bkvs :: [(String, Int)]
    39 
    +      t = fromList kvs
    40 
    +      qs = coerce @_ @String bqs
    41 
    +      i = min (abs (getBoundedBy i0)) (length qs)
    42 
    +      k = take i qs
    43 
    +      v = getBoundedBy v0
    44 
    +      -- (v1, sfx1) pairs where (k1, v1) is in t and k1 is a prefix of qs
    45 
    +      expected =
    46 
    +        [ (v1, sfx1)
    47 
    +        | kv@(k1, v1) <- nubBy ((==) `on` fst) $ (k, v) : reverse kvs
    48 
    +        , Just sfx1 <- [stripPrefix k1 qs]
    49 
    +        ]
    50 
    +   in
    51 
    +      propertyEqWithContext
    52 
    +        (unlines
    53 
    +            [ "k = " ++ show k
    54 
    +            , "v = " ++ show v
    55 
    +            , "qs = " ++ show qs
    56 
    +            , "kvs = " ++ show kvs
    57 
    +            ]
    58 
    +        )
    59 
    +        (StringTrie.lookup qs (insert k v t))
    60 
    +        (sortOn (length . snd) expected)
    61 
    +
    62 
    +-- | @fromList xs == foldl (flip $ uncurry insert) empty xs@
    63 
    +prop_fromList_foldl
    64 
    +     -- | list of key-value pairs to build the trie @t@
    65 
    +  :: Int `BoundedBy` 7
    66 
    +  -> BoundedList 6 (BString4, Int `BoundedBy` 9)
    67 
    +  -> PropertyCheck
    68 
    +prop_fromList_foldl (BoundedBy sparseness) bkvs =
    69 
    +  let kvs = map (first shiftString) $ coerce bkvs :: [(String, Int)]
    70 
    +   in propertyEqWithContext
    71 
    +        (unlines ["kvs = " ++ show kvs])
    72 
    +        (fromListWithSparseness (sparseness - 1) kvs)
    73 
    +        (foldl (flip $ uncurry insert) empty kvs)
    74 
    +  where
    75 
    +    -- Bring characters next to the end of the ASCII range to test the
    76 
    +    -- array-based implementation of fromList.
    77 
    +    shiftString = map shiftChar
    78 
    +    shiftChar = charPlus (126 - fromEnum 'a')
    79 
    +    charPlus x c = toEnum (x + fromEnum c)

  • testsuite/tests/driver/stringtrie.stdout
    1 
    +Group StringTrie
    2 
    +  Running lookup_after_insert
    3 
    +    Passed 1000 iterations
    4 
    +  Running fromList == foldl (flip $ uncurry insert) empty
    5 
    +    Passed 1000 iterations

  • testsuite/tests/perf/compiler/T25763.stderr
    1 
    +[1 of 1] Compiling Main             ( t25763.hs, nothing )

  • testsuite/tests/perf/compiler/all.T
    ... ... @@ -874,6 +874,16 @@ test ('T24984',
    874 874 
           compile,
    875 875 
           ['-O'])
    876 876
    877 
    +# Performance regression test for the parser of command line arguments
    878 
    +test(
    879 
    +    'T25763',
    880 
    +    [
    881 
    +        collect_compiler_runtime(5),
    882 
    +        pre_cmd(f'seq 400000 | sed "s/.*/-XCPP/" > t25763.txt && echo "main = pure ()" > t25763.hs'),
    883 
    +    ],
    884 
    +    multimod_compile,
    885 
    +    ['t25763', '@t25763.txt -c -fno-code'])
    886 
    +
    877 887 
     test('interpreter_steplocal',
    878 888 
          [ collect_compiler_stats('bytes allocated', 5)
    879 889 
          ],

  • testsuite/tests/primops/should_run/T27299.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +import GHC.Exts
    3 
    +import GHC.Word
    4 
    +import Numeric
    5 
    +
    6 
    +main :: IO ()
    7 
    +main = do
    8 
    +  putStrLn $ showHex (W# (bitReverse8# 0x55##)) ""
    9 
    +  putStrLn $ showHex (W# (bitReverse8# 0xAA##)) ""
    10 
    +  putStrLn $ showHex (W# (bitReverse16# 0x5555##)) ""
    11 
    +  putStrLn $ showHex (W# (bitReverse16# 0xAAAA##)) ""
    12 
    +  putStrLn $ showHex (W# (bitReverse32# 0x5555_5555##)) ""
    13 
    +  putStrLn $ showHex (W# (bitReverse32# 0xAAAA_AAAA##)) ""
    14 
    +  putStrLn $ showHex (W# (byteSwap16# 0xABCD##)) ""
    15 
    +  putStrLn $ showHex (W# (byteSwap32# 0xABCD_EF12##)) ""
    16 
    +  putStrLn $ showHex (W# (noinline bitReverse8# 0x55##)) ""
    17 
    +  putStrLn $ showHex (W# (noinline bitReverse8# 0xAA##)) ""
    18 
    +  putStrLn $ showHex (W# (noinline bitReverse16# 0x5555##)) ""
    19 
    +  putStrLn $ showHex (W# (noinline bitReverse16# 0xAAAA##)) ""
    20 
    +  putStrLn $ showHex (W# (noinline bitReverse32# 0x5555_5555##)) ""
    21 
    +  putStrLn $ showHex (W# (noinline bitReverse32# 0xAAAA_AAAA##)) ""
    22 
    +  putStrLn $ showHex (W# (noinline byteSwap16# 0xABCD##)) ""
    23 
    +  putStrLn $ showHex (W# (noinline byteSwap32# 0xABCD_EF12##)) ""

  • testsuite/tests/primops/should_run/T27299.stdout
    1 
    +aa
    2 
    +55
    3 
    +aaaa
    4 
    +5555
    5 
    +aaaaaaaa
    6 
    +55555555
    7 
    +cdab
    8 
    +12efcdab
    9 
    +aa
    10 
    +55
    11 
    +aaaa
    12 
    +5555
    13 
    +aaaaaaaa
    14 
    +55555555
    15 
    +cdab
    16 
    +12efcdab

  • testsuite/tests/primops/should_run/all.T
    ... ... @@ -91,3 +91,4 @@ test('T24496'
    91 91 
           ]
    92 92 
         , compile_and_run, ['-O'])
    93 93 
     test('T6026', normal, compile_and_run, [''])
    94 
    +test('T27299', normal, compile_and_run, [''])

  • testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr
    1 
    +ghc: on the commandline: missing argument for flag: -W=
    2 
    +Usage: For basic information, try the `--help' option.

  • testsuite/tests/warnings/should_fail/all.T
    ... ... @@ -15,6 +15,7 @@ test('CaretDiagnostics1',
    15 15 
          [normalise_whitespace_fun(normalise_whitespace_carefully)],
    16 16 
          compile_fail,
    17 17 
          ['-fdiagnostics-show-caret -ferror-spans'])
    18 
    +test('WExpectedNoArgError', normal, compile_fail, ['-W='])
    18 19 
     test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret'])
    19 20 
     test('Colour', normal, compile_fail, ['-fdiagnostics-color=always'])
    20 21 
     test('T20263', normal, compile_fail, ['-Wunicode-bidirectional-format-characters -Werror'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/7d4707a9e4c2c2038f2b0981e72882991e00c275...94826f172cdf346491c288c25e9ce4b8198a9e1d at 1790021310