[Git][ghc/ghc][wip/ghc-8.10-backports] NCG: Fix 64bit int comparisons on 32bit x86
Ben Gamari
gitlab at gitlab.haskell.org
Wed Nov 18 21:22:50 UTC 2020
Ben Gamari pushed to branch wip/ghc-8.10-backports at Glasgow Haskell Compiler / GHC
Commits:
410b43a2 by Andreas Klebinger at 2020-11-18T16:22:35-05:00
NCG: Fix 64bit int comparisons on 32bit x86
We no compare these by doing 64bit subtraction and
checking the resulting flags.
We used to do this differently but the old approach was
broken when the high bits compared equal and the comparison
was one of >= or <=.
The new approach should be both correct and faster.
(cherry picked from commit bb100805337adc666867da300ee5b0b11c18fe00)
(cherry picked from commit fda3e50b559f6f25347f9ad7239e5003e27937b0)
- - - - -
6 changed files:
- compiler/nativeGen/X86/CodeGen.hs
- compiler/nativeGen/X86/Cond.hs
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/cmm/should_run/cmp64.hs
- + testsuite/tests/cmm/should_run/cmp64.stdout
- + testsuite/tests/cmm/should_run/cmp64_cmm.cmm
Changes:
=====================================
compiler/nativeGen/X86/CodeGen.hs
=====================================
@@ -1804,6 +1804,35 @@ I386: First, we have to ensure that the condition
codes are set according to the supplied comparison operation.
-}
+{- Note [64-bit integer comparisons on 32-bit]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ When doing these comparisons there are 2 kinds of
+ comparisons.
+
+ * Comparison for equality (or lack thereof)
+
+ We use xor to check if high/low bits are
+ equal. Then combine the results using or and
+ perform a single conditional jump based on the
+ result.
+
+ * Other comparisons:
+
+ We map all other comparisons to the >= operation.
+ Why? Because it's easy to encode it with a single
+ conditional jump.
+
+ We do this by first computing [r1_lo - r2_lo]
+ and use the carry flag to compute
+ [r1_high - r2_high - CF].
+
+ At which point if r1 >= r2 then the result will be
+ positive. Otherwise negative so we can branch on this
+ condition.
+
+-}
+
genCondBranch
:: BlockId -- the source of the jump
@@ -1821,22 +1850,63 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
-> NatM InstrBlock
-- 64-bit integer comparisons on 32-bit
+-- See Note [64-bit integer comparisons on 32-bit]
genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
| is32Bit, Just W64 <- maybeIntComparison mop = do
- ChildCode64 code1 r1_lo <- iselExpr64 e1
- ChildCode64 code2 r2_lo <- iselExpr64 e2
- let r1_hi = getHiVRegFromLo r1_lo
- r2_hi = getHiVRegFromLo r2_lo
- cond = machOpToCond mop
- Just cond' = maybeFlipCond cond
- --TODO: Update CFG for x86
- let code = code1 `appOL` code2 `appOL` toOL [
- CMP II32 (OpReg r2_hi) (OpReg r1_hi),
- JXX cond true,
- JXX cond' false,
- CMP II32 (OpReg r2_lo) (OpReg r1_lo),
- JXX cond true] `appOL` genBranch false
- return code
+
+ -- The resulting registers here are both the lower part of
+ -- the register as well as a way to get at the higher part.
+ ChildCode64 code1 r1 <- iselExpr64 e1
+ ChildCode64 code2 r2 <- iselExpr64 e2
+ let cond = machOpToCond mop :: Cond
+
+ let cmpCode = intComparison cond true false r1 r2
+ return $ code1 `appOL` code2 `appOL` cmpCode
+
+ where
+ intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock
+ intComparison cond true false r1_lo r2_lo =
+ case cond of
+ -- Impossible results of machOpToCond
+ ALWAYS -> panic "impossible"
+ NEG -> panic "impossible"
+ POS -> panic "impossible"
+ CARRY -> panic "impossible"
+ OFLO -> panic "impossible"
+ PARITY -> panic "impossible"
+ NOTPARITY -> panic "impossible"
+ -- Special case #1 x == y and x != y
+ EQQ -> cmpExact
+ NE -> cmpExact
+ -- [x >= y]
+ GE -> cmpGE
+ GEU -> cmpGE
+ -- [x > y] <==> ![y >= x]
+ GTT -> intComparison GE false true r2_lo r1_lo
+ GU -> intComparison GEU false true r2_lo r1_lo
+ -- [x <= y] <==> [y >= x]
+ LE -> intComparison GE true false r2_lo r1_lo
+ LEU -> intComparison GEU true false r2_lo r1_lo
+ -- [x < y] <==> ![x >= x]
+ LTT -> intComparison GE false true r1_lo r2_lo
+ LU -> intComparison GEU false true r1_lo r2_lo
+ where
+ r1_hi = getHiVRegFromLo r1_lo
+ r2_hi = getHiVRegFromLo r2_lo
+ cmpExact :: OrdList Instr
+ cmpExact =
+ toOL
+ [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)
+ , XOR II32 (OpReg r2_lo) (OpReg r1_lo)
+ , OR II32 (OpReg r1_hi) (OpReg r1_lo)
+ , JXX cond true
+ , JXX ALWAYS false
+ ]
+ cmpGE = toOL
+ [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)
+ , SBB II32 (OpReg r2_hi) (OpReg r1_hi)
+ , JXX cond true
+ , JXX ALWAYS false ]
genCondBranch' _ bid id false bool = do
CondCode is_float cond cond_code <- getCondCode bool
=====================================
compiler/nativeGen/X86/Cond.hs
=====================================
@@ -13,22 +13,22 @@ import GhcPrelude
data Cond
= ALWAYS -- What's really used? ToDo
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
- | NEG
- | POS
- | CARRY
- | OFLO
- | PARITY
- | NOTPARITY
+ | EQQ -- je/jz -> zf = 1
+ | GE -- jge
+ | GEU -- ae
+ | GTT -- jg
+ | GU -- ja
+ | LE -- jle
+ | LEU -- jbe
+ | LTT -- jl
+ | LU -- jb
+ | NE -- jne
+ | NEG -- js
+ | POS -- jns
+ | CARRY -- jc
+ | OFLO -- jo
+ | PARITY -- jp
+ | NOTPARITY -- jnp
deriving Eq
condUnsigned :: Cond -> Bool
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -2,3 +2,19 @@ test('HooplPostorder',
extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
+
+test('cmp64',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , omit_ways(['ghci'])
+ , extra_clean('cmp64_cmm.o')
+ ],
+ multi_compile_and_run,
+ ['cmp64', [('cmp64_cmm.cmm', '')], '-O'])
+
+
+# test('T17516',
+# [ collect_compiler_stats('bytes allocated', 5),
+# extra_clean(['T17516A.hi', 'T17516A.o'])
+# ],
+# multimod_compile,
+# ['T17516', '-O -v0'])
\ No newline at end of file
=====================================
testsuite/tests/cmm/should_run/cmp64.hs
=====================================
@@ -0,0 +1,156 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE CPP #-}
+
+{- Test 64bit comparisons.
+ We simply compare a number of values in different ways
+ and print the results. 32bit and 64bit platforms use
+ different code paths so if either one breaks this test
+ should catch it.
+
+-}
+
+module Main where
+
+#if defined(__GLASGOW_HASKELL__)
+#include "MachDeps.h"
+#endif
+
+import GHC.Types
+import GHC.Exts
+import GHC.Word
+import GHC.Int
+import Data.Bits
+import Control.Monad
+import Unsafe.Coerce
+
+#if WORD_SIZE_IN_BITS < 64
+#define INT64 Int64#
+#define WORD64 Word64#
+#define I64CON I64#
+#else
+#define INT64 Int#
+#define WORD64 Word#
+#define I64CON I#
+#endif
+
+
+data I64 = I64 INT64
+data W64 = W64 WORD64
+
+foreign import prim "test_lt" lt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_gt" gt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_le" le_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ge" ge_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_eq" eq_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ne" ne_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_ltu" lt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_gtu" gt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_leu" le_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_geu" ge_u :: WORD64 -> WORD64 -> Int#
+
+wordValues :: [Word64]
+wordValues = do
+ lowerBits <- interestingValues
+ higherBits <- interestingValues
+ return $ (fromIntegral higherBits `shiftL` 32) .|. fromIntegral lowerBits
+
+interestingValues :: [Word32]
+interestingValues =
+ [ 0x00000000
+ , 0x00000001
+ , 0x00000002
+
+ , 0x7FFFFFFD
+ , 0x7FFFFFFE
+ , 0x7FFFFFFF
+
+ , 0xFFFFFFFE
+ , 0xFFFFFFFD
+ , 0xFFFFFFFF
+
+ , 0x80000000
+ , 0x80000001
+ , 0x80000002
+ ]
+
+intValues :: [Int64]
+intValues = map fromIntegral wordValues
+
+intOps :: [(INT64 -> INT64 -> Int#, String)]
+intOps = [(lt_s, "lt_s")
+ ,(gt_s, "gt_s")
+ ,(le_s, "le_s")
+ ,(ge_s, "ge_s")
+
+ ,(eq_s, "eq_s")
+ ,(ne_s, "ne_s")]
+
+testInt :: Int64 -> Int64 -> (INT64 -> INT64 -> Int#) -> String -> IO ()
+testInt x y op op_name = do
+ (I64 w1,I64 w2) <- getInts x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+ return ()
+
+testInts = do
+ let tests = do
+ (op,op_desc) <- intOps
+ x <- intValues
+ y <- intValues
+ return $ testInt x y op op_desc
+ sequence tests
+
+wordOps :: [(WORD64 -> WORD64 -> Int#, String)]
+wordOps = [(lt_u, "lt_u")
+ ,(gt_u, "gt_u")
+ ,(le_u, "le_u")
+ ,(ge_u, "ge_u")]
+
+testWord x y op op_name = do
+ (W64 w1,W64 w2) <- getWords x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+
+testWords = do
+ let tests = do
+ (op,op_desc) <- wordOps
+ x <- wordValues
+ y <- wordValues
+ return $ testWord x y op op_desc
+ sequence tests
+
+main = do
+ testInts
+ testWords
+
+ print "done"
+ print wordValues
+ print intValues
+ return ()
+
+
+-- We want to get a I64#/W64# both and 64 and 32bit platforms.
+-- We unsafeCoerce on 64bit, on 32bit the unboxed argument already
+-- has the right type.
+
+getInts :: Int64 -> Int64 -> IO ( I64, I64 )
+#if WORD_SIZE_IN_BITS < 64
+getInts (I64# a1) (I64# a2) = return (I64 a1, I64 a2)
+#else
+getInts (I64# a1) (I64# a2) = return $ unsafeCoerce# (I64 a1, I64 a2)
+#endif
+
+
+getWords :: Word64 -> Word64 -> IO ( W64, W64 )
+#if WORD_SIZE_IN_BITS < 64
+getWords (W64# a1) (W64# a2) = return (W64 a1, W64 a2)
+#else
+getWords (W64# a1) (W64# a2) = return $ unsafeCoerce# (W64 a1, W64 a2)
+#endif
=====================================
testsuite/tests/cmm/should_run/cmp64.stdout
=====================================
The diff for this file was not included because it is too large.
=====================================
testsuite/tests/cmm/should_run/cmp64_cmm.cmm
=====================================
@@ -0,0 +1,31 @@
+#include "Cmm.h"
+
+#define TEST(name, op) \
+ name (bits64 x, bits64 y) { \
+ if(x `op` y) { \
+ return (1); \
+ } else { \
+ return (0); \
+ } \
+ }
+
+cmm_func_test(bits64 foo, bits64 bar) {
+ return (1);
+}
+
+TEST(test_lt, lt)
+TEST(test_gt, gt)
+
+TEST(test_ne, ne)
+TEST(test_eq, eq)
+
+TEST(test_ge, ge)
+TEST(test_le, le)
+
+TEST(test_geu, geu)
+TEST(test_leu, leu)
+
+TEST(test_ltu, ltu)
+TEST(test_gtu, gtu)
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410b43a29576c40f4a65c9558f080a97c194636c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410b43a29576c40f4a65c9558f080a97c194636c
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/20201118/68bf5558/attachment-0001.html>
More information about the ghc-commits
mailing list