Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 16046e69 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 cmm: Add machop width info with -dppr-debug for infix ops. - - - - - 13f7d159 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 Add test for #27430. - - - - - 28318419 by Andreas Klebinger at 2026-07-21T15:53:42+02:00 arm64 ncg: Fix subword handling of ffi calls. Our invariants require us to clear the high bits for subword results. We now do so both for unspecified bit casts (MO_CONV_XX) and when taking in results from ffi calls. I also renamed truncateReg to make it clear it changes the register. - - - - - 7fefaf5f by Andreas Klebinger at 2026-07-25T11:19:30+00:00 Fix truncateReg - - - - - 8 changed files: - + changelog.d/T27430 - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/MachOp.hs - 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: ===================================== changelog.d/T27430 ===================================== @@ -0,0 +1,11 @@ +section: compiler +issues: #27430 +mrs: !16255 +synopsis: + AArch64 code generation: Fix handling of subword return values at FFI boundary. +description: + When calling C functions returning subword values, sometimes those values high + bit would incorrectly influence certain operations. + + We now zero the high bits consistently to avoid this. + ===================================== 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 ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -142,7 +142,7 @@ data MachOp -- Conversions. Some of these will be NOPs. -- Floating-point conversions use the signed variant. - | MO_SF_Round Width Width -- Signed int -> Float + | MO_SF_Round Width Width -- Signed int -> Float, but only W32/W64 inputs | MO_FS_Truncate Width Width -- Float -> Signed int | MO_SS_Conv Width Width -- Signed int -> Signed int | MO_UU_Conv Width Width -- unsigned int -> unsigned int ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -358,19 +358,13 @@ data Register = Fixed Format Reg InstrBlock | Any Format (Reg -> InstrBlock) --- | Sometimes we need to change the Format of a register. Primarily during --- conversion. -swizzleRegisterRep :: Format -> Register -> Register -swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code -swizzleRegisterRep format (Any _ codefn) = Any format codefn - -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _ty)) = case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) @@ -662,7 +656,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 truncateSubwordRegInplace 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 +682,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 truncateSubwordRegInplace in the same block). -- -- TODO: -- Don't use Width in Operands @@ -931,7 +925,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] + truncateSubwordRegInplace 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)) @@ -952,7 +946,13 @@ getRegister' config plat expr where fmt = intFormat w -- Conversions - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + MO_XX_Conv from to + | to >= W32 || to > from -> + -- We don't care about garbage high bits when upcasting this way. + pure $ Fixed (intFormat to) reg code + | otherwise -> do + (trunc_reg, code_trunc) <- truncateSubwordReg to reg + 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)) @@ -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 + truncateSubwordRegInplace 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 + truncateSubwordRegInplace 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 + truncateSubwordRegInplace 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 = truncateSubwordReg 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 + truncateSubwordRegInplace w dst -- truncate back to the operand's original width floatOp w op = do (reg_fx, format_x, code_fx) <- getFloatReg x @@ -1897,25 +1898,44 @@ signExtendReg w w' r = | otherwise -> extend SXTW W16 -> extend SXTH W8 -> extend SXTB - _ -> panic "intOp" + _ -> panic "signExtendReg:unexpectedWidth" where noop = return (r, nilOL) extend instr = do 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@ --- down to width @w'@. -truncateReg :: Width -> Width -> Reg -> OrdList Instr -truncateReg w w' r = - case w of +-- | Truncate/zero extend the subwords high bits and store the +-- result in a new register. +truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr) +truncateSubwordReg w_to r = do + case w_to of + -- Simply move it unchanged, we use at least 32bits + W64 -> trunc W64 MOV -- Ensure W64->W64 is a no-op by using 64bit mov. + W32 -> trunc W32 MOV + + -- Actual truncation + W16 -> trunc W32 UXTH + W8 -> trunc W32 UXTB + _ -> panic "truncateSubwordReg:unexpectedWidth" + where + trunc w instr = do + r' <- getNewRegNat (intFormat w_to) + return (r', unitOL $ instr (OpReg w r') (OpReg w r)) + +-- | Like @truncateSubwordReg@, but modifes the argument register in place if we +-- need to truncate. +truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr +truncateSubwordRegInplace w_to r = do + case w_to of W64 -> nilOL - W32 - | w' == W32 -> nilOL - _ -> unitOL $ UBFM (OpReg w r) - (OpReg w r) - (OpImm (ImmInt 0)) - (OpImm $ ImmInt $ widthInBits w' - 1) + W32 -> nilOL + W16 -> trunc UXTH + W8 -> trunc UXTB + _ -> panic "truncateSubwordReg:unexpectedWidth" + where + trunc instr = do + unitOL $ instr (OpReg W32 r) (OpReg W32 r) -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -2352,7 +2372,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` + truncateSubwordRegInplace 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 +2382,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 + truncateSubwordRegInplace w hi -- Can't handle > 64 bit operands | otherwise -> unsupported (MO_S_Mul2 w) PrimTarget (MO_U_Mul2 w) @@ -2412,7 +2432,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 + truncateSubwordRegInplace w lo ) | otherwise -> unsupported (MO_U_Mul2 w) PrimTarget (MO_Clz w) @@ -2898,6 +2918,7 @@ genCCall target dest_regs arg_regs = do passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + -- readResults gpArgs fpArgs dest_regs reg_acc code_acc readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock) readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do @@ -2915,7 +2936,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,44 @@ +{-# LANGUAGE MagicHash #-} + +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, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b2345656cb37458a6a47534373299... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36b2345656cb37458a6a47534373299... 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