[Git][ghc/ghc][wip/T23726] 2 commits: nativeGen/AArch64: Fix sign extension in MulMayOflo

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/T23726 at Glasgow Haskell Compiler / GHC


Commits:
e995abb0 by Ben Gamari at 2023-07-25T13:07:10-04:00
nativeGen/AArch64: Fix sign extension in MulMayOflo

When evaluating MulMayOflo of a product of sub-word-size operands,
we must

Fixes #23721.

- - - - -
82ef316a by Ben Gamari at 2023-07-25T14:08:02-04:00
hihih

- - - - -


1 changed file:

- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs


Changes:

=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1003,7 +1003,7 @@ getRegister' config plat expr
 
     -- N.B. MUL does not set the overflow flag.
     do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    do_mul_may_oflo w at W64 x y = do
+    do_mul_may_oflo W64 x y = do
         (reg_x, _format_x, code_x) <- getSomeReg x
         (reg_y, _format_y, code_y) <- getSomeReg y
         lo <- getNewRegNat II64
@@ -1015,31 +1015,44 @@ getRegister' config plat expr
             SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`
             CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`
             CSET (OpReg w dst) NE)
+
+    do_mul_may_oflo W32 x y
+        (reg_x, _format_x, code_x) <- getSomeReg x
+        (reg_y, _format_y, code_y) <- getSomeReg y
+        tmp1 <- getNewRegNat II64
+        tmp2 <- getNewRegNat II64
+        return $ Any (intFormat w) (\dst ->
+            code_x `appOL`
+            code_y `snocOL`
+            SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL`
+            ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL`
+            CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL`
+            CSET (OpReg W32 dst) NE)
+
     do_mul_may_oflo w x y = do
         (reg_x, _format_x, code_x) <- getSomeReg x
         (reg_y, _format_y, code_y) <- getSomeReg y
-        let tmp_w = case w of
-                      W32 -> W64
-                      W16 -> W32
-                      W8  -> W32
-                      _   -> panic "do_mul_may_oflo: impossible"
-        -- This will hold the product
-        tmp <- getNewRegNat (intFormat tmp_w)
-        let ext_mode = case w of
-                         W32 -> ESXTW
-                         W16 -> ESXTH
-                         W8  -> ESXTB
-                         _   -> panic "do_mul_may_oflo: impossible"
-            mul = case w of
-                    W32 -> SMULL
-                    W16 -> MUL
-                    W8  -> MUL
-                    _   -> panic "do_mul_may_oflo: impossible"
+        tmp1 <- getNewRegNat II32
+        tmp2 <- getNewRegNat II32
+        let extend dst arg =
+              case w of
+                W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg)
+                W8  -> SXTB (OpReg W32 dst) (OpReg W32 arg)
+            width = widthInBits w
+            cmp_ext_mode =
+              case w of
+                W16 -> EUXTH
+                W8  -> EUXTB
+
         return $ Any (intFormat w) (\dst ->
             code_x `appOL`
             code_y `snocOL`
-            mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`
-            CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`
+            extend tmp1 reg_x `snocOL`
+            extend tmp2 reg_y `snocOL`
+            MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL`
+            SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm $ ImmInt $ width - 1) 1 `snocOL`
+            UBFM (OpReg W64 tmp1) (OpReg W64 tmp1) (OpImm $ ImmInt width) (OpImm $ ImmInt width) `snocOL`
+            CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL`
             CSET (OpReg w dst) NE)
 
 -- | Is a given number encodable as a bitmask immediate?



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fc952a273a9d81af5f742afc52a9acb58fdcbb57...82ef316a107c0618cfd6870a880eaf0f860e6f64

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fc952a273a9d81af5f742afc52a9acb58fdcbb57...82ef316a107c0618cfd6870a880eaf0f860e6f64
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230725/d4bbd3eb/attachment-0001.html>