[Git][ghc/ghc][wip/andreask/arm-ffi] 6 commits: arm64 ncg: Fix truncation/extension logic for genCondJump.

28 Jul 2026

Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC


Commits:
0359549b by Andreas Klebinger at 2026-07-27T08:46:24+00:00
arm64 ncg: Fix truncation/extension logic for genCondJump.

We used to sign-extend the comparison registers in place which could clobber local variables.

- - - - -
5c603651 by Andreas Klebinger at 2026-07-27T21:31:10+00:00
Add test for #27533

In the ticket we observed a single-byte read being implemented as
multi-byte read causing issues.

- - - - -
2445ef22 by Andreas Klebinger at 2026-07-27T21:32:39+00:00
Added an assert for correct widths to arm64 backend

- - - - -
2b8ee333 by Andreas Klebinger at 2026-07-28T06:41:49+00:00
arm64 ncg: Fix MO_V_Broadcast for non-literals.

We now use OpReg instead of OpScalarAsVec as required since we broadcast a gp register.

Also adds a test. Fixes #27533.

- - - - -
fca96f28 by Andreas Klebinger at 2026-07-28T08:38:08+00:00
cmmLint: Check address width to be equal to wordWidth.

- - - - -
e5d9fac3 by Andreas Klebinger at 2026-07-28T15:04:51+00:00
arm64 ncg: Fix subword store/load instructions.

We used to read those at 32bit width even for smaller values possibly
resulting in invalid memory access. Now we construct the suffix for
subword variants based on the instruction format for these.

- - - - -


12 changed files:

- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- + testsuite/tests/codeGen/should_run/T27533.hs
- + testsuite/tests/codeGen/should_run/T27533.stdout
- + testsuite/tests/codeGen/should_run/T27533_cmm.cmm
- testsuite/tests/codeGen/should_run/T27538.hs
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/simd/should_run/T27565.hs
- + testsuite/tests/simd/should_run/T27565.stdout
- testsuite/tests/simd/should_run/all.T


Changes:

=====================================
compiler/GHC/Cmm/Lint.hs
=====================================
@@ -88,8 +88,9 @@ lintCmmBlock labels block
 -- byte/word mismatches.
 
 lintCmmExpr :: CmmExpr -> CmmLint CmmType
-lintCmmExpr (CmmLoad expr rep _alignment) = do
-  _ <- lintCmmExpr expr
+lintCmmExpr e@(CmmLoad expr rep _alignment) = do
+  ty <- lintCmmExpr expr
+  lintAddrTy e ty
   -- Disabled, if we have the inlining phase before the lint phase,
   -- we can have funny offsets due to pointer tagging. -- EZY
   -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
@@ -112,6 +113,15 @@ lintCmmExpr expr =
   do platform <- getPlatform
      return (cmmExprType platform expr)
 
+-- We require every address to refer to be word-width since we don't support 32
+-- bit pointers on 64bit platforms.
+lintAddrTy :: CmmExpr -> CmmType -> CmmLint ()
+lintAddrTy e addr_ty = do
+  p <- getPlatform
+  -- We don't support any platforms where wordwidth /= ptrWidth currently.
+  unless (addr_ty `cmmCompatType` bWord p) $ cmmLintErr (text "Non word-width address found in:" <+> pdoc p e)
+
+
 -- | Check for obviously out-of-bounds shift operations
 lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
 lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]
@@ -173,10 +183,10 @@ lintCmmMiddle node = case node of
             unless (erep `cmmCompatType` reg_ty) $
               cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
 
-  CmmStore l r _alignment -> do
-            _ <- lintCmmExpr l
-            _ <- lintCmmExpr r
-            return ()
+  CmmStore addr rhs _alignment -> do
+            addr_ty <- lintCmmExpr addr
+            _ <- lintCmmExpr rhs
+            lintAddrTy addr addr_ty
 
   CmmUnsafeForeignCall target _formals actuals -> do
             let lintArg expr = do


