diff options
author | Michal Terepeta <michal.terepeta@gmail.com> | 2018-10-04 13:56:59 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-10-07 18:36:07 -0400 |
commit | 5d5307f943d7581d7013ffe20af22233273fba06 (patch) | |
tree | ec9ae993cfa44d2cfe797e0422eb388933277100 /testsuite/tests | |
parent | e4bec29cb475b7e1431dad41fb8d4438814641c9 (diff) | |
download | haskell-5d5307f943d7581d7013ffe20af22233273fba06.tar.gz |
Add Int8# and Word8#
This is the first step of implementing:
https://github.com/ghc-proposals/ghc-proposals/pull/74
The main highlights/changes:
- `primops.txt.pp` gets two new sections for two new primitive types
for signed and unsigned 8-bit integers (`Int8#` and `Word8`
respectively) along with basic arithmetic and comparison
operations. `PrimRep`/`RuntimeRep` get two new constructors for
them. All of the primops translate into the existing `MachOP`s.
- For `CmmCall`s the codegen will now zero-extend the values at call
site (so that they can be moved to the right register) and then
truncate them back their original width.
- x86 native codegen needed some updates, since it wasn't able to deal
with the new widths, but all the changes are quite localized. LLVM
backend seems to just work.
Bumps binary submodule.
Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: ./validate with new tests
Reviewers: hvr, goldfire, bgamari, simonmar
Subscribers: Abhiroop, dfeuer, rwbarton, thomie, carter
Differential Revision: https://phabricator.haskell.org/D4475
Diffstat (limited to 'testsuite/tests')
18 files changed, 691 insertions, 0 deletions
diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.hs b/testsuite/tests/ffi/should_run/PrimFFIInt8.hs new file mode 100644 index 0000000000..4124e074aa --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_int8" + add_all_int8 + :: Int8# -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# + +main :: IO () +main = do + let a = narrowInt8# 0# + b = narrowInt8# 1# + c = narrowInt8# 2# + d = narrowInt8# 3# + e = narrowInt8# 4# + f = narrowInt8# 5# + g = narrowInt8# 6# + h = narrowInt8# 7# + i = narrowInt8# 8# + j = narrowInt8# 9# + x = I# (extendInt8# (add_all_int8 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout b/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c new file mode 100644 index 0000000000..dc51687530 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +int8_t add_all_int8( + int8_t a, int8_t b, int8_t c, int8_t d, int8_t e, + int8_t f, int8_t g, int8_t h, int8_t i, int8_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.hs b/testsuite/tests/ffi/should_run/PrimFFIWord8.hs new file mode 100644 index 0000000000..87e46636d1 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_word8" + add_all_word8 + :: Word8# -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# + +main :: IO () +main = do + let a = narrowWord8# 0## + b = narrowWord8# 1## + c = narrowWord8# 2## + d = narrowWord8# 3## + e = narrowWord8# 4## + f = narrowWord8# 5## + g = narrowWord8# 6## + h = narrowWord8# 7## + i = narrowWord8# 8## + j = narrowWord8# 9## + x = W# (extendWord8# (add_all_word8 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout b/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c new file mode 100644 index 0000000000..535ed4185c --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +uint8_t add_all_word8( + uint8_t a, uint8_t b, uint8_t c, uint8_t d, uint8_t e, + uint8_t f, uint8_t g, uint8_t h, uint8_t i, uint8_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index fd0af7ebc3..9223b3d1b3 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -188,3 +188,7 @@ test('ffi023', [ omit_ways(['ghci']), test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c']) test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c']) + +test('PrimFFIInt8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt8_c.c']) + +test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c']) diff --git a/testsuite/tests/primops/should_run/ArithInt8.hs b/testsuite/tests/primops/should_run/ArithInt8.hs new file mode 100644 index 0000000000..77f4cea21a --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt8.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Int8# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allInt8 + ] + expected = + [ toInt8 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Int8# on the stack" input expected actual + + -- + -- negateInt8# + -- + let input = allInt8 + expected = [ toInt8 (negate a) | a <- input ] + actual = [ apply1 negateInt8# a | a <- input ] + checkResults "negateInt8#" input expected actual + + -- + -- plusInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a + b) | (a, b) <- input ] + actual = [ apply2 plusInt8# a b | (a, b) <- input ] + checkResults "plusInt8#" input expected actual + + -- + -- subInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a - b) | (a, b) <- input ] + actual = [ apply2 subInt8# a b | (a, b) <- input ] + checkResults "subInt8#" input expected actual + + -- + -- timesInt8# + -- + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + expected = [ toInt8 (a * b) | (a, b) <- input ] + actual = [ apply2 timesInt8# a b | (a, b) <- input ] + checkResults "timesInt8#" input expected actual + + -- + -- remInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + -- Don't divide by 0 or cause overflow + , b /= 0, not (a == -128 && b == -1) + ] + expected = [ toInt8 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remInt8# a b | (a, b) <- input ] + checkResults "remInt8#" input expected actual + + -- + -- quotInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + , b /= 0, not (a == -128 && b == -1) + ] + expected = [ toInt8 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotInt8# a b | (a, b) <- input ] + checkResults "quotInt8#" input expected actual + + -- + -- quotRemInt8# + -- + let input = + [ (a, b) | a <- allInt8, b <- allInt8 + , b /= 0, not (a == -128 && b == -1) + ] + expected = + [ (toInt8 q, toInt8 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemInt8# a b | (a, b) <- input ] + checkResults "quotRemInt8#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allInt8 :: [Int] +allInt8 = [ minInt8 .. maxInt8 ] + +minInt8 :: Int +minInt8 = fromIntegral (minBound :: Int8) + +maxInt8 :: Int +maxInt8 = fromIntegral (maxBound :: Int8) + +toInt8 :: Int -> Int +toInt8 a = fromIntegral (fromIntegral a :: Int8) + +addMany# + :: Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# -> Int8# -> Int8# -> Int8# + -> Int8# +addMany# a b c d e f g h i j k l m n o p = + a `plusInt8#` b `plusInt8#` c `plusInt8#` d `plusInt8#` + e `plusInt8#` f `plusInt8#` g `plusInt8#` h `plusInt8#` + i `plusInt8#` j `plusInt8#` k `plusInt8#` l `plusInt8#` + m `plusInt8#` n `plusInt8#` o `plusInt8#` p +{-# NOINLINE addMany# #-} + +addMany + :: Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int + -> Int +addMany (I# a) (I# b) (I# c) (I# d) + (I# e) (I# f) (I# g) (I# h) + (I# i) (I# j) (I# k) (I# l) + (I# m) (I# n) (I# o) (I# p) + = I# (extendInt8# int8) + where + !int8 = addMany# + (narrowInt8# a) (narrowInt8# b) (narrowInt8# c) (narrowInt8# d) + (narrowInt8# e) (narrowInt8# f) (narrowInt8# g) (narrowInt8# h) + (narrowInt8# i) (narrowInt8# j) (narrowInt8# k) (narrowInt8# l) + (narrowInt8# m) (narrowInt8# n) (narrowInt8# o) (narrowInt8# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Int8# +apply1 :: (Int8# -> Int8#) -> Int -> Int +apply1 opToTest (I# a) = I# (extendInt8# (opToTest (narrowInt8# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Int8# -> Int8# -> Int8#) -> Int -> Int -> Int +apply2 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #) + r = opToTest sa sb + in I# (extendInt8# r) +{-# NOINLINE apply2 #-} + +apply3 :: (Int8# -> Int8# -> (# Int8#, Int8# #)) -> Int -> Int -> (Int, Int) +apply3 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #) + (# ra, rb #) = opToTest sa sb + in (I# (extendInt8# ra), I# (extendInt8# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithInt8.stdout b/testsuite/tests/primops/should_run/ArithInt8.stdout new file mode 100644 index 0000000000..16990fb3c5 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt8.stdout @@ -0,0 +1,8 @@ +Pass: passing Int8# on the stack +Pass: negateInt8# +Pass: plusInt8# +Pass: subInt8# +Pass: timesInt8# +Pass: remInt8# +Pass: quotInt8# +Pass: quotRemInt8# diff --git a/testsuite/tests/primops/should_run/ArithWord8.hs b/testsuite/tests/primops/should_run/ArithWord8.hs new file mode 100644 index 0000000000..ceac789878 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord8.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Word +import Data.Bits +import Data.List +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Word8# on the stack works (16 parameter function will + -- need to use stack for some of the them) + -- + let input = + [ ( (a + 0), (a + 1), (a + 2), (a + 3), + (a + 4), (a + 5), (a + 6), (a + 7), + (a + 8), (a + 9), (a + 10), (a + 11), + (a + 12), (a + 13), (a + 14), (a + 15) ) + | a <- allWord8 + ] + expected = + [ toWord8 + (a + b + c + d + e + f + g + h + + i + j + k + l + m + n + o + p) + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + actual = + [ addMany a b c d e f g h i j k l m n o p + | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input + ] + checkResults "passing Word8# on the stack" input expected actual + + -- + -- notWord8# + -- + let input = allWord8 + expected = [ toWord8 (complement a) | a <- input ] + actual = [ apply1 notWord8# a | a <- input ] + checkResults "notWord8#" input expected actual + + -- + -- plusWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a + b) | (a, b) <- input ] + actual = [ apply2 plusWord8# a b | (a, b) <- input ] + checkResults "plusWord8#" input expected actual + + -- + -- subWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a - b) | (a, b) <- input ] + actual = [ apply2 subWord8# a b | (a, b) <- input ] + checkResults "subWord8#" input expected actual + + -- + -- timesWord8# + -- + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + expected = [ toWord8 (a * b) | (a, b) <- input ] + actual = [ apply2 timesWord8# a b | (a, b) <- input ] + checkResults "timesWord8#" input expected actual + + -- + -- remWord8# + -- + let input = + -- Don't divide by 0. + [ (a, b) | a <- allWord8, b <- allWord8 , b /= 0 ] + expected = [ toWord8 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remWord8# a b | (a, b) <- input ] + checkResults "remWord8#" input expected actual + + -- + -- quotWord8# + -- + let input = + [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ] + expected = [ toWord8 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotWord8# a b | (a, b) <- input ] + checkResults "quotWord8#" input expected actual + + -- + -- quotRemWord8# + -- + let input = + [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ] + expected = + [ (toWord8 q, toWord8 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemWord8# a b | (a, b) <- input ] + checkResults "quotRemWord8#" input expected actual + + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allWord8 :: [Word] +allWord8 = [ minWord8 .. maxWord8 ] + +minWord8 :: Word +minWord8 = fromIntegral (minBound :: Word8) + +maxWord8 :: Word +maxWord8 = fromIntegral (maxBound :: Word8) + +toWord8 :: Word -> Word +toWord8 a = fromIntegral (fromIntegral a :: Word8) + +addMany# + :: Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# -> Word8# -> Word8# -> Word8# + -> Word8# +addMany# a b c d e f g h i j k l m n o p = + a `plusWord8#` b `plusWord8#` c `plusWord8#` d `plusWord8#` + e `plusWord8#` f `plusWord8#` g `plusWord8#` h `plusWord8#` + i `plusWord8#` j `plusWord8#` k `plusWord8#` l `plusWord8#` + m `plusWord8#` n `plusWord8#` o `plusWord8#` p +{-# NOINLINE addMany# #-} + +addMany + :: Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word -> Word -> Word -> Word + -> Word +addMany (W# a) (W# b) (W# c) (W# d) + (W# e) (W# f) (W# g) (W# h) + (W# i) (W# j) (W# k) (W# l) + (W# m) (W# n) (W# o) (W# p) + = W# (extendWord8# word8) + where + !word8 = + addMany# + (narrowWord8# a) (narrowWord8# b) (narrowWord8# c) (narrowWord8# d) + (narrowWord8# e) (narrowWord8# f) (narrowWord8# g) (narrowWord8# h) + (narrowWord8# i) (narrowWord8# j) (narrowWord8# k) (narrowWord8# l) + (narrowWord8# m) (narrowWord8# n) (narrowWord8# o) (narrowWord8# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Word8# +apply1 :: (Word8# -> Word8#) -> Word -> Word +apply1 opToTest (W# a) = W# (extendWord8# (opToTest (narrowWord8# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Word8# -> Word8# -> Word8#) -> Word -> Word -> Word +apply2 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #) + r = opToTest sa sb + in W# (extendWord8# r) +{-# NOINLINE apply2 #-} + +apply3 + :: (Word8# -> Word8# -> (# Word8#, Word8# #)) -> Word -> Word -> (Word, Word) +apply3 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #) + (# ra, rb #) = opToTest sa sb + in (W# (extendWord8# ra), W# (extendWord8# rb)) +{-# NOINLINE apply3 #-} + +instance + (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, + Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) + => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) == + (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && + e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && + i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && + m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2 + +instance + (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, + Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p) + => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = + "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ + "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++ + "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ + "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++ + ")" diff --git a/testsuite/tests/primops/should_run/ArithWord8.stdout b/testsuite/tests/primops/should_run/ArithWord8.stdout new file mode 100644 index 0000000000..b745ea0a48 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord8.stdout @@ -0,0 +1,8 @@ +Pass: passing Word8# on the stack +Pass: notWord8# +Pass: plusWord8# +Pass: subWord8# +Pass: timesWord8# +Pass: remWord8# +Pass: quotWord8# +Pass: quotRemWord8# diff --git a/testsuite/tests/primops/should_run/CmpInt8.hs b/testsuite/tests/primops/should_run/CmpInt8.hs new file mode 100644 index 0000000000..daea22701d --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt8.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Int +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Int8# +data TestInt8 = T8 Int8# + deriving (Eq, Ord) + +mkT8 :: Int -> TestInt8 +mkT8 (I# a) = T8 (narrowInt8# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allInt8, b <- allInt8 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT8 a == mkT8 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT8 a /= mkT8 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT8 a < mkT8 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT8 a > mkT8 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT8 a <= mkT8 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT8 a >= mkT8 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allInt8 :: [Int] +allInt8 = [ minInt8 .. maxInt8 ] + +minInt8 :: Int +minInt8 = fromIntegral (minBound :: Int8) + +maxInt8 :: Int +maxInt8 = fromIntegral (maxBound :: Int8) diff --git a/testsuite/tests/primops/should_run/CmpInt8.stdout b/testsuite/tests/primops/should_run/CmpInt8.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt8.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/CmpWord8.hs b/testsuite/tests/primops/should_run/CmpWord8.hs new file mode 100644 index 0000000000..101f7837b5 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord8.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Word +import Data.List +import GHC.Prim +import GHC.Exts + + +-- Having a wrapper gives us two things: +-- * it's easier to test everything (no need for code using raw primops) +-- * we test the deriving mechanism for Word8# +data TestWord8 = T8 Word8# + deriving (Eq, Ord) + +mkT8 :: Word -> TestWord8 +mkT8 (W# a) = T8 (narrowWord8# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allWord8, b <- allWord8 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT8 a == mkT8 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT8 a /= mkT8 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT8 a < mkT8 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT8 a > mkT8 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT8 a <= mkT8 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT8 a >= mkT8 b | (a, b) <- input ] + checkResults "(>=)" input expected actual + +checkResults + :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO () +checkResults test inputs expected actual = + case findIndex (\(e, a) -> e /= a) (zip expected actual) of + Nothing -> putStrLn $ "Pass: " ++ test + Just i -> error $ + "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i) + ++ " expected: " ++ show (expected !! i) + ++ " but got: " ++ show (actual !! i) + +allWord8 :: [Word] +allWord8 = [ minWord8 .. maxWord8 ] + +minWord8 :: Word +minWord8 = fromIntegral (minBound :: Word8) + +maxWord8 :: Word +maxWord8 = fromIntegral (maxBound :: Word8) diff --git a/testsuite/tests/primops/should_run/CmpWord8.stdout b/testsuite/tests/primops/should_run/CmpWord8.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord8.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs new file mode 100644 index 0000000000..5670032f4a --- /dev/null +++ b/testsuite/tests/primops/should_run/ShowPrim.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts + +data Test = Test Int8# Word8# + deriving (Show) + +test1 :: Test +test1 = Test (narrowInt8# 1#) (narrowWord8# 2##) + +main :: IO () +main = print test1 diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout new file mode 100644 index 0000000000..5720effb8b --- /dev/null +++ b/testsuite/tests/primops/should_run/ShowPrim.stdout @@ -0,0 +1 @@ +Test (narrowInt8# 1#) (narrowWord8# 2##) diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index 742206d93d..ecf995bea8 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -17,3 +17,8 @@ test('T10678', compile_and_run, ['-O']) test('T11296', normal, compile_and_run, ['']) test('T13825-compile', normal, compile_and_run, ['']) +test('ArithInt8', omit_ways(['ghci']), compile_and_run, ['']) +test('ArithWord8', omit_ways(['ghci']), compile_and_run, ['']) +test('CmpInt8', normal, compile_and_run, ['']) +test('CmpWord8', normal, compile_and_run, ['']) +test('ShowPrim', normal, compile_and_run, ['']) |