GitLab

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		-Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67
	1	+Subproject commit 423fd981e576bd17a8b5fa48d0ad6b9a0c370e77

testsuite/tests/ghc-api/TypeMapStringLiteral.hs

 +{-# 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 = ...}
 +           ...