GitLab

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

Commits:

d033b028

by Andreas Klebinger at 2026-07-03T12:36:27+02:00

cmm: Add machop width info with -dppr-debug for infix ops.

035094c1
by Andreas Klebinger at 2026-07-03T12:37:39+02:00
```
Add test for #27430.
```

294c6098

by Andreas Klebinger at 2026-07-03T12:40:02+02:00

Tiny arm64 codegen refactor.

Rename truncateReg to make it clear it changes the register.

3faf1eb0

by Andreas Klebinger at 2026-07-03T12:40:52+02:00

Revert "Tiny arm64 codegen refactor."

Reverted to test if test actually fails on ci.

This reverts commit 294c609842069a4474356baf99e43cdfdb604e50.

5 changed files:

compiler/GHC/Cmm/Expr.hs
+ testsuite/tests/codeGen/should_run/T27430.hs
+ testsuite/tests/codeGen/should_run/T27430.stdout
+ testsuite/tests/codeGen/should_run/T27430_c.c
testsuite/tests/codeGen/should_run/all.T

Changes:

compiler/GHC/Cmm/Expr.hs

@@ -443,6 +443,11 @@ pprExpr platform e
          CmmLit lit -> pprLit platform lit
          _other     -> pprExpr1 platform e
 +-- `exp` usually, but (expr[width]) with -dppr-debug
 +withDebugWidth :: Width -> SDoc -> SDoc
 +withDebugWidth w exp =
 +  ifPprDebug (parens (exp <> brackets (ppr w))) exp
++
  -- Here's the precedence table from GHC.Cmm.Parser:
  -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
  -- %left '|'
@@ -465,15 +470,17 @@ pprExpr1 platform e = pprExpr7 platform e
  infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
 -infixMachOp1 (MO_Eq     _) = Just (text "==")
 -infixMachOp1 (MO_Ne     _) = Just (text "!=")
 -infixMachOp1 (MO_Shl    _) = Just (text "<<")
 -infixMachOp1 (MO_U_Shr  _) = Just (text ">>")
 -infixMachOp1 (MO_U_Ge   _) = Just (text ">=")
 -infixMachOp1 (MO_U_Le   _) = Just (text "<=")
 -infixMachOp1 (MO_U_Gt   _) = Just (char '>')
 -infixMachOp1 (MO_U_Lt   _) = Just (char '<')
 -infixMachOp1 _             = Nothing
 +infixMachOp1 mop = case mop of
 +    (MO_Eq     w) -> Just $ withDebugWidth w (text "==")
 +    (MO_Ne     w) -> Just $ withDebugWidth w (text "!=")
 +    (MO_Shl    w) -> Just $ withDebugWidth w (text "<<")
 +    (MO_U_Shr  w) -> Just $ withDebugWidth w (text ">>")
 +    (MO_U_Ge   w) -> Just $ withDebugWidth w (text ">=")
 +    (MO_U_Le   w) -> Just $ withDebugWidth w (text "<=")
 +    (MO_U_Gt   w) -> Just $ withDebugWidth w (char '>')
 +    (MO_U_Lt   w) -> Just $ withDebugWidth w (char '<')
 +    _             -> Nothing
 +    where
  -- %left '-' '+'
  pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
@@ -483,8 +490,8 @@ pprExpr7 platform (CmmMachOp op [x,y])
     = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
  pprExpr7 platform e = pprExpr8 platform e
 -infixMachOp7 (MO_Add _)  = Just (char '+')
 -infixMachOp7 (MO_Sub _)  = Just (char '-')
 +infixMachOp7 (MO_Add w)  = Just $ withDebugWidth w (char '+')
 +infixMachOp7 (MO_Sub w)  = Just $ withDebugWidth w (char '-')
  infixMachOp7 _           = Nothing
  -- %left '/' '*' '%'
@@ -493,9 +500,9 @@ pprExpr8 platform (CmmMachOp op [x,y])
     = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
  pprExpr8 platform e = pprExpr9 platform e
 -infixMachOp8 (MO_U_Quot _) = Just (char '/')
 -infixMachOp8 (MO_Mul _)    = Just (char '*')
 -infixMachOp8 (MO_U_Rem _)  = Just (char '%')
 +infixMachOp8 (MO_U_Quot w) = Just $ withDebugWidth w (char '/')
 +infixMachOp8 (MO_Mul w)    = Just $ withDebugWidth w (char '*')
 +infixMachOp8 (MO_U_Rem w)  = Just $ withDebugWidth w (char '%')
  infixMachOp8 _             = Nothing
  pprExpr9 :: Platform -> CmmExpr -> SDoc

testsuite/tests/codeGen/should_run/T27430.hs

 +{-# LANGUAGE MagicHash #-}
 +{-# OPTIONS_GHC -dno-typeable-binds -ddump-to-file -dsuppress-ticks -dsuppress-timestamps -ddump-stg-from-core -ddump-stg-final -ddump-cmm -ddump-cmm-raw -ddump-asm #-}
++
 +import GHC.Exts
 +import Data.Bits
 +import GHC.Word
++
 +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8
 +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word16
 +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word32
++
 +x :: Word64
 +x = 5
++
 +-- Those should give just x when truncated.
 +y8,y16,y32 :: Word64
 +y8 = setBit x 8
 +y16 = setBit x 16
 +y32 = setBit x 32
++
 +eq8 :: Word8 -> Word8 -> Int
 +eq8 (W8# a) (W8# b) = I# (eqWord8# a b)
++
 +eq16 :: Word16 -> Word16 -> Int
 +eq16 (W16# a) (W16# b) = I# (eqWord16# a b)
++
 +eq32 :: Word32 -> Word32 -> Int
 +eq32 (W32# a) (W32# b) = I# (eqWord32# a b)
++
 +{-# NOINLINE outline_eq8 #-}
 +outline_eq8 = eq8
 +{-# NOINLINE outline_eq16 #-}
 +outline_eq16 = eq16
 +{-# NOINLINE outline_eq32 #-}
 +outline_eq32 = eq32
++
 +main :: IO ()
 +main = do
 +  print (eq8 (u64_to_u8 x) (u64_to_u8 y8))
 +  print (eq16 (u64_to_u16 x) (u64_to_u16 y16))
 +  print (eq32 (u64_to_u32 x) (u64_to_u32 y32))
++
 +  print (outline_eq8 (u64_to_u8 x) (u64_to_u8 y8))
 +  print (outline_eq16 (u64_to_u16 x) (u64_to_u16 y16))
 +  print (outline_eq32 (u64_to_u32 x) (u64_to_u32 y32))

testsuite/tests/codeGen/should_run/T27430.stdout

 +1
 +1
 +1
 +1
 +1
 +1

testsuite/tests/codeGen/should_run/T27430_c.c

 +#include <stdint.h>
++
 +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; }
 +uint8_t u64_to_u16(uint64_t v) { return (uint16_t)v; }
 +uint8_t u64_to_u32(uint64_t v) { return (uint32_t)v; }

testsuite/tests/codeGen/should_run/all.T

@@ -295,3 +295,5 @@ test('aarch64-sxtw-run',
         when(unregisterised(), skip)],
       multi_compile_and_run,
       ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])
++
 +test('T27430', [req_c], compile_and_run, ['T27430_c.c'])