=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -376,8 +376,10 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _ty))
 -- -----------------------------------------------------------------------------
 -- General things for putting together code sequences

--- | The dual to getAnyReg: compute an expression into a register, but
---      we don't mind which one it is.
+-- | Computes the register into some register, but we can't pick which one.
+-- This means the register might be mapped to a global or local variable and
+-- we can only mutate the result reg in place if we know the Cmm expression can't
+-- refer to local or global variables.
 getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
 getSomeReg expr = do
   r <- getRegister expr
@@ -955,7 +957,7 @@ getRegister' config plat expr
               return $ Fixed (intFormat to) trunc_reg (code `appOL` code_trunc)
 
         -- Vector
-        MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
+        MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpReg w reg))
           where fmt = VecFormat l (intScalarFormat w)
                 vw = formatToWidth fmt
         MO_VF_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
@@ -1071,7 +1073,7 @@ getRegister' config plat expr
             in return $ Any (intFormat to) $ \dst ->
                 code `snocOL`
                 SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
-                -- At this point an 8- or 16-bit value would be sign-extended
+                -- At this point an 8- or 16-bit value is sign-extended
                 -- to 32-bits. Truncate back down the final width.
                 truncateSubwordRegInplace to dst
 
@@ -1760,7 +1762,7 @@ getRegister' config plat expr
           tmp <- getNewRegNat format
           return $ Any format $ \dst ->
             code_x `appOL` code_y `appOL`
