Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 81ae48b5 by ARATA Mizuki at 2026-09-21T16:08:19-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - b70eb2c5 by Wolfgang Jeltsch at 2026-09-21T16:08:20-04:00 Improve the `mhu-closure` makefile - - - - - cbba15de by Wolfgang Jeltsch at 2026-09-21T16:08:20-04:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - 94826f17 by Wolfgang Jeltsch at 2026-09-21T16:08:20-04:00 Improve the definition of the home unit closure property - - - - - 30 changed files: - + changelog.d/25763-cmdline-opt - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Env.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T Changes: ===================================== changelog.d/25763-cmdline-opt ===================================== @@ -0,0 +1,19 @@ +section: compiler +synopsis: Speed up command line parser with a trie map +description: + Parsing flags is now faster when there are many flags to parse. + + There is a new trie implementation with String keys in ``GHC.Data.StringTrie``. + + Added a new abstract type ``FlagSpecTrie`` to represent tries of flags. + + ``GHC.Driver.Session`` gets ``flagsDynamic`` removed and ``flagsDynamicTrie`` + added with type ``FlagSpecTrie``. ``processCmdLineP`` and ``parseDynamicFlagsFull`` + now have a ``FlagSpecTrie`` parameter instead of a list. + + ``GHC.Driver.Session.Mode`` gets a value ``mode_flags_trie`` of type ``FlagSpecTrie``. + + ``GHC.Driver.CmdLine.processArgs`` now gets a ``FlagSpecTrie`` argument instead + of a list. +mrs: !16392 +issues: #25763 ===================================== compiler/GHC/Data/StringTrie.hs ===================================== @@ -0,0 +1,148 @@ +module GHC.Data.StringTrie + ( StringTrie(..) + , empty + , insert + , fromList + , fromListWithSparseness + , lookup + ) where + +import GHC.Prelude hiding (lookup) + +import Data.Array (Array, accumArray, assocs) +import Data.Maybe (fromMaybe) +import qualified Data.IntMap.Lazy as M + +-- | A trie mapping strings to values of type @a@. +-- +-- See #25763 and Note [Optimising the processing of command-line arguments] +-- in "GHC.Driver.Session". +data StringTrie a + = -- | A value and other children under the same path. + -- + -- The 'IntMap' can be empty. + STNode a (M.IntMap (StringTrie a)) + -- | There is no value at this path, but there are children under it + -- + -- The 'IntMap' must be non-empty, so 'STEmpty' remains the only way to + -- represent a trie with no values. + | STFork (M.IntMap (StringTrie a)) + -- | A trie with no values + | STEmpty + deriving (Eq, Show) + +-- | There are no key-value pairs in this trie. +empty :: StringTrie a +empty = STEmpty + +-- | Inserts a key-value pair into the trie. When a value for the key is already +-- present, the new value replaces the old one. +insert :: forall a. String -> a -> StringTrie a -> StringTrie a +insert k0 v = go k0 + where + go :: String -> StringTrie a -> StringTrie a + go (x:xs) STEmpty = STFork $ M.singleton (fromEnum x) (go xs STEmpty) + go "" STEmpty = STNode v M.empty + go "" (STFork children) = STNode v children + go (x:xs) (STFork children) = + STFork (M.insert (fromEnum x) child children) + where + child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children) + + go "" (STNode _ children) = STNode v children + go (x:xs) (STNode vs children) = + STNode vs (M.insert (fromEnum x) child children) + where + child = go xs (fromMaybe empty $ M.lookup (fromEnum x) children) + +-- | Returns the values associated with prefixes of a query string as well as +-- the non-matching suffix. The matches are returned ordered by suffix length. +-- +-- Examples: +-- +-- > lookup "abc" (fromList [("ab", 2), ("abc", 3), ("b", 4)]) == [(3, ""), (2, "c")] +-- > lookup "abc" (fromList [("ab", 2), ("ab", 3)]) == [(3, "c")] +-- > lookup "ba" (fromList [("ab", 2), ("abc", 3)]) == [] +-- +-- More formally: +-- +-- @(v, suffix)@ is in @lookup queryString t@ iff there is a string @k@ such that +-- * @(k, v)@ is in @t@, and +-- * @k ++ suffix == queryString@. +lookup + :: String + -> StringTrie a + -> [(a, String)] +lookup = go [] + where + go :: [(a, String)] -> String -> StringTrie a -> [(a, String)] + -- + -- In @lookup queryString t@ and @go acc unmatchedSuffix t'@, + -- + -- unmatchedSuffix is a suffix of queryString, and t' is the subtrie + -- of t at path @queryString - unmatchedSuffix@. + -- + -- (v, suffix) is in acc iff there is a k such that + -- * (k, v) is in t, and + -- * @k ++ suffix == queryString@, and + -- * @unmatchedSuffix /= suffix@. + go acc [] (STNode v _) = (v, "") : acc + go acc [] (STFork _) = acc + go acc _ STEmpty = acc + go acc unmatchedSuffix@(c:rest) (STNode v children) = + let acc' = (v, unmatchedSuffix) : acc + in maybe acc' (go acc' rest) (M.lookup (fromEnum c) children) + go acc (c:rest) (STFork children) = + maybe acc (go acc rest) (M.lookup (fromEnum c) children) + +-- | Constructs a trie from a list of key-value pairs. +-- +-- Later entries in the list will overwrite earlier ones with the same key. +-- +-- Equivalent to @foldl (\t (k, v) -> insert k v t) empty@, but lazier: the +-- subtrie for each first character is only built when demanded. +fromList :: [(String, a)] -> StringTrie a +fromList = fromListWithSparseness 32 + +-- | Like 'fromList', but allows the caller to specify a threshold for when to use +-- an array to sort the keys. +fromListWithSparseness :: Int -> [(String, a)] -> StringTrie a +fromListWithSparseness sparseness = go + where + go [] = STEmpty + go xs = + let revxs = reverse xs + valuesWithEmptyKeys = filter (null . fst) revxs + children = M.map go (headBuckets sparseness revxs) + in case valuesWithEmptyKeys of + (_, v) : _ -> STNode v children + _ -> STFork children + + -- Group the entries with a non-empty key by their first character (in reverse order). + -- + -- Discards entries with an empty key. Uses an array to sort the entries, unless the + -- entries are too sparse. + headBuckets :: Int -> [(String, a)] -> M.IntMap [(String, a)] + headBuckets sparseness kvs + -- Entries are too sparse if they are too few or if they span too large a range + -- of characters. + | null (drop sparseness kvs) || any non_ascii kvs + = M.fromListWith (++) [ (fromEnum c, [(cs, v)]) | (c:cs, v) <- kvs ] + | otherwise + = M.fromDistinctAscList + [ (i, group) | (i, group) <- assocs (bucketsArr kvs), not (null group) ] + + -- @(k, v)@ is in @bucketsArr kvs ! i@ iff @(tail k, v)@ is in @kvs@ and + -- @fromEnum (head k) == i@. + -- + -- Note: Discard entries with an empty key. + bucketsArr :: [(String, a)] -> Array Int [(String, a)] + bucketsArr kvs = + accumArray + (flip (:)) + [] + (0, 0x7f) + [ (fromEnum c, (cs, v)) | (c:cs, v) <- kvs ] + + non_ascii (c:_, _) = fromEnum c > 0x7f + non_ascii ([], _) = False ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -3,6 +3,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- -- | ===================================== compiler/GHC/Data/Word64Set/Internal.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} +-- Speeds up otherwise unoptimized ghcs by 5-25% (#27814) +{-# OPTIONS_GHC -O2 #-} ----------------------------------------------------------------------------- -- | ===================================== compiler/GHC/Driver/CmdLine.hs ===================================== @@ -1,8 +1,9 @@ +{-# LANGUAGE BangPatterns #-} ------------------------------------------------------------------------------- -- -- | Command-line parser -- --- This is an abstract command-line parser used by DynFlags. +-- This is a command-line parser used by DynFlags. -- -- (c) The University of Glasgow 2005 -- @@ -10,13 +11,26 @@ module GHC.Driver.CmdLine ( - processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..), - Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag, - errorsToGhcException, + processArgs, + + -- ** Flags + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + OptKind(..), GhcFlagMode(..), + + -- ** EwM monad + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, Err(..), Warn, warnsToMessages, - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM + -- ** FlagSpecTrie + FlagSpecTrie, mkFlagSpecTrie, extendFlagSpecTrie, + + -- ** State + CmdLineP(..), runCmdLineP, + getCmdLineState, putCmdLineState, + + -- ** Utils + parseResponseFile, errorsToGhcException ) where import GHC.Prelude @@ -24,6 +38,7 @@ import GHC.Prelude import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Bag +import qualified GHC.Data.StringTrie as StringTrie import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Error @@ -31,14 +46,16 @@ import GHC.Driver.Errors.Types import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage import GHC.Utils.Outputable (text) -import Data.Function -import Data.List (sortBy, intercalate, stripPrefix) +import Data.List (intercalate) import Data.Word import GHC.ResponseFile import Control.Exception (IOException, catch) import Control.Monad (ap) import Control.Monad.IO.Class +import Control.Monad.Trans.State (StateT) +import qualified Control.Monad.Trans.State as State +import Data.Functor.Identity (runIdentity) -------------------------------------------------------- -- The Flag and OptKind types @@ -62,24 +79,6 @@ defGhciFlag name optKind = Flag name optKind OnlyGhci defHiddenFlag :: String -> OptKind m -> Flag m defHiddenFlag name optKind = Flag name optKind HiddenFlag -hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n -hoistFlag f (Flag a b c) = Flag a (go b) c - where - go (NoArg k) = NoArg (go2 k) - go (HasArg k) = HasArg (\s -> go2 (k s)) - go (SepArg k) = SepArg (\s -> go2 (k s)) - go (Prefix k) = Prefix (\s -> go2 (k s)) - go (OptPrefix k) = OptPrefix (\s -> go2 (k s)) - go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n)) - go (IntSuffix k) = IntSuffix (\n -> go2 (k n)) - go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s)) - go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s)) - go (PassFlag k) = PassFlag (\s -> go2 (k s)) - go (AnySuffix k) = AnySuffix (\s -> go2 (k s)) - - go2 :: EwM m a -> EwM n a - go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws) - -- | GHC flag modes describing when a flag has an effect. data GhcFlagMode = OnlyGhc -- ^ The flag only affects the non-interactive GHC @@ -159,6 +158,9 @@ getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +hoistEwM :: (forall a. m a -> n a) -> EwM m b -> EwM n b +hoistEwM f (EwM g) = EwM $ \loc es ws -> f (g loc es ws) + warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage warnsToMessages diag_opts = foldr (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws) @@ -168,20 +170,70 @@ warnsToMessages diag_opts = foldr -- Processing arguments -------------------------------------------------------- -processArgs :: Monad m - => [Flag m] -- ^ cmdline parser spec - -> [Located String] -- ^ args - -> (FilePath -> EwM m [Located String]) -- ^ response file handler - -> m ( [Located String], -- spare args +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) + +instance Monad (CmdLineP s) where + CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) + return = pure + +instance Applicative (CmdLineP s) where + pure x = CmdLineP (pure x) + (<*>) = ap + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP State.get + +putCmdLineState :: s -> CmdLineP s () +putCmdLineState x = CmdLineP (State.put x) + +runCmdLineP :: CmdLineP s a -> s -> (a, s) +runCmdLineP (CmdLineP k) s0 = runIdentity $ State.runStateT k s0 + +-- | Flag specifications as a trie map +-- +-- No two flags with the same 'flagName' are allowed. +-- +-- See Note [Optimising the processing of command-line arguments] +-- in GHC.Driver.Session. +newtype FlagSpecTrie s = + -- | The key of each 'Flag' @f@ is @flagName f@. + FlagSpecTrie { unFlagSpecTrie :: StringTrie.StringTrie (Flag (CmdLineP s)) } + +-- | Construct a 'FlagSpecTrie' from a list of flags. +-- +-- Precondition: No two flags in the list have the same flag name. +mkFlagSpecTrie :: [Flag (CmdLineP s)] -> FlagSpecTrie s +mkFlagSpecTrie flags = + FlagSpecTrie $ StringTrie.fromList [ (flagName f, f) | !f <- flags ] +{-# INLINE mkFlagSpecTrie #-} + +-- | Add flags to an existing 'FlagSpecTrie'. +-- +-- Precondition: No two flags in the trie plus the list have the same flag name. +extendFlagSpecTrie :: FlagSpecTrie s -> [Flag (CmdLineP s)] -> FlagSpecTrie s +extendFlagSpecTrie (FlagSpecTrie t) flags = + FlagSpecTrie $ foldl' (\acc f -> StringTrie.insert (flagName f) f acc) t flags +{-# INLINE extendFlagSpecTrie #-} + +processArgs :: forall s m. Monad m + => FlagSpecTrie s -- ^ cmdline parser spec + -> [Located String] -- ^ args + -> (FilePath -> EwM (StateT s m) [Located String]) -- ^ response file handler + -> StateT s m + ( [Located String], -- spare args [Err], -- errors Warns ) -- warnings processArgs spec args handleRespFile = do (errs, warns, spare) <- runEwM action return (spare, bagToList errs, warns) where + getCmdLineP :: CmdLineP s a -> StateT s m a + getCmdLineP (CmdLineP k) = k + action = process args [] - -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process :: [Located String] -> [Located String] -> EwM (StateT s m) [Located String] process [] spare = return (reverse spare) process (L _ ('@' : resp_file) : args) spare = do @@ -189,7 +241,7 @@ processArgs spec args handleRespFile = do process (resp_args ++ args) spare process (locArg@(L _ ('-' : arg)) : args) spare = - case findArg spec arg of + case findArg (unFlagSpecTrie spec) arg of Just (rest, opt_kind) -> case processOneArg opt_kind rest arg args of Left err -> @@ -198,7 +250,7 @@ processArgs spec args handleRespFile = do Right (action,rest) -> let b = process rest spare - in (setArg locArg $ action) >> b + in setArg locArg (hoistEwM getCmdLineP action) >> b Nothing -> process args (locArg : spare) @@ -246,31 +298,38 @@ processOneArg opt_kind rest arg args OptPrefix f -> Right (f rest_no_eq, args) AnySuffix f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) -findArg spec arg = - case sortBy (compare `on` (length . fst)) -- prefer longest matching flag - [ (removeSpaces rest, optKind) - | flag <- spec, - let optKind = flagOptKind flag, - Just rest <- [stripPrefix (flagName flag) arg], - arg_ok optKind rest arg ] - of - [] -> Nothing - (one:_) -> Just one - -arg_ok :: OptKind t -> [Char] -> String -> Bool -arg_ok (NoArg _) rest _ = null rest -arg_ok (HasArg _) _ _ = True -arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t - -- to improve error message (#12625) -arg_ok (OptIntSuffix _) _ _ = True -arg_ok (IntSuffix _) _ _ = True -arg_ok (Word64Suffix _) _ _ = True -arg_ok (FloatSuffix _) _ _ = True -arg_ok (OptPrefix _) _ _ = True -arg_ok (PassFlag _) rest _ = null rest -arg_ok (AnySuffix _) _ _ = True +-- | Find a flag in the trie whose name is a prefix of the given string. +-- +-- The unmatched suffix of the string is returned along with the 'OptKind'. +-- +-- A flag is only returned if the suffix is valid for the 'OptKind' of the flag. +-- For example, a flag with 'NoArg' will only be returned if the suffix is +-- empty. More concretely, @-Wallx@ will produce an invalid suffix @"x"@ since +-- @-Wall@ has @OptKind@ 'NoArg'. +-- +-- If more than one flag name is a prefix of the string, the longest match with +-- a valid suffix is returned. +findArg :: StringTrie.StringTrie (Flag m) -> String -> Maybe (String, OptKind m) +findArg trie arg = + case filter (uncurry valid_flag_suffix) $ StringTrie.lookup arg trie of + [] -> Nothing + (flag, rest) : _ -> Just (removeSpaces rest, flagOptKind flag) + where + valid_flag_suffix :: Flag m -> String -> Bool + valid_flag_suffix flag rest = + case flagOptKind flag of + NoArg _ -> null rest + HasArg _ -> True + SepArg _ -> null rest + Prefix _ -> True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) + OptIntSuffix _ -> True + IntSuffix _ -> True + Word64Suffix _ -> True + FloatSuffix _ -> True + OptPrefix _ -> True + PassFlag _ -> null rest + AnySuffix _ -> True -- | Parse an Int -- ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -6,6 +6,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-invalid-haddock #-} + -- | See Note [The ModuleGraph] module GHC.Driver.Downsweep ( downsweep @@ -54,7 +56,6 @@ import GHC.Runtime.Context import Language.Haskell.Syntax.ImpExp import GHC.Types.UnresolvedImport -import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.Maybe as M @@ -71,12 +72,15 @@ import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants +import GHC.Utils.Monad (concatMapM) +import GHC.Utils.Monad.State.Strict import GHC.Types.Error import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc +import GHC.Types.Unique.Set import GHC.Types.Unique.Map import GHC.Types.PkgQual import GHC.Types.Basic @@ -91,9 +95,12 @@ import GHC.Unit.Module.Graph import GHC.Unit.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage +import GHC.Unit.External.Index (UnitAbiHash) import Data.Either ( partitionEithers, lefts ) +import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent.MVar @@ -101,7 +108,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe -import Data.List (partition) +import Data.List (sort, partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first, bimap) @@ -933,52 +940,175 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do -- * Check/validate properties and error out -------------------------------------------------------------------------------- --- | This function checks then important property that if both p and q are home units --- then any dependency of p, which transitively depends on q is also a home unit. +-- | Checks whether the given 'UnitEnv' has the closure property. -- --- See Note [Multiple Home Units], section 'Closure Property'. -checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] -checkHomeUnitsClosed ue - | Set.null bad_unit_ids = [] - | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] +-- See the section “Closure Property” in @Note [Multiple Home Units]@ for the +-- definition of the closure property and +-- @Note [Home unit closure property check]@ below for a discussion of the +-- algorithm used for this check, its justification, and a potential +-- alternative. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed unit_env + | null offenders = [] + | otherwise = [ + singleMessage $ + mkPlainErrorMsgEnvelope error_source_span $ + DriverHomePackagesNotClosed (sort offenders) + ] where - home_id_set = HUG.allUnits $ ue_home_unit_graph ue - bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") - downwards_closure :: Graph (Node UnitId UnitId) - downwards_closure = graphFromEdgedVerticesUniq graphNodes + -- | The 'UnitId' and 'HomeUnitEnv' of each home unit. + home_unit_data :: [(UnitId, HomeUnitEnv)] + home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env) + + -- | The 'UnitId's of all home units. + home_units :: UniqSet UnitId + home_units = mkUniqSet (map fst home_unit_data) + + -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is + -- offending exactly if /u/ is an external unit reachable from a home unit + -- and /v/ is a home unit. Each such dependency is represented in this list + -- by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/. + offenders :: [(UnitId, UnitId)] + offenders + = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) + emptyUniqMap + where - inverse_closure = graphReachability $ transposeG downwards_closure + -- | Collects offending dependencies. + collect :: [UnitState] + -- ^ The 'UnitState's of the home units from which to traverse + -- the dependency graph. + -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)] + -- ^ A stateful computation that collects offending dependencies + -- that have not yet been found. It uses its state, which is an + -- efficent representation of a set of 'GlobalUnitKey's, to + -- keep track of which units have already been considered as + -- sources of offending dependencies. + collect = concatMapM $ \ unit_state -> + collect_for_home_unit + (unitInfoMap unit_state) + (map (toUnitId . fst) $ explicitUnits $ unit_state) + where - upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + -- | Collects offending dependencies that are reachable from a particular + -- home unit. + collect_for_home_unit + :: UnitInfoMap + -- ^ The 'UnitInfoMap' of the home unit. + -> [UnitId] + -- ^ The 'UnitId's of the units from which to traverse the dependency + -- graph. + -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)] + -- ^ A stateful computation that collects offending dependencies that + -- have not yet been found. It uses its state, which is an efficent + -- representation of a set of 'GlobalUnitKey's, to keep track of + -- which units have already been considered as sources of offending + -- dependencies. + collect_for_home_unit _ [] + = return [] + collect_for_home_unit unit_info_map (current_unit : remaining_units) = do + let + + -- | The 'UnitInfo' of the current unit. + unit_info :: UnitInfo + unit_info + = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $ + lookupUniqMap unit_info_map current_unit + where + + -- | The message that says that a unit was not found. + unit_not_found_msg :: String + unit_not_found_msg = "Unit not found during closure property check" + + -- | The ABI hash of the current unit. + unit_abi_hash :: UnitAbiHash + unit_abi_hash = unitAbiHash unit_info + + has_been_processed <- gets $ maybe False (Set.member unit_abi_hash) . + (`lookupUniqMap` current_unit) + if has_been_processed + then collect_for_home_unit unit_info_map remaining_units + else do + modify $ \ processed -> addToUniqMap_C Set.union + processed + current_unit + (Set.singleton unit_abi_hash) + let + + -- | The 'UnitId's of the units that the current unit depends on. + needed_units :: [UnitId] + needed_units = unitDepends unit_info + + -- | The offending dependencies of the current unit. + current_offenders :: [(UnitId, UnitId)] + current_offenders + | current_unit `elementOfUniqSet` home_units + = [] + | otherwise + = map ((,) current_unit) $ + nonDetEltsUniqSet $ + mkUniqSet needed_units `intersectUniqSets` home_units + + remaining_offenders <- collect_for_home_unit unit_info_map $ + needed_units ++ remaining_units + return $ current_offenders ++ remaining_offenders + + -- | A fake source span used for reporting violations of the closure property. + error_source_span :: SrcSpan + error_source_span = mkGeneralSrcSpan (fsLit "<command line>") - all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) - all_unit_direct_deps - = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C Set.union - (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) - rest - where - external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) - this_units = homeUnitEnv_units this_uis - this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go Set.empty home_id_set - where - go done todo - = case Set.minView todo of - Nothing -> [] - Just (uid, todo') - | Set.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends Set.\\ done) `Set.union` todo' - in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' +{- + +Note [Home unit closure property check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Per the definition in Note [Multiple Home Units], a unit environment has the +closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the +dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external +unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for +so-called offending dependencies, which are dependencies /e/ → /h/₂ that are +part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a +viable approach, consider the following: + + * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂. + + * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′, + where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be + constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂ + and as /e/′ the, necessarily external, unit preceding it. + +Concretely, the algorithm picks one home unit after the other, determines what +units it directly depends on, and, starting from them, follows unit dependencies +to search for offending dependencies. It does not follow dependencies that have +been followed before, possibly when processing another home unit. To achieve +this, the algorithm tracks, across home units, from which units it has already +followed dependencies. For this tracking, it identifies each unit by a 'UnitId' +and an ABI hash. Using only a 'UnitId' would not work, because 'UnitId's are not +always globally unique. Also using only an ABI hash is not an option, because an +ABI hash is not necessarily an ABI hash: it can also be the string @"inline"@. + +The correctness of this algorithm rests on the, likely correct, assumption that, +among the units mentioned in the 'UnitState' of a particular home unit, any unit +can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only +occur across the 'UnitState's of different home units. + +An alternative approach to finding offending dependencies would be to follow +dependencies starting from all units that /any/ home unit directly depends on +instead of considering the different home units separately. A corresponding +algorithm could in principle find the dependencies of a particular unit +independently of any home unit by fetching the 'UnitInfo' of that unit from the +'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not +only the 'UnitId' but also the ABI hash of the unit in question. Therefore, +whenever following a dependency of a unit /u/ on a unit /v/, it would have to +determine the ABI hash of /v/, so that it could later look up /v/’s +dependencies. The ABI hashes of all units that /u/ depends on should be +available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the +time of writing, 'unitAbiDepends' never contained anything other than the empty +list during GHC test runs, which indicated that this alternative solution was +impossible to realize. + +-} -------------------------------------------------------------------------------- -- * Enable Code Gen for Template Haskell @@ -1763,7 +1893,7 @@ data NodeRes v -- -- See also Note [Downsweep Control Flow and Caching] dfsBuild :: (Ord k, Monad m) - => Maybe (Map.Map k (NodeRes v)) + => Maybe (Map k (NodeRes v)) -- ^ Base map, existing results. We won't re-expand any of the nodes -- already present in this map. -> [n] @@ -1773,7 +1903,7 @@ dfsBuild :: (Ord k, Monad m) -> (n -> m (NodeRes (v,[n]))) -- ^ Expand this node into its payload result and into the list of -- children nodes to visit next. - -> m (Map.Map k (NodeRes v)) + -> m (Map k (NodeRes v)) -- ^ The result accumulates the payload of expanding the root nodes -- and all nodes transitively reachable from those roots. 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 "but no output will be generated.") $$ (text "There is no module named" <+> quotes (ppr mod_name) <> text ".")) - DriverHomePackagesNotClosed needed_unit_ids - -> mkSimpleDecorated $ vcat ([text "Home units are not closed." - , text "It is necessary to also load the following units:" ] - ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverHomePackagesNotClosed offending_dependencies + -> mkSimpleDecorated $ + hang (text "Some units are not loaded but depend on loaded units.") + 4 + (vcat (map pprDependency offending_dependencies)) + where + + pprDependency :: (UnitId, UnitId) -> SDoc + pprDependency (external_unit, home_unit) + = ppr external_unit <+> arrow <+> ppr home_unit + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason DriverInconsistentDynFlags msg ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -369,7 +369,7 @@ data DriverMessage where DriverRedirectedNoMain :: !ModuleName -> DriverMessage - DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage DriverInterfaceError :: !IfaceMessage -> DriverMessage ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -181,7 +181,8 @@ module GHC.Driver.Session ( -- ** Available DynFlags allNonDeprecatedFlags, flagsAll, - flagsDynamic, + flagsAllTrie, + flagsDynamicTrie, flagsPackage, flagsForCompletion, @@ -294,8 +295,7 @@ import System.Semaphore ( getSemaphoreProtocolVersion, semaphoreVersion ) import Data.IORef import Control.Arrow ((&&&)) import Control.Monad -import Control.Monad.Trans.State as State -import Data.Functor.Identity +import Control.Monad.Trans.State (runStateT) import Data.Ord import Data.Char @@ -391,6 +391,37 @@ import Language.Haskell.Syntax.Text -- -- See #4437 and #8176. +-- Note [Optimising the processing of command-line arguments] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For each command line argument we need to search all the possible flag names to +-- find the correct command-line argument processor (of type `CmdLineP DynFlags`) +-- to complete parsing of the argument and modify the `DynFlags`. +-- +-- GHC has a LOT of flags, and occasionally, users give a LOT of command line +-- arguments. So in some cases it pays to optimize the search for a command-line +-- argument processor (#25763). +-- +-- An additional complication is that flag specs need to be looked up with a +-- string that may contain the flag key as a prefix. +-- +-- In general, the `=` sign is optional, and anything after the name of the flag, +-- if it doesn't start with `=`, is considered the argument. E.g. +-- `-odirsome/path`, or `-pgmFprogram`, or `-package-dbDiff`, or `-optc-DFOO`, +-- or `-Isome/path`, or `-fpluginLiquidHaskell`, or `-fplugin-optLiquidHaskell:--save`. +-- +-- To achieve this: +-- +-- * We build global lookup tables +-- * GHC.Driver.Session.flagsAllTrie :: FlagSpecTrie DynFlags +-- * GHC.Driver.Session.flagsDynamicTrie :: FlagSpecTrie DynFlags +-- * GHC.Driver.Session.Mode.mode_flags_trie :: FlagSpecTrie ModeMS +-- +-- These are implemented by a trie indexed by Strings, see GHC.Data.StringTrie. +-- +-- * As we process each command line argument, one by one, we +-- look up in the `FlagSpecTrie` to find which processor +-- to use. See `GHC.Driver.CmdLine.processArgs`. + -- ----------------------------------------------------------------------------- -- DynFlags @@ -837,7 +868,7 @@ parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAllTrie True -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags @@ -847,42 +878,19 @@ parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False - -newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) - deriving (Functor) - -instance Monad (CmdLineP s) where - CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) - return = pure - -instance Applicative (CmdLineP s) where - pure x = CmdLineP (pure x) - (<*>) = ap - -getCmdLineState :: CmdLineP s s -getCmdLineState = CmdLineP State.get - -putCmdLineState :: s -> CmdLineP s () -putCmdLineState x = CmdLineP (State.put x) - -runCmdLineP :: CmdLineP s a -> s -> (a, s) -runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0 +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamicTrie False -- | A helper to parse a set of flags from a list of command-line arguments, handling -- response files. processCmdLineP :: forall s m. MonadIO m - => [Flag (CmdLineP s)] -- ^ valid flags to match against + => FlagSpecTrie s -- ^ valid flags to match against -> s -- ^ current state -> [Located String] -- ^ arguments to parse -> m (([Located String], [Err], [Warn]), s) -- ^ (leftovers, errors, warnings) processCmdLineP activeFlags s0 args = - runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0 - where - getCmdLineP :: CmdLineP s a -> StateT s m a - getCmdLineP (CmdLineP k) = k + runStateT (processArgs activeFlags args parseResponseFile) s0 -- | Parses the dynamically set flags for GHC. This is the most general form of -- the dynamic flag parser that the other methods simply wrap. It allows @@ -890,7 +898,7 @@ processCmdLineP activeFlags s0 args = -- arguments from the command line or from a file pragma. parseDynamicFlagsFull :: forall m. MonadIO m - => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + => FlagSpecTrie DynFlags -- ^ valid flags to match against -> Bool -- ^ are the arguments from the command line? -> Logger -- ^ logger -> DynFlags -- ^ current dynamic flags @@ -1012,14 +1020,22 @@ allFlagsDeps keepDeprecated = [ '-':flagName flag flagsAll :: [Flag (CmdLineP DynFlags)] flagsAll = map snd flagsAllDeps +-- | Same as 'flagsAll' but in trie form for fast lookup. +-- +-- See Note [Optimising the processing of command-line arguments] +flagsAllTrie :: FlagSpecTrie DynFlags +flagsAllTrie = extendFlagSpecTrie flagsDynamicTrie $ map snd package_flags_deps + -- All dynamic flags present in GHC with deprecation information. flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] flagsAllDeps = package_flags_deps ++ dynamic_flags_deps -- All dynamic flags, minus package flags, present in GHC. -flagsDynamic :: [Flag (CmdLineP DynFlags)] -flagsDynamic = map snd dynamic_flags_deps +-- +-- See Note [Optimising the processing of command-line arguments]. +flagsDynamicTrie :: FlagSpecTrie DynFlags +flagsDynamicTrie = mkFlagSpecTrie $ map snd dynamic_flags_deps -- ALl package flags present in GHC. flagsPackage :: [Flag (CmdLineP DynFlags)] @@ -2013,8 +2029,7 @@ dynamic_flags_deps = [ ++ ------ Warning flags ------------------------------------------------- - [ make_ord_flag defFlag "W" (NoArg (setWarningGroup W_extra)) - , make_ord_flag defFlag "Werror" + [ make_ord_flag defFlag "Werror" (NoArg (do { setGeneralFlag Opt_WarnIsError ; setFatalWarningGroup W_everything })) , make_ord_flag defFlag "Wwarn" @@ -2040,7 +2055,7 @@ dynamic_flags_deps = [ , (NotDeprecated, customOrUnrecognisedWarning "Werror=" setCustomWErrorFlag) , (NotDeprecated, customOrUnrecognisedWarning "Wwarn=" unSetCustomFatalWarningFlag) , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag) - , (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag) + , flagW , (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag) , (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag) ] @@ -2076,19 +2091,35 @@ warningControls set unset set_werror unset_fatal xs = ++ map (mkFlag turnOn "fwarn-" set . hideFlag) xs ++ map (mkFlag turnOff "fno-warn-" unset . hideFlag) xs +-- | The "W" flag is special in that it can mean enable extra warnings ('W_extra') +-- or enable a custom warning, if the suffix is non-empty. +flagW :: (Deprecation, Flag (CmdLineP DynFlags)) +flagW = + make_ord_flag defFlag "W" $ OptPrefix $ \suffix -> + if null suffix then do + -- Reject "-W=" instead of taking it to mean "-W". + arg <- getArg + if arg == "-W" then + setWarningGroup W_extra + else + addErr ("missing argument for flag: " ++ arg) + else + customOrUnrecognisedWarningAction "W" setCustomWarningFlag suffix + -- | This is where we handle unrecognised warning flags. If the flag is valid as -- an extended warning category, we call the supplied action. Otherwise, issue a -- warning if -Wunrecognised-warning-flags is set. See #11429 for context. -- See Note [Warning categories] in GHC.Unit.Module.Warnings. customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags) -customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) - where - action :: String -> DynP () - action flag +customOrUnrecognisedWarning prefix custom = + defHiddenFlag prefix $ Prefix $ customOrUnrecognisedWarningAction prefix custom + +customOrUnrecognisedWarningAction :: String -> (WarningCategory -> DynP ()) -> String -> DynP () +customOrUnrecognisedWarningAction prefix custom flag | validWarningCategory cat = custom cat | otherwise = unrecognised flag - where - cat = mkWarningCategory (packHText flag) + where + cat = mkWarningCategory (packHText flag) unrecognised flag = do -- #23402 and #12056 ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -443,13 +443,14 @@ The flow: Closure Property ---------------- -You must perform a clean cut of the dependency graph. +A unit environment must have the closure property: -> Any dependency which is not a home unit must not (transitively) depend on a home unit. + No used external unit depends on a home unit. -For example, if you have three packages p, q and r, then if p depends on q which -depends on r then it is illegal to load both p and r as home units but not q, -because q is a dependency of the home unit p which depends on another home unit r. +More concretely, a unit environment has the closure property exactly if no home +unit directly or indirectly depends on an external unit that directly or +indirectly depends on a home unit. 'GHC.Driver.Downsweep.checkHomeUnitsClosed' +checks whether a given unit environment indeed has this property. Offsetting Paths ---------------- ===================================== compiler/ghc.cabal.in ===================================== @@ -474,6 +474,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.StringTrie GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== ghc/GHC/Driver/Session/Mode.hs ===================================== @@ -180,7 +180,7 @@ parseModeFlags :: [Located String] [Warn]) parseModeFlags args = do ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <- - processCmdLineP mode_flags (Nothing, [], [], []) args + processCmdLineP mode_flags_trie (Nothing, [], [], []) args let mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m @@ -191,10 +191,14 @@ parseModeFlags args = do return (mode, units, flags' ++ leftover, warns) -type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String]) +type ModeMS = (Maybe (Mode, String), [String], [String], [Located String]) +type ModeM = CmdLineP ModeMS -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. +mode_flags_trie :: FlagSpecTrie ModeMS +mode_flags_trie = mkFlagSpecTrie mode_flags + mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- ===================================== rts/include/stg/Prim.h ===================================== @@ -59,16 +59,16 @@ StgWord hs_xchg32(StgWord x, StgWord val); StgWord64 hs_xchg64(StgWord x, StgWord64 val); /* rts/prim/bswap.c */ -StgWord16 hs_bswap16(StgWord16 x); -StgWord32 hs_bswap32(StgWord32 x); +StgWord hs_bswap16(StgWord x); +StgWord hs_bswap32(StgWord x); StgWord64 hs_bswap64(StgWord64 x); /* rts/prim/bitrev.c This was done as part of issue #16164. See Note [Bit reversal primop] for more details about the implementation.*/ StgWord hs_bitrev8(StgWord x); -StgWord16 hs_bitrev16(StgWord16 x); -StgWord32 hs_bitrev32(StgWord32 x); +StgWord hs_bitrev16(StgWord x); +StgWord hs_bitrev32(StgWord x); StgWord64 hs_bitrev64(StgWord64 x); /* rts/prim/longlong.c */ ===================================== rts/prim/bitrev.c ===================================== @@ -36,8 +36,8 @@ hs_bitrev8(StgWord x) return x; } -StgWord16 -hs_bitrev16(StgWord16 x) +StgWord +hs_bitrev16(StgWord x) { x = ((x >> 1) & 0x5555) | ((x & 0x5555) << 1 ); x = ((x >> 2) & 0x3333) | ((x & 0x3333) << 2 ); @@ -46,14 +46,14 @@ hs_bitrev16(StgWord16 x) return x; } -StgWord32 -hs_bitrev32(StgWord32 x) +StgWord +hs_bitrev32(StgWord x) { - x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 ); - x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 ); - x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 ); - x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 ); - x = ( x >> 16 ) | ( x << 16 ); + x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 ); + x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 ); + x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 ); + x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 ); + x = ((x >> 16) & 0x0000FFFF) | ((x & 0x0000FFFF) << 16); return x; } ===================================== rts/prim/bswap.c ===================================== @@ -1,16 +1,18 @@ #include "Rts.h" -StgWord16 -hs_bswap16(StgWord16 x) +StgWord +hs_bswap16(StgWord x) { - return ((x >> 8) | (x << 8)); + x = (StgWord16)x; + return (StgWord16)((x >> 8) | (x << 8)); } -StgWord32 -hs_bswap32(StgWord32 x) +StgWord +hs_bswap32(StgWord x) { - return ((x >> 24) | ((x >> 8) & 0xff00) | - (x << 24) | ((x & 0xff00) << 8)); + x = (StgWord32)x; + return (StgWord32)((x >> 24) | ((x >> 8) & 0xff00) | + (x << 24) | ((x & 0xff00) << 8)); } StgWord64 ===================================== testsuite/tests/MiniQuickCheck.hs ===================================== @@ -28,6 +28,7 @@ module MiniQuickCheck , propertyCompare , propertyAnd , propertyTrue + , propertyEqWithContext , getCheck -- * QuickCheck test tree @@ -51,11 +52,15 @@ module MiniQuickCheck , nonZero , BoundedShiftAmount(..) , BoundedBy(..) + , BoundedList(..) + , BoundedChar(..) ) where -- base import Control.Exception ( SomeException, displayException, evaluate, try ) +import Control.Monad + ( replicateM ) import Control.Monad.IO.Class ( liftIO ) import Data.Bits @@ -64,8 +69,6 @@ import Data.Bits ) import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.IORef - ( newIORef, atomicModifyIORef' ) import Data.Kind ( Type ) import Data.List @@ -84,6 +87,8 @@ import System.Exit ( die, exitFailure ) import Text.Read ( readMaybe ) +import System.IO.Unsafe + ( unsafePerformIO ) -- transformers import Control.Monad.Trans.Reader @@ -141,6 +146,15 @@ propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b) (===) = propertyCompare "==" (==) infix 4 === +-- | Prints the given message when the two values are not equal. +propertyEqWithContext :: (Eq a, Show a) => String -> a -> a -> PropertyCheck +propertyEqWithContext msg = + propertyCompare + (intercalate "\n" $ + "is not the expected" : map (" " ++) (lines msg ++ ["expected:"]) + ) + (==) + -- | Conjunction of two property checks. propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck propertyAnd = PropertyAnd @@ -424,3 +438,28 @@ instance where n :: a n = fromIntegral $ natVal @n Proxy + +type BoundedList :: Nat -> Type -> Type +newtype BoundedList n a = BoundedList { getBoundedList :: [a] } + deriving (Eq, Ord, Show) + +instance + forall n a + . ( KnownNat n, Arbitrary a ) + => Arbitrary ( BoundedList n a ) where + arbitrary = do + x <- arbitrary + let n = (x :: Word64) `mod` fromIntegral (natVal @n Proxy + 1) + BoundedList <$> replicateM (fromIntegral n) arbitrary + +instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where + arbitrary = (,) <$> arbitrary <*> arbitrary + +type BoundedChar :: Nat -> Type +newtype BoundedChar n = BoundedChar { getBoundedChar :: Char } + deriving (Eq, Ord, Show) + +instance KnownNat n => Arbitrary (BoundedChar n) where + arbitrary = do + x <- getBoundedBy @_ @n <$> arbitrary + pure $ BoundedChar (['a'..] !! abs x) ===================================== testsuite/tests/driver/all.T ===================================== @@ -99,6 +99,8 @@ test('driver200', [extra_files(['A200.hs', 'B200/', 'D200.hs'])], makefile_test, test('T2566', normalise_fun(normalise_errmsg), makefile_test, []) +test('stringtrie', [mini_quickcheck], compile_and_run, ['-package ghc']) + test('pragma001', normal, compile, ['']) test('pragma002', normal, compile, ['']) ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile ===================================== @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk SETUP=../Setup -v0 +CONFIGURE=configure \ + $(CABAL_MINIMAL_BUILD) \ + --with-ghc='$(TEST_HC)' \ + --with-hc-pkg='$(GHC_PKG)' \ + --ghc-options='$(TEST_HC_OPTS)' \ + --package-db=../tmp.d +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp +ONLY_BASE=-hide-all-packages -package base -mhu-closure: clean - $(MAKE) -s --no-print-directory clean +mhu-closure: clean pkg-database + ! $(TEST_BUILD) -unit @unitP + ! $(TEST_BUILD) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) -unit @unitP -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitR1 + $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1 + +.PHONY: pkg-database +pkg-database: '$(GHC_PKG)' init tmp.d '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup - cd p && $(SETUP) clean - 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 + cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0 cd p && $(SETUP) build cd p && $(SETUP) register --inplace - 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 + cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0 cd q && $(SETUP) build cd q && $(SETUP) register --inplace - 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 + cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0 cd r && $(SETUP) build cd r && $(SETUP) register --inplace - # This should work - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR - # This should error with a closure message - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR - # This should work, even though r1 is not in the package db - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1 - # This should fail, even though r1 is not in the package db - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1 +.PHONY: clean +clean: + $(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o ifeq "$(CLEANUP)" "1" $(MAKE) -s --no-print-directory clean endif - -clean : - $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) - ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr ===================================== @@ -1,10 +1,28 @@ <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout ===================================== @@ -1,3 +1,6 @@ +[1 of 3] Compiling P[p-0.1.0.0] +[2 of 3] Compiling Q[q-0.1.0.0] +[3 of 3] Compiling R[r-0.1.0.0] [1 of 1] Compiling P [1 of 2] Compiling P[p-0.1.0.0] [2 of 2] Compiling Q[q-0.1.0.0] ===================================== testsuite/tests/driver/stringtrie.hs ===================================== @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +import Data.Bifunctor (first) +import Data.Coerce +import Data.Function (on) +import Data.List (nubBy, sortOn, stripPrefix) +import GHC.Data.StringTrie as StringTrie +import MiniQuickCheck + +main :: IO () +main = do + runTestsMain (Iterations 1000) tests + -- runTests (Iterations 100) 9856592474076851907 tests + +tests :: Test +tests = Group "StringTrie" + [ Property "lookup_after_insert" prop_lookup_after_insert + , Property "fromList == foldl (flip $ uncurry insert) empty" prop_fromList_foldl + ] + +type BString4 = BoundedList 4 (BoundedChar 4) + +-- | @lookup qs (insert k v t)@ returns the values of matching keys ordered by +-- suffix length. +prop_lookup_after_insert + -- | query string as a bounded list + :: BoundedList 6 (BoundedChar 3) + -- | length of the key to insert in @t@ + -> BoundedBy Int 3 + -- | value to insert in @t@ + -> BoundedBy Int 9 + -- | list of key-value pairs to build the trie @t@ + -> BoundedList 6 (BString4, Int `BoundedBy` 9) + -> PropertyCheck +prop_lookup_after_insert bqs i0 v0 bkvs = + let kvs = coerce bkvs :: [(String, Int)] + t = fromList kvs + qs = coerce @_ @String bqs + i = min (abs (getBoundedBy i0)) (length qs) + k = take i qs + v = getBoundedBy v0 + -- (v1, sfx1) pairs where (k1, v1) is in t and k1 is a prefix of qs + expected = + [ (v1, sfx1) + | kv@(k1, v1) <- nubBy ((==) `on` fst) $ (k, v) : reverse kvs + , Just sfx1 <- [stripPrefix k1 qs] + ] + in + propertyEqWithContext + (unlines + [ "k = " ++ show k + , "v = " ++ show v + , "qs = " ++ show qs + , "kvs = " ++ show kvs + ] + ) + (StringTrie.lookup qs (insert k v t)) + (sortOn (length . snd) expected) + +-- | @fromList xs == foldl (flip $ uncurry insert) empty xs@ +prop_fromList_foldl + -- | list of key-value pairs to build the trie @t@ + :: Int `BoundedBy` 7 + -> BoundedList 6 (BString4, Int `BoundedBy` 9) + -> PropertyCheck +prop_fromList_foldl (BoundedBy sparseness) bkvs = + let kvs = map (first shiftString) $ coerce bkvs :: [(String, Int)] + in propertyEqWithContext + (unlines ["kvs = " ++ show kvs]) + (fromListWithSparseness (sparseness - 1) kvs) + (foldl (flip $ uncurry insert) empty kvs) + where + -- Bring characters next to the end of the ASCII range to test the + -- array-based implementation of fromList. + shiftString = map shiftChar + shiftChar = charPlus (126 - fromEnum 'a') + charPlus x c = toEnum (x + fromEnum c) ===================================== testsuite/tests/driver/stringtrie.stdout ===================================== @@ -0,0 +1,5 @@ +Group StringTrie + Running lookup_after_insert + Passed 1000 iterations + Running fromList == foldl (flip $ uncurry insert) empty + Passed 1000 iterations ===================================== testsuite/tests/perf/compiler/T25763.stderr ===================================== @@ -0,0 +1 @@ +[1 of 1] Compiling Main ( t25763.hs, nothing ) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -874,6 +874,16 @@ test ('T24984', compile, ['-O']) +# Performance regression test for the parser of command line arguments +test( + 'T25763', + [ + collect_compiler_runtime(5), + pre_cmd(f'seq 400000 | sed "s/.*/-XCPP/" > t25763.txt && echo "main = pure ()" > t25763.hs'), + ], + multimod_compile, + ['t25763', '@t25763.txt -c -fno-code']) + test('interpreter_steplocal', [ collect_compiler_stats('bytes allocated', 5) ], ===================================== testsuite/tests/primops/should_run/T27299.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} +import GHC.Exts +import GHC.Word +import Numeric + +main :: IO () +main = do + putStrLn $ showHex (W# (bitReverse8# 0x55##)) "" + putStrLn $ showHex (W# (bitReverse8# 0xAA##)) "" + putStrLn $ showHex (W# (bitReverse16# 0x5555##)) "" + putStrLn $ showHex (W# (bitReverse16# 0xAAAA##)) "" + putStrLn $ showHex (W# (bitReverse32# 0x5555_5555##)) "" + putStrLn $ showHex (W# (bitReverse32# 0xAAAA_AAAA##)) "" + putStrLn $ showHex (W# (byteSwap16# 0xABCD##)) "" + putStrLn $ showHex (W# (byteSwap32# 0xABCD_EF12##)) "" + putStrLn $ showHex (W# (noinline bitReverse8# 0x55##)) "" + putStrLn $ showHex (W# (noinline bitReverse8# 0xAA##)) "" + putStrLn $ showHex (W# (noinline bitReverse16# 0x5555##)) "" + putStrLn $ showHex (W# (noinline bitReverse16# 0xAAAA##)) "" + putStrLn $ showHex (W# (noinline bitReverse32# 0x5555_5555##)) "" + putStrLn $ showHex (W# (noinline bitReverse32# 0xAAAA_AAAA##)) "" + putStrLn $ showHex (W# (noinline byteSwap16# 0xABCD##)) "" + putStrLn $ showHex (W# (noinline byteSwap32# 0xABCD_EF12##)) "" ===================================== testsuite/tests/primops/should_run/T27299.stdout ===================================== @@ -0,0 +1,16 @@ +aa +55 +aaaa +5555 +aaaaaaaa +55555555 +cdab +12efcdab +aa +55 +aaaa +5555 +aaaaaaaa +55555555 +cdab +12efcdab ===================================== testsuite/tests/primops/should_run/all.T ===================================== @@ -91,3 +91,4 @@ test('T24496' ] , compile_and_run, ['-O']) test('T6026', normal, compile_and_run, ['']) +test('T27299', normal, compile_and_run, ['']) ===================================== testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr ===================================== @@ -0,0 +1,2 @@ +ghc: on the commandline: missing argument for flag: -W= +Usage: For basic information, try the `--help' option. ===================================== testsuite/tests/warnings/should_fail/all.T ===================================== @@ -15,6 +15,7 @@ test('CaretDiagnostics1', [normalise_whitespace_fun(normalise_whitespace_carefully)], compile_fail, ['-fdiagnostics-show-caret -ferror-spans']) +test('WExpectedNoArgError', normal, compile_fail, ['-W=']) test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret']) test('Colour', normal, compile_fail, ['-fdiagnostics-color=always']) test('T20263', normal, compile_fail, ['-Wunicode-bidirectional-format-characters -Werror']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d4707a9e4c2c2038f2b0981e728829... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d4707a9e4c2c2038f2b0981e728829... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help