Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: c0bb67fd by Andreas Klebinger at 2026-07-03T12:00:31+02:00 Add test for #27430. - - - - - 5 changed files: - compiler/GHC/CmmToAsm/AArch64/CodeGen.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/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -662,7 +662,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) -- in between operations. -- -- IMPORTANT: this invariant only holds within a single expression tree as --- generated by the NCG (via truncateReg after each sub-word operation). It +-- generated by the NCG (via truncateRegInplace after each sub-word operation). It -- does NOT hold at function entry points or across basic block boundaries, -- because the GHC calling convention does not guarantee that callers -- zero-extend sub-word arguments. Therefore, any operation that is sensitive @@ -688,7 +688,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) -- Next we compute `c`: The `%not` requires no extension of its operands, but -- we must still truncate the result back down to 8-bits. Finally the `%shrl` -- requires no extension and no truncate since we can assume that --- `c` is zero-extended (it was produced by a truncateReg in the same block). +-- `c` is zero-extended (it was produced by a truncateRegInplace in the same block). -- -- TODO: -- Don't use Width in Operands @@ -931,7 +931,7 @@ getRegister' config plat expr let w' = opRegWidth w in code `snocOL` MVN (OpReg w' dst) (OpReg w' reg) `appOL` - truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] + truncateRegInplace w' w dst -- See Note [Signed arithmetic on AArch64] MO_S_Neg w -> negate code w reg MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg)) @@ -1064,7 +1064,7 @@ getRegister' config plat expr code `appOL` code_sx `snocOL` NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL` - truncateReg w' w dst + truncateRegInplace w' w dst ss_conv from to reg code = let w' = opRegWidth (max from to) @@ -1073,7 +1073,7 @@ getRegister' config plat expr 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 -- to 32-bits. Truncate back down the final width. - truncateReg w' to dst + truncateRegInplace w' to dst -- Dyadic machops: -- @@ -1220,7 +1220,7 @@ getRegister' config plat expr code_y `appOL` op (OpReg w dst) (OpReg w reg_x) op_y) - -- A (potentially signed) integer operation. + -- A (potentially signed) integer operation that can have immediate arguments. -- In the case of 8- and 16-bit signed arithmetic we must first -- sign-extend both arguments to 32-bits. -- See Note [Signed arithmetic on AArch64]. @@ -1230,6 +1230,7 @@ getRegister' config plat expr -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o> + let w' = opRegWidth w (reg_x, format_x, code_x) <- getSomeReg x (op_y, format_y, code_y) <- case y of CmmLit (CmmInt n w) @@ -1241,12 +1242,11 @@ getRegister' config plat expr massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" -- This is the width of the registers on which the operation -- should be performed. - let w' = opRegWidth w return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + truncateRegInplace w' w dst -- truncate back to the operand's original width -- A (potentially signed) integer operation. -- In the case of 8- and 16-bit signed arithmetic we must first @@ -1263,7 +1263,8 @@ getRegister' config plat expr -- should be performed. let w' = opRegWidth w signExt r - | not is_signed = return (r, nilOL) + -- See Note [Signed arithmetic on AArch64] and #27430 + | not is_signed = truncateReg w w' r | otherwise = signExtendReg w w' r (reg_x_sx, code_x_sx) <- signExt reg_x (reg_y_sx, code_y_sx) <- signExt reg_y @@ -1274,7 +1275,7 @@ getRegister' config plat expr code_x_sx `appOL` code_y_sx `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + truncateRegInplace w' w dst -- truncate back to the operand's original width floatOp w op = do (reg_fx, format_x, code_fx) <- getFloatReg x @@ -1904,10 +1905,28 @@ signExtendReg w w' r = r' <- getNewRegNat (intFormat w') return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) --- | Instructions to truncate the value in the given register from width @w@ +-- | Instructions to truncate (zero extend) the value in the given register from width @w@ +-- down to width @w'@ into a new register. Or return the original register if it's a noop. +truncateReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) +truncateReg w w' r = do + case w' of + W64 -> noop + W32 + | w' == W32 -> noop + | otherwise -> trunc MOV + W16 -> trunc UXTH + W8 -> trunc UXTB + _ -> panic "intOp" + where + noop = return (r, nilOL) + trunc instr = do + r' <- getNewRegNat (intFormat w') + return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) + +-- | Instructions to truncate (zero extend) the value in the given register from width @w@ -- down to width @w'@. -truncateReg :: Width -> Width -> Reg -> OrdList Instr -truncateReg w w' r = +truncateRegInplace :: Width -> Width -> Reg -> OrdList Instr +truncateRegInplace w w' r = case w of W64 -> nilOL W32 @@ -2352,7 +2371,7 @@ genCCall target dest_regs arg_regs = do -- product, and hi gets the overflow (sign extension bits). SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL` ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` - truncateReg w' w lo `snocOL` + truncateRegInplace w' w lo `snocOL` -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'. -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive. -- No overflow iff hi is the sign extension of lo: @@ -2362,7 +2381,7 @@ genCCall target dest_regs arg_regs = do -- NE to set nd = 1 when overflow occurred. CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` CSET (OpReg w' nd) NE `appOL` - truncateReg w' w hi + truncateRegInplace w' w hi -- Can't handle > 64 bit operands | otherwise -> unsupported (MO_S_Mul2 w) PrimTarget (MO_U_Mul2 w) @@ -2412,7 +2431,7 @@ genCCall target dest_regs arg_regs = do (OpImm (ImmInt $ widthInBits w)) -- lsb (OpImm (ImmInt $ widthInBits w)) -- width to extract `appOL` - truncateReg W64 w lo + truncateRegInplace W64 w lo ) | otherwise -> unsupported (MO_U_Mul2 w) PrimTarget (MO_Clz w) @@ -2916,7 +2935,14 @@ genCCall target dest_regs arg_regs = do r_dst = getRegisterReg platform (CmmLocal dst) if isFloatFormat format || isVecFormat format then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) - else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)) + else do + -- See [Signed arithmetic on AArch64] + -- Strictly speaking we don't have to here but err on the side of caution. + let !mov_instr = case w of + W8 -> UXTB + W16 -> UXTH + _ -> MOV + readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg)) unaryFloatOp w op arg_reg dest_reg = do platform <- getPlatform ===================================== testsuite/tests/codeGen/should_run/T27430.hs ===================================== @@ -0,0 +1,45 @@ +{-# 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 ===================================== @@ -0,0 +1,6 @@ +1 +1 +1 +1 +1 +1 ===================================== testsuite/tests/codeGen/should_run/T27430_c.c ===================================== @@ -0,0 +1,5 @@ +#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']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c0bb67fd4b757c3b7a337bbd08439969... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c0bb67fd4b757c3b7a337bbd08439969... You're receiving this email because of your account on gitlab.haskell.org.