Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 - - - - - 43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 - - - - - e8675d88 by Matthew Pickering at 2026-01-30T05:02:23-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 - - - - - 9a996fae by Andrew Lelechenko at 2026-01-30T05:02:23-05:00 Upgrade text submodule to 2.1.4 - - - - - 6 changed files: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/Core/Map/Type.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/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -180,7 +180,7 @@ stmtToInstrs stmt = do format = cmmTypeFormat ty CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args + -> genCCall platform target result_regs args CmmBranch id -> genBranch id CmmCondBranch arg true false prediction -> do @@ -338,6 +338,8 @@ iselExpr64 (CmmReg (CmmLocal local_reg)) = do let Reg64 hi lo = localReg64 local_reg return (RegCode64 nilOL hi lo) +iselExpr64 regoff@(CmmRegOff _ _) = iselExpr64 $ mangleIndexTree regoff + iselExpr64 (CmmLit (CmmInt i _)) = do Reg64 rhi rlo <- getNewReg64 let @@ -1183,24 +1185,25 @@ genCondJump id bool prediction = do -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. -genCCall :: ForeignTarget -- function to call +genCCall :: Platform + -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_AcquireFence) _ _ +genCCall _ (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_ReleaseFence) _ _ +genCCall _ (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_SeqCstFence) _ _ +genCCall _ (PrimTarget MO_SeqCstFence) _ _ = return $ unitOL HWSYNC -genCCall (PrimTarget MO_Touch) _ _ +genCCall _ (PrimTarget MO_Touch) _ _ = return $ nilOL -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ +genCCall _ (PrimTarget (MO_Prefetch_Data _)) _ _ = return $ nilOL -genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] +genCCall _ (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do let fmt = intFormat width reg_dst = getLocalRegReg dst (instr, n_code) <- case amop of @@ -1250,7 +1253,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] +genCCall _ (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1277,12 +1280,12 @@ genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do +genCCall _ (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code -genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] - | width == W32 || width == W64 +genCCall platform (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] + | width == W32 || (width == W64 && not (target32Bit platform)) = do (old_reg, old_code) <- getSomeReg old (new_reg, new_code) <- getSomeReg new @@ -1311,9 +1314,8 @@ genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] format = intFormat width -genCCall (PrimTarget (MO_Clz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Clz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do RegCode64 code vr_hi vr_lo <- iselExpr64 src @@ -1361,9 +1363,8 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src] let cntlz = unitOL (CNTLZ format reg_dst reg) return $ s_code `appOL` pre `appOL` cntlz `appOL` post -genCCall (PrimTarget (MO_Ctz width)) [dst] [src] - = do platform <- getPlatform - let reg_dst = getLocalRegReg dst +genCCall platform (PrimTarget (MO_Ctz width)) [dst] [src] + = do let reg_dst = getLocalRegReg dst if target32Bit platform && width == W64 then do let format = II32 @@ -1425,9 +1426,8 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src] , SUBFC dst r' (RIImm (ImmInt (format_bits))) ] -genCCall target dest_regs argsAndHints - = do platform <- getPlatform - case target of +genCCall platform target dest_regs argsAndHints + = do case target of PrimTarget (MO_S_QuotRem width) -> divOp1 True width dest_regs argsAndHints PrimTarget (MO_U_QuotRem width) -> divOp1 False width ===================================== 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 ===================================== 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/347d114194b2d02d88ee8b4e236e335... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/347d114194b2d02d88ee8b4e236e335... You're receiving this email because of your account on gitlab.haskell.org.