[Git][ghc/ghc][wip/andreask/32bit_cmp_fix] Test NCG 64bit comparisons
Andreas Klebinger
gitlab at gitlab.haskell.org
Tue Nov 3 14:11:29 UTC 2020
Andreas Klebinger pushed to branch wip/andreask/32bit_cmp_fix at Glasgow Haskell Compiler / GHC
Commits:
db555fe7 by Andreas Klebinger at 2020-11-03T15:11:11+01:00
Test NCG 64bit comparisons
- - - - -
4 changed files:
- 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:
=====================================
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/db555fe7b256e2728f914cc654338ed8e84121e2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db555fe7b256e2728f914cc654338ed8e84121e2
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/20201103/155a40c7/attachment-0001.html>
More information about the ghc-commits
mailing list