[Git][ghc/ghc][wip/andreask/32bit_cmp_fix] 2 commits: Testsuite: Support for user supplied package dbs
Andreas Klebinger
gitlab at gitlab.haskell.org
Mon Nov 2 14:18:45 UTC 2020
Andreas Klebinger pushed to branch wip/andreask/32bit_cmp_fix at Glasgow Haskell Compiler / GHC
Commits:
755d56b7 by Andreas Klebinger at 2020-11-02T14:22:36+01:00
Testsuite: Support for user supplied package dbs
We can now supply additional package dbs to the testsuite.
For make the package db can be supplied by
passing PACKAGE_DB=/path/to/db.
In the testsuite driver it's passed via the --test-package-db
argument.
- - - - -
092d1eea by Andreas Klebinger at 2020-11-02T15:15:14+01:00
Test 64bit comparison codegen
- - - - -
6 changed files:
- testsuite/driver/runtests.py
- testsuite/driver/testlib.py
- testsuite/mk/test.mk
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/cmm/should_run/cmp64.hs
- + testsuite/tests/cmm/should_run/cmp64_cmm.cmm
Changes:
=====================================
testsuite/driver/runtests.py
=====================================
@@ -71,6 +71,7 @@ parser.add_argument("--junit", type=argparse.FileType('wb'), help="output testsu
parser.add_argument("--broken-test", action="append", default=[], help="a test name to mark as broken for this run")
parser.add_argument("--test-env", default='local', help="Override default chosen test-env.")
parser.add_argument("--perf-baseline", type=GitRef, metavar='COMMIT', help="Baseline commit for performance comparsons.")
+parser.add_argument("--test-package-db", dest="test_package_db", action="append", help="Package db providing optional packages used by the testsuite.")
perf_group.add_argument("--skip-perf-tests", action="store_true", help="skip performance tests")
perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
@@ -104,6 +105,8 @@ config.summary_file = args.summary_file
config.no_print_summary = args.no_print_summary
config.baseline_commit = args.perf_baseline
+config.test_package_db = args.test_package_db
+
if args.only:
config.only = args.only
config.run_only_some_tests = True
=====================================
testsuite/driver/testlib.py
=====================================
@@ -165,7 +165,16 @@ def have_library(lib: str) -> bool:
got_it = have_lib_cache[lib]
else:
cmd = strip_quotes(config.ghc_pkg)
- p = subprocess.Popen([cmd, '--no-user-package-db', 'describe', lib],
+ cmd_line = [cmd, '--no-user-package-db']
+
+ for db in config.test_package_db:
+ cmd_line.append("--package-db="+db)
+
+ cmd_line.extend(['describe', lib])
+
+ print(cmd_line)
+
+ p = subprocess.Popen(cmd_line,
stdout=subprocess.PIPE,
stderr=subprocess.PIPE,
env=ghc_env)
@@ -181,6 +190,10 @@ def have_library(lib: str) -> bool:
def _reqlib( name, opts, lib ):
if not have_library(lib):
opts.expect = 'missing-lib'
+ else:
+ opts.extra_hc_opts = opts.extra_hc_opts + ' -package ' + lib + ' '
+ for db in config.test_package_db:
+ opts.extra_hc_opts = opts.extra_hc_opts + ' -package-db=' + db + ' '
def req_haddock( name, opts ):
if not config.haddock:
=====================================
testsuite/mk/test.mk
=====================================
@@ -216,6 +216,10 @@ ifneq "$(THREADS)" ""
RUNTEST_OPTS += --threads=$(THREADS)
endif
+ifneq "$(PACKAGE_DB)" ""
+RUNTEST_OPTS += --test-package-db=$(PACKAGE_DB)
+endif
+
ifneq "$(VERBOSE)" ""
RUNTEST_OPTS += --verbose=$(VERBOSE)
endif
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -2,3 +2,20 @@ test('HooplPostorder',
extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
+
+test('cmp64',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , reqlib('primitive')
+ , 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,160 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+#ifdef __GLASGOW_HASKELL__
+#include "MachDeps.h"
+#endif
+
+import Data.Primitive.ByteArray
+import GHC.Types
+import GHC.Exts
+import Data.Word
+import Data.Int
+import Data.Bits
+import Control.Monad
+import Unsafe.Coerce
+
+#if WORD_SIZE_IN_BITS < 64
+#define INT64 Int64#
+#define WORD64 Word64#
+#else
+#define INT64 Int#
+#define WORD64 Word#
+#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 ()
+
+
+-- Moving values int Int64# / Word64# is currently
+-- quite annoying. The only way to do this on both
+-- 64 and 32bit platforms is to go through a byte
+-- array.
+
+getInts :: Int64 -> Int64 -> IO ( I64, I64 )
+getInts a1 a2 = do
+ mba@(MutableByteArray ba) <- newPinnedByteArray 16
+ writeByteArray mba 0 a1
+ writeByteArray mba 1 a2
+ i1 <- readInt 0 ba
+ i2 <- readInt 1 ba
+ return ( i1, i2 )
+
+getWords :: Word64 -> Word64 -> IO ( W64, W64 )
+getWords a1 a2 = do
+ mba@(MutableByteArray ba) <- newPinnedByteArray 16
+ writeByteArray mba 0 a1
+ writeByteArray mba 1 a2
+ w1 <- readWord 0 ba :: IO W64
+ w2 <- readWord 1 ba
+ return ( w1, w2 )
+
+readInt :: Int -> MutableByteArray# RealWorld -> IO I64
+readInt (I# i) ba = IO $ \s ->
+ case (readInt64Array# ba i s) of
+ (# s', x #) -> (# s', I64 x #)
+
+readWord :: Int -> MutableByteArray# RealWorld -> IO W64
+readWord (I# i) ba = IO $ \s ->
+ case (readWord64Array# ba i s) of
+ (# s', x #) -> (# s', W64 x #)
=====================================
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/-/compare/55dd45fdbb7afa88e56b1290deb6f2588adc8fad...092d1eeafe6f24b5fab1ff7c4aff622331677717
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55dd45fdbb7afa88e56b1290deb6f2588adc8fad...092d1eeafe6f24b5fab1ff7c4aff622331677717
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/20201102/d06f6932/attachment-0001.html>
More information about the ghc-commits
mailing list