Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 36f76098 by Andreas Klebinger at 2026-07-17T13:02:30+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. - - - - - 4 changed files: - + changelog.d/T27430 - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - testsuite/tests/codeGen/should_run/T27430.hs - 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/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 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 +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 truncateRegInplace 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] + 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)) @@ -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) <- truncateReg from 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 + 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 @@ -1897,17 +1898,35 @@ 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@ +-- | 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_from w_to r = do + case w_to of + W64 -> noop + W32 + | w_from == W32 -> noop + | otherwise -> trunc MOV + W16 -> trunc UXTH + W8 -> trunc UXTB + _ -> panic "truncateReg:unexpectedWidth" + where + noop = return (r, nilOL) + trunc instr = do + r' <- getNewRegNat (intFormat w_to) + return (r', unitOL $ instr (OpReg W32 r') (OpReg W32 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) @@ -2898,6 +2917,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 +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 ===================================== @@ -1,5 +1,4 @@ {-# 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 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -296,4 +296,4 @@ test('aarch64-sxtw-run', multi_compile_and_run, ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O']) -test('T27430', [req_c], compile_and_run, ['T27430_c.c']) +test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36f760980d3f44cefc2358cd099013a8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36f760980d3f44cefc2358cd099013a8... 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