-            if dst == reg_y
+            if dst == reg_y --unlike MO_V_Insert here y/dst can overlap.
             then toOL [ MOV (OpReg W128 tmp) (OpReg W128 reg_x)
                       , INS format (OpVecLane w tmp index) (OpScalarAsVec w reg_y)
                       , MOV (OpReg W128 dst) (OpReg W128 tmp)
@@ -2062,23 +2064,33 @@ genCondJump bid expr = do
                 -- compute both sides.
                 (reg_x, _format_x, code_x) <- getSomeReg x
                 (reg_y, _format_y, code_y) <- getSomeReg y
-                let x' = OpReg w reg_x
-                    y' = OpReg w reg_y
-                return $ case w of
-                  W8  -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
+
+                -- If all computations reliably produce zero-extended subword results
+                -- this truncation is redundant. But for now better to be correct than
+                -- fast.
+                (reg_x', trunc_x) <- truncateSubwordReg w reg_x
+                -- TODO: Use CMP on OpRegExt rather than extending explicitly.
+                (reg_y', trunc_y) <- truncateSubwordReg w reg_y
+
+                let x' = OpReg w reg_x'
+                    y' = OpReg w reg_y'
+                return $ concatOL [code_x, trunc_x, code_y, trunc_y,
+                                   toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]]
 
             sbcond w cmp = do
                 -- compute both sides.
                 (reg_x, _format_x, code_x) <- getSomeReg x
                 (reg_y, _format_y, code_y) <- getSomeReg y
-                let x' = OpReg w reg_x
-                    y' = OpReg w reg_y
-                return $ case w of
-                  W8  -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
+
+                -- W64 always works, even if we ultimately compare at W32.
+                (reg_x', ext_x) <- signExtendReg w W64 reg_x
+                -- TODO: Use CMP on OpRegExt rather than extending explicitly.
+                (reg_y', ext_y) <- signExtendReg w W64 reg_y
+
+                let x' = OpReg w reg_x'
+                    y' = OpReg w reg_y'
+                return $ concatOL [code_x, ext_x, code_y, ext_y,
+                                   toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]]
 
             fbcond w cmp = do
               -- ensure we get float regs
@@ -2750,6 +2762,7 @@ genCCall target dest_regs arg_regs = do
           | [p_reg, val_reg] <- arg_regs -> do
               (p, _fmt_p, code_p) <- getSomeReg p_reg
               (val, fmt_val, code_val) <- getSomeReg val_reg
+              massert (fmt_val == intFormat w)
               let instr = case ord of
                       MemOrderRelaxed -> STR
                       _               -> STLR


=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -771,7 +771,8 @@ data Instr
     | MOVZ Operand Operand
     | MVN Operand Operand -- rd = ~rn
     | ORR Format Operand Operand Operand -- rd = rn | op2
-    -- Load and stores.
+    -- Load and stores, we support subwords by picking the subword variant
+    -- based on the format.
     -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.
     | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr
     | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr


=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -569,12 +569,8 @@ pprInstr platform instr = case instr of
   -- NOTE: GHC may do whacky things where it only load the lower part of an
   --       address. Not observing the correct size when loading will lead
   --       inevitably to crashes.
-  STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tstrb") o1 o2
-  STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tstrh") o1 o2
-  STR _f o1 o2 -> op2 (text "\tstr") o1 o2
-  STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2
+  STR f o1 o2 ->  op2 (subword_suffix f $ text "\tstr") o1 o2
+  STLR f o1 o2 -> op2 (subword_suffix f $ text "\tstlr") o1 o2
 
   LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
     let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
@@ -622,12 +618,8 @@ pprInstr platform instr = case instr of
     op_adrp o1 adrp' $$
     op_add o1 ldr'
 
-  LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tldrb") o1 o2
-  LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tldrh") o1 o2
-  LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
-  LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
+  LDR f o1 o2 -> op2 (subword_suffix f $ text "\tldr") o1 o2
+  LDAR f o1 o2 -> op2 (subword_suffix f $ text "\tldar") o1 o2
 
   -- 8. Synchronization Instructions -------------------------------------------
   DMBISH DmbLoadStore -> line $ text "\tdmb ish"
@@ -698,6 +690,12 @@ pprInstr platform instr = case instr of
        check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else
          pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"
 
+       -- Some instructions encode with via b/h suffix on the instruction.
+       -- We handle this here relying on the format rather then the operands.
+       subword_suffix II8  t = t <> char 'b'
+       subword_suffix II16 t = t <> char 'h'
+       subword_suffix _    t = t
+
 pprBcond :: IsLine doc => Cond -> doc
 pprBcond c = text "b." <> pprCond c
 


=====================================
testsuite/tests/codeGen/should_run/T27533.hs
=====================================
@@ -0,0 +1,27 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes #-}
+
+import GHC.Exts
+import GHC.IO (IO(..))
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Ptr (Ptr(..))
+import Numeric (showHex)
+import System.IO
+
+foreign import prim "store8" store8# :: Addr# -> Word#
+foreign import prim "load8"  load8#  :: Addr# -> Word#
+
+main :: IO ()
+main = do
+  hSetBuffering stdout NoBuffering
+  allocaBytes 8 $ \(Ptr a) -> do
+    -- 1. Silent corruption: release-store of 1 byte into an all-ones word.
+    IO (\s -> (# writeWordOffAddr# a 0# 0xFFFFFFFFFFFFFFFF## s, () #))
+    case store8# a of _ -> return ()   -- case on unlifted Word# forces the call
+    w <- IO (\s -> case readWordOffAddr# a 0# s of (# s', v #) -> (# s', W# v #))
+    putStrLn ("after 1-byte release-store: 0x" ++ showHex w "")
+    -- expected 0xffffffffffffff43; buggy NCG gives 0xffffffff00000043
+
+    -- 2. SIGBUS: acquire-load of 1 byte at an odd address (well-defined).
+    r <- IO (\s -> (# s, W# (load8# (a `plusAddr#` 1#)) #))
+    putStrLn ("acquire byte load at p+1:   0x" ++ showHex r "")
+    -- expected 0xff; buggy NCG dies with SIGBUS before printing


=====================================
testsuite/tests/codeGen/should_run/T27533.stdout
=====================================
@@ -0,0 +1,2 @@
+after 1-byte release-store: 0xffffffffffffff43
+acquire byte load at p+1:   0xff


=====================================
testsuite/tests/codeGen/should_run/T27533_cmm.cmm
=====================================
@@ -0,0 +1,14 @@
+#include "Cmm.h"
+
+// Release-store one byte at p. Must touch exactly 1 byte.
+store8 (W_ p) {
+    %release I8[p] = 67 :: I8;
+    return (0);
+}
+
+// Acquire-load one byte from p.
+load8 (W_ p) {
+    I8 v;
+    v = %acquire I8[p];
+    return (%zx64(v));
+}


=====================================
testsuite/tests/codeGen/should_run/T27538.hs
=====================================
@@ -14,6 +14,7 @@ f x = if isTrue# (x `ltInt8#` intToInt8# 0#)
 
 main :: IO ()
 main = do
+  -- Test for use of byte-width read.
   let !(I# i) = ix
       x = indexInt8OffAddr# "\x80"# i
   putStrLn ("f(0x80) = " ++ show (I# (f x)))


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -298,6 +298,10 @@ test('aarch64-sxtw-run',
 
 test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c'])
 
+test('T27533', [req_cmm, extra_ways(['optasm'])], multi_compile_and_run,
+               ['T27533', [('T27533_cmm.cmm', '')], '-O'])
+
 test('T27537', normal, compile_and_run, ['-O'])
 
 test('T27538', normal, compile_and_run, ['-O'])
+


=====================================
testsuite/tests/simd/should_run/T27565.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+module Main (main) where
+import GHC.Exts
+import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))
+
+{-# OPAQUE broadcast_i8 #-}
+broadcast_i8 :: Int8# -> Int8X16#
+broadcast_i8 x = broadcastInt8X16# x
+
+{-# OPAQUE broadcast_i16 #-}
+broadcast_i16 :: Int16# -> Int16X8#
+broadcast_i16 x = broadcastInt16X8# x
+
+{-# OPAQUE broadcast_i32 #-}
+broadcast_i32 :: Int32# -> Int32X4#
+broadcast_i32 x = broadcastInt32X4# x
+
+{-# OPAQUE broadcast_i64 #-}
+broadcast_i64 :: Int64# -> Int64X2#
+broadcast_i64 x = broadcastInt64X2# x
+
+main :: IO ()
+main = do
+  case unpackInt8X16# (broadcast_i8 (intToInt8# 32#)) of
+    (# a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 #) ->
+      print [ I8# a0, I8# a1, I8# a2, I8# a3, I8# a4, I8# a5, I8# a6, I8# a7
+            , I8# a8, I8# a9, I8# a10, I8# a11, I8# a12, I8# a13, I8# a14, I8# a15 ]
+  case unpackInt16X8# (broadcast_i16 (intToInt16# 32#)) of
+    (# b0,b1,b2,b3,b4,b5,b6,b7 #) ->
+      print [ I16# b0, I16# b1, I16# b2, I16# b3, I16# b4, I16# b5, I16# b6, I16# b7 ]
+  case unpackInt32X4# (broadcast_i32 (intToInt32# 32#)) of
+    (# c0,c1,c2,c3 #) ->
+      print [ I32# c0, I32# c1, I32# c2, I32# c3 ]
+  case unpackInt64X2# (broadcast_i64 (intToInt64# 32#)) of
+    (# d0,d1 #) ->
+      print [ I64# d0, I64# d1 ]


=====================================
testsuite/tests/simd/should_run/T27565.stdout
=====================================
@@ -0,0 +1,4 @@
+[32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32]
+[32,32,32,32,32,32,32,32]
+[32,32,32,32]
+[32,32]


=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -217,3 +217,5 @@ test('StackAlignment64'
     , compile_and_run if have_cpu_feature('avx512f') else compile
     , ['StackAlignment64_main.c']
     )
+
+test('T27565', [], compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1523beef0d172548211894720063a32...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1523beef0d172548211894720063a32...
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

    

Andreas Klebinger (＠AndreasK)

tags

participants (1)