Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: aeeb4a20 by Matthew Pickering at 2026-01-30T11:42:47-05:00 determinism: Use deterministic map for Strings in TyLitMap When generating typeable evidence the types we need evidence for all cached in a TypeMap, the order terms are retrieved from a type map determines the order the bindings appear in the program. A TypeMap is quite diligent to use deterministic maps, apart from in the TyLitMap, which uses a UniqFM for storing strings, whose ordering depends on the Unique of the FastString. This can cause non-deterministic .hi and .o files. An unexpected side-effect is the error message but RecordDotSyntaxFail8 changing. I looked into this with Sam and this change caused the constraints to be solved in a different order which results in a slightly different error message. I have accepted the new test, since the output before was non-deterministic and the new output is consistent with the other messages in that file. Fixes #26846 - - - - - 9e4d70c2 by Andrew Lelechenko at 2026-01-30T11:43:29-05:00 Upgrade text submodule to 2.1.4 - - - - - c8f80cf2 by Simon Hengel at 2026-01-31T19:21:39+05:30 Update the documentation for MultiWayIf (fixes #25376) (so that it matches the implementation) - - - - - b1b02869 by Peter Trommler at 2026-01-31T18:19:32-05:00 hadrian: Fix dependency generation for assembler Assembler files allow # for comments unless in column 1. A modern cpp for C treats those a preprocessor directives. We tell gcc that a .S file is assembler with cpp and not C. Fixes #26819 - - - - - 10 changed files: - compiler/GHC/Core/Map/Type.hs - docs/users_guide/exts/multiway_if.rst - hadrian/src/Builder.hs - hadrian/src/Rules/Compile.hs - hadrian/src/Settings/Builders/Cc.hs - hadrian/src/Settings/Packages.hs - libraries/text - + testsuite/tests/ghc-api/TypeMapStringLiteral.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr Changes: ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM import GHC.Utils.Outputable import GHC.Utils.Panic @@ -365,14 +365,14 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a - , tlm_string :: UniqFM FastString a + , tlm_string :: UniqDFM FastString a , tlm_char :: Map.Map Char a } -- TODO(22292): derive instance Functor TyLitMap where fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM - { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + { tlm_number = Map.map f tn, tlm_string = mapUDFM f ts, tlm_char = Map.map f tc } instance TrieMap TyLitMap where type Key TyLitMap = TyLit @@ -384,34 +384,34 @@ instance TrieMap TyLitMap where mapMaybeTM = mpTyLit emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUDFM, tlm_char = Map.empty } lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of NumTyLit n -> tlm_number >.> Map.lookup n - StrTyLit n -> tlm_string >.> (`lookupUFM` n) + StrTyLit n -> tlm_string >.> (`lookupUDFM` n) CharTyLit n -> tlm_char >.> Map.lookup n xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m = case l of NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } - StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + StrTyLit n -> m { tlm_string = alterUDFM f (tlm_string m) n } CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) +foldTyLit l m = flip (foldUDFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) . flip (Map.foldr l) (tlm_char m) filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUDFM f ts, tlm_char = Map.filter f tc } mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc } + = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUDFM f ts, tlm_char = Map.mapMaybe f tc } ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this ===================================== docs/users_guide/exts/multiway_if.rst ===================================== @@ -10,7 +10,7 @@ Multi-way if-expressions Allow the use of multi-way-``if`` syntax. -With :extension:`MultiWayIf` extension GHC accepts conditional expressions with +With the :extension:`MultiWayIf` extension GHC accepts conditional expressions with multiple branches: :: if | guard1 -> expr1 @@ -24,12 +24,12 @@ which is roughly equivalent to :: ... _ | guardN -> exprN -Multi-way if expressions introduce a new layout context. So the example +Multi-way if expressions introduce a new kind of layout context that does not generate semicolons. The example above is equivalent to: :: if { | guard1 -> expr1 - ; | ... - ; | guardN -> exprN + | ... + | guardN -> exprN } The following behaves as expected: :: @@ -41,14 +41,14 @@ The following behaves as expected: :: because layout translates it as :: if { | guard1 -> if { | guard2 -> expr2 - ; | guard3 -> expr3 + | guard3 -> expr3 } - ; | guard4 -> expr4 + | guard4 -> expr4 } Layout with multi-way if works in the same way as other layout contexts, -except that the semi-colons between guards in a multi-way if are -optional. So it is not necessary to line up all the guards at the same +except that desugaring does not insert semicolons. +So it is not necessary to line up all the guards at the same column; this is consistent with the way guards work in function definitions and case expressions. ===================================== hadrian/src/Builder.hs ===================================== @@ -49,7 +49,7 @@ import GHC.Toolchain.Program -- * Compile or preprocess a source file. -- * Extract source dependencies by passing @-MM@ command line argument. data CcMode = CompileC | FindCDependencies DependencyType deriving (Eq, Generic, Show) -data DependencyType = CDep | CxxDep deriving (Eq, Generic, Show) +data DependencyType = CDep | CxxDep | AsmDep deriving (Eq, Generic, Show) instance Binary CcMode instance Hashable CcMode ===================================== hadrian/src/Rules/Compile.hs ===================================== @@ -282,8 +282,11 @@ needDependencies lang context@Context {..} src depFile = do discover -- Continue the discovery process -- We need to pass different flags to cc depending on whether the - -- file to compile is a .c or a .cpp file - depType = if lang == Cxx then CxxDep else CDep + -- file to compile is a .c or a .cpp or a .S file + depType = case lang of + Cxx -> CxxDep + Asm -> AsmDep + _ -> CDep parseFile :: FilePath -> Action [String] parseFile file = do ===================================== hadrian/src/Settings/Builders/Cc.hs ===================================== @@ -18,6 +18,7 @@ ccBuilderArgs = do , arg "-o", arg =<< getOutput ] , builder (Cc (FindCDependencies CDep)) ? findCDepExpr CDep , builder (Cc (FindCDependencies CxxDep)) ? findCDepExpr CxxDep + , builder (Cc (FindCDependencies AsmDep)) ? findCDepExpr AsmDep ] where findCDepExpr depType = do @@ -26,10 +27,10 @@ ccBuilderArgs = do , arg "-MM", arg "-MG" , arg "-MF", arg output , arg "-MT", arg $ dropExtension output -<.> "o" - , case depType of CDep -> mempty; CxxDep -> arg "-std=c++11" + , case depType of CDep -> mempty; CxxDep -> arg "-std=c++11"; AsmDep -> mempty , cIncludeArgs - , arg "-x", arg (case depType of CDep -> "c"; CxxDep -> "c++") - , case depType of CDep -> mempty; CxxDep -> getContextData cxxOpts + , arg "-x", arg (case depType of CDep -> "c"; CxxDep -> "c++"; AsmDep -> "assembler-with-cpp") + , case depType of CDep -> mempty; CxxDep -> getContextData cxxOpts; AsmDep -> mempty -- Pass 'ghcversion.h' to give sources access to the -- `MIN_VERSION_GLASGOW_HASKELL` macro. , notStage0 ? arg "-include" <> arg "rts/include/ghcversion.h" ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -428,6 +428,7 @@ rtsPackageArgs = package rts ? do ] , builder (Cc (FindCDependencies CDep)) ? cArgs , builder (Cc (FindCDependencies CxxDep)) ? cArgs + , builder (Cc (FindCDependencies AsmDep)) ? cArgs , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs , builder (Ghc CompileCppWithGhc) ? map ("-optcxx" ++) <$> cArgs , builder Ghc ? ghcArgs ===================================== libraries/text ===================================== @@ -1 +1 @@ -Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67 +Subproject commit 423fd981e576bd17a8b5fa48d0ad6b9a0c370e77 ===================================== testsuite/tests/ghc-api/TypeMapStringLiteral.hs ===================================== @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad (unless) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Short as SBS +import Data.Char (ord) +import Data.List (foldl') +import GHC.Core.Map.Type (TypeMap, emptyTypeMap, extendTypeMap, foldTypeMap) +import GHC.Core.Type (Type, mkStrLitTy) +import GHC.Data.FastString (FastString (..), FastZString (..)) +import GHC.Utils.Encoding (zEncodeString) + +main :: IO () +main = do + let logicalEntries = + [ ("alpha", "payload-alpha") + , ("beta", "payload-beta") + , ("gamma", "payload-gamma") + ] + uniquesOne = [1, 2, 3] + uniquesTwo = [200, 100, 500] + + tmOne = buildMap logicalEntries uniquesOne + tmTwo = buildMap logicalEntries uniquesTwo + + foldedOne = foldValues tmOne + foldedTwo = foldValues tmTwo + + assert "foldTypeMap order independent of FastString uniques" $ + foldedOne == foldedTwo + + +buildMap :: [(String, a)] -> [Int] -> TypeMap a +buildMap entries uniques = + foldl' insertEntry emptyTypeMap (zip uniques entries) + where + insertEntry :: TypeMap a -> (Int, (String, a)) -> TypeMap a + insertEntry tm (u, (txt, payload)) = + extendTypeMap tm (strLiteralWithUnique u txt) payload + +foldValues :: TypeMap a -> [a] +foldValues tm = foldTypeMap (:) [] tm + +strLiteralWithUnique :: Int -> String -> Type +strLiteralWithUnique u = mkStrLitTy . fakeFastString u + +fakeFastString :: Int -> String -> FastString +fakeFastString u s = FastString + { uniq = u + , n_chars = length s + , fs_sbs = SBS.pack (map (fromIntegral . ord) s) + , fs_zenc = error "unused" + } + +assert :: String -> Bool -> IO () +assert label condition = unless condition $ + error ("TypeMap string literal test failed: " ++ label) ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -74,3 +74,4 @@ test('T25577', [ extra_run_opts(f'"{config.libdir}"') test('T26120', [], compile_and_run, ['-package ghc']) test('T26264', normal, compile_and_run, ['-package ghc']) +test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr ===================================== @@ -30,7 +30,13 @@ RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999] • No instance for ‘HasField "quux3" Quux r0’ arising from selecting the field ‘quux3’ NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. - • In the expression: ....bar.baz.quux3 - In the second argument of ‘($)’, namely ‘....baz.quux3.wob’ + • In the second argument of ‘($)’, namely ‘....baz.quux3.wob’ In a stmt of a 'do' block: print @Bool $ ....quux3.wob + In the expression: + do let a = Foo {foo = ...} + print @Quux $ ....quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a996fae9ab0dcbe25a5575f4d1864d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a996fae9ab0dcbe25a5575f4d1864d... You're receiving this email because of your account on gitlab.haskell.org.