Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC Commits: 69d5ca17 by Andreas Klebinger at 2026-08-24T13:21:00+00:00 arm64 ncg: The big subword truncation fix. A set of slightly related fixes to arm subword handling: Bitmask immediates: Don't produce overflowing assembly literals. There is still another bug here that causes us to miss some valid literals but we will fix that later. Improve subword truncation handling: We now use a small set of helpers to truncate `Register` values rather than truncating immediate `Reg` values which greatly simplifies the code structure. This fixes a great many bugs to do with sign/zero extending subwords or the lack thereof. We now establish the invariant that subword values are zero-extended at every site at which they come into "scope" of the ncg, and rely on the invariant throughout rather than pessimistically inserting redundant extensions in a hodgepodge manner at the use sites of these values. This fixes at least the bugs described in issues #27533, #27430 #27537, #27538, #27539, and #27550. But likely more bugs yet not found. Subword ffi results: Apply truncations when calling functions returning subword values. genCondJump: Don't sign extend signed values in the input register as it might map to a local variable, corrupting the value stored within. 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. - - - - - e996a6de by Andreas Klebinger at 2026-08-24T13:21:03+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 #27565. - - - - - 4dd69a45 by Andreas Klebinger at 2026-08-24T13:21:03+00:00 Add some test cases covering bugs in the arm ncg. * Test for #27430 (subword ffi results) * #27537 - subword conversions * #27538 - subwords used in conditional * #27533 - single byte read - - - - - 746a43e3 by Andreas Klebinger at 2026-08-24T13:21:03+00:00 cmmLint: Lint against MO_FS_Truncate subword use. - - - - - 26 changed files: - + changelog.d/arm_ncg_fixes_T27430 - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr - − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - + 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/T27533.hs - + testsuite/tests/codeGen/should_run/T27533.stdout - + testsuite/tests/codeGen/should_run/T27533_cmm.cmm - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - 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: ===================================== changelog.d/arm_ncg_fixes_T27430 ===================================== @@ -0,0 +1,18 @@ +section: compiler +issues: #27430 #27539 #27538 #27537 #27550 #27565 #27533 +mrs: !16255 +synopsis: + A series of fixes to the ARM64 ncg, related to handling of primitive + 8/16bit types and simd. +description: + A series of related fixes to the ncg fixing: + + Fixed sign extension for subword values returned from unsafe ffi calls. + Clarify and lint for invalid conversions of int8/int16 -> float/double conversions. + Fix incorrect clobbering of local variables when comparing signed subword values. + Fix incorrect use of 32bit reads/stores for 8/16bit wide reads/stores. + Fix zero extension on function entry if arguments are passed at word-width + but used at subword-widths. + Fix broadcast# for non-literal arguments (arm64 only). + Fix rare assembler errors caused by overflowing literals, by properly checking + whether a constant is a viable immediate argument. ===================================== compiler/GHC/Cmm/Expr.hs ===================================== @@ -445,8 +445,8 @@ pprExpr platform e -- | `op` usually, but `(op[width])` with -dppr-debug withDebugWidth :: Width -> SDoc -> SDoc -withDebugWidth w exp = - ifPprDebug (parens (exp <> brackets (ppr w))) exp +withDebugWidth w doc = + ifPprDebug (parens (doc <> brackets (ppr w))) doc -- Here's the precedence table from GHC.Cmm.Parser: -- %nonassoc '>=' '>' '<=' '<' '!=' '==' ===================================== compiler/GHC/Cmm/Lint.hs ===================================== @@ -113,7 +113,7 @@ 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 +-- We require every address value to be word-sized since we don't support 32 -- bit pointers on 64bit platforms. lintAddrTy :: CmmExpr -> CmmType -> CmmLint () lintAddrTy e addr_ty = do ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -142,8 +142,8 @@ 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_FS_Truncate Width Width -- Float -> Signed int + | MO_SF_Round Width Width -- Signed int -> Float, but only W32/W64 inputs + | MO_FS_Truncate Width Width -- Float -> Signed int, only W32/W64 on the int side. | MO_SS_Conv Width Width -- Signed int -> Signed int | MO_UU_Conv Width Width -- unsigned int -> unsigned int | MO_XX_Conv Width Width -- int -> int; puts no requirements on the @@ -623,7 +623,9 @@ machOpArgReps platform op = MO_XX_Conv from _ -> Just [from] -- Only supports W32/W64 MO_SF_Round from _w -> onlyW32W64 from - MO_FS_Truncate from _ -> onlyW32W64 from + MO_FS_Truncate from to + | to `notElem` [W32, W64] -> Nothing + | otherwise -> onlyW32W64 from MO_FF_Conv from _ -> onlyW32W64 from MO_WF_Bitcast w -> onlyW32W64 w MO_FW_Bitcast w -> onlyW32W64 w ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -746,7 +746,7 @@ stmt :: { CmmParse () } | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' { doCall $6 $2 $8 } -- NB: bool_expr most be a *boolean* expression: A comparison machOp or 1/0 word literals. - -- We don't allow arbitrary expressions as conditions (See checkCond, #27543). + -- We don't allow arbitrary expressions as conditions (See GHC.Cmm.Lint.checkCond:checkCond, #27543). | 'if' bool_expr cond_likely 'goto' NAME { do l <- lookupLabel $5; cmmRawIf $2 l $3 } | 'if' bool_expr cond_likely '{' body '}' else ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -356,13 +356,10 @@ type InstrBlock -- data Register = Fixed Format Reg InstrBlock + -- ^ It can be unsafe to clobber the result reg, as it might map to a + -- local variable. | 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 + -- ^ A destination the caller decides, prevents redundant moves -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg @@ -370,8 +367,9 @@ getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) - = case globalRegMaybe platform mid of +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid ty)) + = assert (formatInBytes (cmmTypeFormat ty) >= 4) $ + case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) -- By this stage, the only MagicIds remaining should be the @@ -382,11 +380,17 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) -- ----------------------------------------------------------------------------- -- 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` value into a concrete 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 + someReg r + +someReg :: Register -> NatM (Reg, Format, InstrBlock) +someReg r = case r of Any rep code -> do tmp <- getNewRegNat rep @@ -647,28 +651,38 @@ opRegWidth W16 = W32 -- w opRegWidth W8 = W32 -- w opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) --- Note [Signed arithmetic on AArch64] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Handling signed arithmetic on sub-word-size values on AArch64 is a bit --- tricky as Cmm's type system does not capture signedness. While 32-bit values --- are fairly easy to handle due to AArch64's 32-bit instruction variants --- (denoted by use of %wN registers), 16- and 8-bit values require quite some --- care. +-- Note [Subword operations on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Handling subword operations on AArch64 is a bit tricky. 32-bit values are fairly +-- easy to handle due to AArch64's 32-bit instruction variants. 16- and 8-bit +-- values require quite some care. The platform doesn't provide operations at +-- widths below 32bit. Which means we have to simulate them using wider operations. +-- Signed arithmetic on sub-word-size values on AArch64 is a bit tricky as Cmm's +-- type system does not capture signedness. If we have a 8 bit value the high +-- bits could be sign or zero extended with no easy way to tell. -- --- We handle 16-and 8-bit values by using the 32-bit operations and +-- To work around this handle 16-and 8-bit values by using the 32-bit operations and -- sign-/zero-extending operands and truncate results as necessary. For -- simplicity we maintain the invariant that a register containing a -- sub-word-size value always contains the zero-extended form of that value -- 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 --- 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 --- to the upper bits of its input (e.g. unsigned right shift, unsigned --- division) must explicitly zero- or sign-extend its operands rather than --- assuming they are already extended. +-- Concretely we establish this invariant on every input into the function for which +-- we generate code for in the NCG. This means: +-- * Global STG register access +-- * memory reads +-- * function arguments +-- * ffi results +-- * function call results +-- * results from any subexpression +-- +-- This means we can assume the invariant when generated code for expression trees +-- or machops reading local variables, avoiding (some) redundant extensions. But +-- we have to take great care to uphold the invariant when computing new values. +-- +-- We used to do the inverse. Re-establish the invariant for any operation that +-- is sensitive to values in the high bits. But that turned out to produce worse +-- code and wasn't any less likely to result in new bugs in practice. -- -- For instance, consider the program, -- @@ -688,7 +702,10 @@ 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. +-- +-- Down the line I think the right way to approach this is to operate more over +-- the `Register` type and store sign extension information inside it. -- -- TODO: -- Don't use Width in Operands @@ -925,20 +942,36 @@ getRegister' config plat expr getRegister (CmmLoad e (cmmBits w) NaturallyAligned) CmmMachOp op [e] -> do - (reg, _format, code) <- getSomeReg e + register <- getRegister e + (reg, _format, code) <- someReg register case op of - MO_Not w -> return $ Any (intFormat w) $ \dst -> + -- XX Conversion + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_XX_Conv from to + | to >= from -> pure $ swizzleRegisterRep register (intFormat to) + | otherwise -> pure $ truncateSubwordRegister to register + + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_Not w -> return $ truncateSubwordRegister w $ Any (intFormat w) $ \dst -> 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] + MVN (OpReg w' dst) (OpReg w' reg) + + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_S_Neg w -> truncateSubwordRegister w <$> do + let op_w = opRegWidth w + (src, _fmt, reg_code) <- someReg $ signExtendRegister w op_w register + pure $ Any (intFormat w) $ \dst -> reg_code `snocOL` (NEG (intFormat w) (OpReg op_w dst) (OpReg op_w src)) - 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)) where fmt = floatFormat w - MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) - MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) + MO_SF_Round from to -> + massert (from >= W32) >> + return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + MO_FS_Truncate from to -> + massert (to >= W32) >> + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) -- TODO this is very hacky -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ @@ -951,11 +984,8 @@ getRegister' config plat expr MO_FW_Bitcast w -> return $ Any fmt (\dst -> code `snocOL` FMOV fmt (OpReg w dst) (OpReg w reg)) where fmt = intFormat w - -- Conversions - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e - -- 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)) @@ -1054,26 +1084,13 @@ getRegister' config plat expr toImm W256 = (OpImm (ImmInt 255)) toImm W512 = (OpImm (ImmInt 511)) - -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits - -- See Note [Signed arithmetic on AArch64]. - negate code w reg = do - let w' = opRegWidth w - fmt = intFormat w - (reg', code_sx) <- signExtendReg w w' reg - return $ Any fmt $ \dst -> - code `appOL` - code_sx `snocOL` - NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL` - truncateReg w' w dst - ss_conv from to reg code = let w' = opRegWidth (max from to) - 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 + in return $ truncateSubwordRegister to $ Any (intFormat to) $ \dst -> + code `snocOL` + SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) + -- At this point an 8- or 16-bit value is sign-extended -- to 32-bits. Truncate back down the final width. - truncateReg w' to dst -- Dyadic machops: -- @@ -1090,26 +1107,14 @@ getRegister' config plat expr CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' -- Immediates are handled via `getArithImm` in the generic code path. - CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16-> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y - tmp_x <- getNewRegNat (intFormat w) - tmp_y <- getNewRegNat (intFormat w) - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w tmp_x) (OpReg w reg_x)) `snocOL` - (UXTB (OpReg w tmp_y) (OpReg w reg_y)) `snocOL` - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y))) - CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y - tmp_x <- getNewRegNat (intFormat w) - tmp_y <- getNewRegNat (intFormat w) - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w tmp_x) (OpReg w reg_x)) `snocOL` - (UXTH (OpReg w tmp_y) (OpReg w reg_y)) `snocOL` - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y))) + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) -- 2. Shifts. x << n, x >> n. -- Sub-word left shifts by a constant: use UBFM (UBFIZ alias) to shift - -- and mask in a single instruction. See Note [Signed arithmetic on AArch64]. + -- and mask in a single instruction. See Note [Subword operations on AArch64]. CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFM (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger ((32 - n) `mod` 32))) (OpImm (ImmInteger (7 - n))))) @@ -1126,7 +1131,7 @@ getRegister' config plat expr CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))) - `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y @@ -1135,12 +1140,12 @@ getRegister' config plat expr tmp <- getNewRegNat (intFormat w) return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w tmp) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL` - (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))) - `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y @@ -1149,7 +1154,7 @@ getRegister' config plat expr tmp <- getNewRegNat (intFormat w) return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w tmp) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL` - (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32 || w == W64 @@ -1182,14 +1187,14 @@ getRegister' config plat expr return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) -- 3. Logic &&, || - CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> - return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w -> + return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') op_bitmask)) where fmt = intFormat w w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg - CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> - return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w -> + return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') op_bitmask)) where fmt = intFormat w w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg @@ -1220,16 +1225,17 @@ 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]. - intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) - intOpImm {- is signed -} True w op _encode_imm = intOp True w op - intOpImm False w op encode_imm = do + -- See Note [Subword operations on AArch64]. + intOpImm :: Bool -> SetsHighBits -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) + intOpImm {- is signed -} True trunc w op _encode_imm = intOp True trunc w op + intOpImm False trunc w op encode_imm = maintainHighBits trunc w <$> do -- 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,40 +1247,29 @@ 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 + op (OpReg w' dst) (OpReg w' reg_x) (op_y) -- A (potentially signed) integer operation. -- 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]. - intOp is_signed w op = do + -- See Note [Subword operations on AArch64]. + intOp is_signed clean_highbits w op = maintainHighBits clean_highbits w <$> do -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o> - (reg_x, format_x, code_x) <- getSomeReg x - (reg_y, format_y, code_y) <- getSomeReg y + let op_w = opRegWidth w + let setHighBits = if is_signed then signExtendRegister w (opRegWidth w) else id + (reg_x_sx, format_x, code_x) <- someReg =<< setHighBits <$> getRegister x + (reg_y_sx, format_y, code_y) <- someReg =<< setHighBits <$> getRegister y 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 - signExt r - | not is_signed = return (r, nilOL) - | otherwise = signExtendReg w w' r - (reg_x_sx, code_x_sx) <- signExt reg_x - (reg_y_sx, code_y_sx) <- signExt reg_y + return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` - -- sign-extend both operands - 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 + op (OpReg op_w dst) (OpReg op_w reg_x_sx) (OpReg op_w reg_y_sx) floatOp w op = do (reg_fx, format_x, code_fx) <- getFloatReg x @@ -1465,9 +1460,9 @@ getRegister' config plat expr case op of -- Integer operations -- Add/Sub should only be Integer Options. - MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm + MO_Add w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm -- TODO: Handle sub-word case - MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm + MO_Sub w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm -- Note [CSET] -- ~~~~~~~~~~~ @@ -1513,9 +1508,9 @@ getRegister' config plat expr MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm -- Signed multiply/divide - MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL (intFormat w) d x y) + MO_Mul w -> intOp True UnknownHighBits w (\d x y -> unitOL $ MUL (intFormat w) d x y) MO_S_MulMayOflo w -> do_mul_may_oflo w x y - MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV (intFormat w) d x y) + MO_S_Quot w -> intOp True UnknownHighBits w (\d x y -> unitOL $ SDIV (intFormat w) d x y) -- No native rem instruction. So we'll compute the following -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry @@ -1525,24 +1520,24 @@ getRegister' config plat expr -- '--------------------------' -- Note the swap in Rx and Ry. MO_S_Rem w -> withTempIntReg w $ \t -> - intOp True w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ]) + intOp True UnknownHighBits w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ]) -- Unsigned multiply/divide - MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) + MO_U_Quot w -> intOp False CleanHighBits w (\d x y -> unitOL $ UDIV d x y) MO_U_Rem w -> withTempIntReg w $ \t -> - intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) + intOp False CleanHighBits w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) -- Signed comparisons -- see Note [CSET] - MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ]) - MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ]) - MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ]) - MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) + MO_S_Ge w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGE ]) + MO_S_Le w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLE ]) + MO_S_Gt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGT ]) + MO_S_Lt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLT ]) -- Unsigned comparisons - MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm - MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm - MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm - MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm + MO_U_Ge w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm + MO_U_Le w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm + MO_U_Gt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm + MO_U_Lt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm -- Floating point arithmetic MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD (floatFormat w) d x y) @@ -1570,9 +1565,9 @@ getRegister' config plat expr MO_And w -> bitOpImm w (\d x y -> unitOL $ AND (intFormat w) d x y) getBitmaskImm MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR (intFormat w) d x y) getBitmaskImm MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR (intFormat w) d x y) getBitmaskImm - MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y) - MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y) - MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y) + MO_Shl w -> intOp False UnknownHighBits w (\d x y -> unitOL $ LSL d x y) + MO_U_Shr w -> intOp False CleanHighBits w (\d x y -> unitOL $ LSR d x y) + MO_S_Shr w -> intOp True UnknownHighBits w (\d x y -> unitOL $ ASR d x y) -- Vector operations MO_V_Add l w -> intVecOp l w (\fmt d x y -> unitOL $ ADD fmt d x y) @@ -1630,7 +1625,7 @@ getRegister' config plat expr _ -> pprPanic "Unsupported offset" (pdoc platform y) (reg_x, format_x, code_x) <- getSomeReg x massertPpr (isVecFormat format_x) $ text "MO_V_Extract: non-vector" - -- Always use UMOV. See Note [Signed arithmetic on AArch64] + -- Always use UMOV. See Note [Subword operations on AArch64] return $ Any format (\dst -> code_x `snocOL` UMOV (OpReg w dst) (OpVecLane w reg_x index)) MO_VF_Extract l w -> do @@ -1759,7 +1754,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) @@ -1886,36 +1881,87 @@ isAArch64Bitmask width n = hasOneRun m = 64 == popCount m + countLeadingZeros m + countTrailingZeros m +-------------------------------------------------------------------------------- +-- Helpers to help enforcing Note [Subword operations on AArch64] +-------------------------------------------------------------------------------- + -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@. -signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) -signExtendReg w w' r = - case w of - W64 -> noop - W32 - | w' == W32 -> noop - | otherwise -> extend SXTW - W16 -> extend SXTH - W8 -> extend SXTB - _ -> panic "intOp" +signExtendInstr :: Width -> Width -> Reg -> Maybe (Reg -> Instr) +signExtendInstr w w' r = + case (w,w') of + (W64,_) -> Nothing + (W32,W32) -> Nothing + (W32,_) -> extend SXTW + (W16,_) -> extend SXTH + (W8 ,_) -> extend SXTB + _ -> panic "signExtendInstr:unexpectedWidth" + where + extend instr = Just $ \r' -> instr (OpReg w' r') (OpReg w r) + +-- | Sign extend the register if needed, otherwise use register as-is +signExtendRegister :: Width -> Width -> Register -> Register +signExtendRegister w w' register = case register of + Fixed _fmt reg code -> + maybe register + (\instr_ext -> Any (intFormat w') (\dst -> code `snocOL` instr_ext dst) ) + (signExtendInstr w w' reg) + Any _fmt code -> + Any (intFormat w') $ \dst -> + maybe (code dst) + (\instr_ext -> code dst `snocOL` instr_ext dst) + (signExtendInstr w w' dst) + +truncSubwordRegInstr :: Width -> Reg -> Maybe (Reg -> Instr) +truncSubwordRegInstr w_to r = + case w_to of + -- Asserted false, but be defensive for non-debug builds. + W64 -> Nothing + W32 -> Nothing + + -- Actual truncation + W16 -> trunc W32 UXTH + W8 -> trunc W32 UXTB + _ -> panic "truncateSubwordReg: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 + trunc w instr = do + Just $ \r' -> instr (OpReg w r') (OpReg w r) + +-- | Like @truncateSubwordRegister@, but modifes the given 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 "truncateSubwordRegInplace:unexpectedWidth" + where + trunc instr = do + unitOL $ instr (OpReg W32 r) (OpReg W32 r) + +-- | Zeros the high words of the value represented by Register if needed according to +-- Note [Subword operations on AArch64] +truncateSubwordRegister :: Width -> Register -> Register +truncateSubwordRegister w register = case register of + Fixed _fmt reg code -> + maybe (swizzleRegisterRep register (intFormat w)) + (\r_instr -> Any (intFormat w) (\dst -> code `snocOL` r_instr dst)) + (truncSubwordRegInstr w reg) + Any _fmt code -> Any (intFormat w) $ \dst -> + maybe (code dst) (\r_inst -> code dst `snocOL` r_inst dst) (truncSubwordRegInstr w dst) + +data SetsHighBits = UnknownHighBits | CleanHighBits + +maintainHighBits :: SetsHighBits -> Width -> Register -> Register +maintainHighBits CleanHighBits _w x = x +maintainHighBits UnknownHighBits w x = truncateSubwordRegister w x + +-- Reinterpret the value in the register as different format. +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -2038,27 +2084,24 @@ genCondJump bid expr = do -- Generic case. CmmMachOp mop [x, y] -> do - let ubcond 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 [ 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))) ] - - sbcond w cmp = do - -- compute both sides. - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y + let icond is_signed w cmp = do + -- zero or sign extend the argument register(s) + let extend reg = + if is_signed + then someReg $ signExtendRegister w (opRegWidth w) reg + else someReg reg + + (reg_x, _format_x, code_x) <- extend =<< getRegister x + (reg_y, _format_y, code_y) <- extend =<< getRegister 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))) ] + + return $ concatOL [code_x, code_y, + toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]] + + let ubcond w cmp = icond False w cmp + sbcond w cmp = icond True w cmp fbcond w cmp = do -- ensure we get float regs @@ -2327,32 +2370,27 @@ genCCall target dest_regs arg_regs = do , [src_a, src_b] <- arg_regs , [dst_needed, dst_hi, dst_lo] <- dest_regs -> do - (reg_a', _format_x, code_a) <- getSomeReg src_a - (reg_b', _format_y, code_b) <- getSomeReg src_b + -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm). + -- sign extension always allocates a fresh temp for w < W32, + -- and is a noop for W32 (safe: SMULL reads both sources + -- atomically before writing the destination). + (reg_a, _format_x, code_a) <- someReg =<< signExtendRegister w W32 <$> getRegister src_a + (reg_b, _format_y, code_b) <- someReg =<< signExtendRegister w W32 <$> getRegister src_b let lo = getRegisterReg platform (CmmLocal dst_lo) hi = getRegisterReg platform (CmmLocal dst_hi) nd = getRegisterReg platform (CmmLocal dst_needed) w' = platformWordWidth platform - -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm). - -- signExtendReg always allocates a fresh temp for w < W32, - -- and is a noop for W32 (safe: SMULL reads both sources - -- atomically before writing the destination). - (reg_a, code_a') <- signExtendReg w W32 reg_a' - (reg_b, code_b') <- signExtendReg w W32 reg_b' - return $ code_a `appOL` - code_b `appOL` - code_a' `appOL` - code_b' `snocOL` + code_b `snocOL` -- SMULL Xd, Wn, Wm: multiply two W32 values producing a -- 64-bit result. The low w bits of lo contain the truncated -- 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 +2400,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) @@ -2385,7 +2423,7 @@ genCCall target dest_regs arg_regs = do ) -- For sizes < platform width, we can just perform a multiply and shift -- Need to be careful to truncate the low half, but the upper half should be - -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained. + -- be ok if the invariant in Note [Subword operations on AArch64] is maintained. -- Currently this case can't be produced by the compiler since -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #) -- TODO: Remove? Or would the extra primop be useful for avoiding the extra @@ -2412,7 +2450,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) @@ -2730,6 +2768,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 @@ -2845,6 +2884,7 @@ genCCall target dest_regs arg_regs = do W16 -> SXTH (OpReg W64 gpReg) (OpReg w r) _ -> panic "impossible" | otherwise + -- Relies on Note [Subword operations on AArch64] = MOV (OpReg w gpReg) (OpReg w r) accumCode' = accumCode `appOL` code_r `snocOL` @@ -2898,6 +2938,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 +2956,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 + -- Needed, ffi calls can return garbage in high bits. + -- See Note [Subword operations on AArch64] + 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 ===================================== 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 subword ops via b/h suffix on the instruction. + -- We handle this here relying on the format rather than 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/cmm/should_compile/Makefile ===================================== @@ -16,16 +16,3 @@ T16930: T23610: '$(TEST_HC)' $(TEST_HC_OPTS) T23610.cmm -S - -# The three seds below, in order: -# 1. Keep only the "Parsed Cmm" dump, since that is the one stage where the -# unreachable block still exists. -# 2. Rewrite goto targets: their label uniques survive -dsuppress-uniques -# (#21310). -# 3. Drop the "// CmmAssign"-style node annotations, which pprNode emits -# only on DEBUG compilers. -T27368-ppr-debug: - '$(TEST_HC)' $(TEST_HC_OPTS) -c -no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug -dsuppress-uniques -dsuppress-ticks T27368-ppr-debug.cmm 2>&1 \ - | sed -n '/^==* Parsed Cmm/,/^ \}\]/p' \ - | sed 's/goto c[0-9A-Za-z]*/goto _lbl_/g' \ - | sed 's| *// Cmm[A-Za-z]*$$||' ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr ===================================== @@ -0,0 +1,191 @@ + +==================== Parsed Cmm ==================== +[testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + goto c6; + c6: // global + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + goto c3; + c3: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + // unreachable blocks: + c5: // global + //tick src<T27368-ppr-debug.cmm:13:5-13> + _c1::I64 = _c1::I64 (+[W64]) 42; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + } + }] + + + +==================== Post control-flow optimisations (1) ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== Post switch plan ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== ThreadSanitizer instrumentation ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== Layout Stack ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== CAFEnv ==================== +[(c2, {}), (c4, {}), (c7, {})] + + + +==================== after setInfoTableStackMap ==================== +testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } +} + + + +==================== Post control-flow optimisations (2) ==================== +testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } +} + + + +==================== Post CPS Cmm ==================== +[testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } + }] + + ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout deleted ===================================== @@ -1,27 +0,0 @@ -==================== Parsed Cmm ==================== -[testUnreachable() { // [R1] - { info_tbls: [] - stack_info: arg_space: 8 - } - {offset - _lbl_: - __locVar_::I64 = R1; - if (__locVar_::I64 (>[W64]) 0) goto _lbl_; else goto _lbl_; - _lbl_: - goto _lbl_; - _lbl_: - __locVar_::I64 = __locVar_::I64 (-[W64]) 1; - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - _lbl_: - goto _lbl_; - _lbl_: - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - // unreachable blocks: - _lbl_: - __locVar_::I64 = __locVar_::I64 (+[W64]) 42; - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - } - }] ===================================== testsuite/tests/cmm/should_compile/all.T ===================================== @@ -13,11 +13,9 @@ test('T20725', normal, compile, ['-package ghc']) test('T23610', normal, makefile_test, ['T23610']) test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1]), only_ways(['normal'])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques']) test('T24474', cmm_src, compile, ['-optc-g3']) -# -dppr-debug makes stored-but-unreachable blocks visible in Cmm dumps (#27368). -# Skipped on wordsize(32) targets, where the dump would say I32/P32, and on -# unregisterised builds, which print call targets with an extra load. -test('T27368-ppr-debug', [when(wordsize(32), skip), when(unregisterised(), skip)], - makefile_test, ['T27368-ppr-debug']) +# Grep for a `... = + .. 42 ..;` occurence from within the dead code block in the cmm dump output. +test('T27368-ppr-debug', [cmm_src, only_ways(['normal']), grep_errmsg(r'\=.*\+.*(42;)', [1])], + compile, ['-no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug']) test('T24474-cmm-gets-c-opts', cmm_src, compile, ['-optc-DFOO']) test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO ' '-optCmmP-UFOO ' ===================================== 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; } +uint16_t u64_to_u16(uint64_t v) { return (uint16_t)v; } +uint32_t u64_to_u32(uint64_t v) { return (uint32_t)v; } ===================================== testsuite/tests/codeGen/should_run/T27533.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes #-} + +import GHC.Exts +import GHC.IO (IO(..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Ptr (Ptr(..)) +import Data.Word (Word8) +import Numeric (showHex) +import System.IO + +foreign import prim "store8" store8# :: Addr# -> Word# +foreign import prim "load8" load8# :: Addr# -> Word# + +-- Read one byte at a given byte offset. Working a byte at a time keeps the +-- test independent of both endianness and word size: the buffer contents are +-- a fixed sequence of bytes in address order, whereas a word-sized read of +-- the same buffer would give 0x..43 on little-endian and 0x43.. on big-endian. +readByte :: Addr# -> Int -> IO Word +readByte a (I# i) = + IO (\s -> case readWord8OffAddr# a i s of + (# s', v #) -> (# s', W# (word8ToWord# v) #)) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + allocaBytes 8 $ \p@(Ptr a) -> do + -- 1. Silent corruption: release-store of 1 byte into an all-ones buffer. + -- The store must touch byte 0 and leave bytes 1..7 alone; a buggy NCG + -- widens it to a 4-byte store and zeroes bytes 1..3. + fillBytes p (0xFF :: Word8) 8 + case store8# a of _ -> return () -- case on unlifted Word# forces the call + bs <- mapM (readByte a) [0 .. 7] + putStrLn ("after 1-byte release-store: " ++ unwords (map (\b -> showHex b "") bs)) + -- expected 43 ff ff ff ff ff ff ff + -- buggy NCG gives 43 0 0 0 ff ff ff ff + + -- 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: 43 ff ff ff ff ff ff ff +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/T27537.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE lt8 #-} +lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1 +lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eq8 #-} +eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1 +eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eqi16 #-} +eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1 +eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n)))) + +{-# NOINLINE rem8 #-} +rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54 +rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))) + +main :: IO () +main = do + print (lt8 (-2) 255) + print (eq8 (-2) 254) + print (eqi16 (-2) 65534) + print (rem8 (-2) 100) ===================================== testsuite/tests/codeGen/should_run/T27537.stdout ===================================== @@ -0,0 +1,4 @@ +1 +1 +1 +54 ===================================== testsuite/tests/codeGen/should_run/T27538.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE ix #-} +ix :: Int +ix = 0 + +{-# NOINLINE f #-} +f :: Int8# -> Int# +f x = if isTrue# (x `ltInt8#` intToInt8# 0#) + then (int8ToWord8# x) `gtWord8#` wordToWord8# 200## + else 1# + +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/T27538.stdout ===================================== @@ -0,0 +1 @@ +f(0x80) = 0 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -295,3 +295,12 @@ 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']) + +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/92a88f55d52a4e729b32d9c355fb452... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92a88f55d52a4e729b32d9c355fb452... 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