diff options
Diffstat (limited to 'testsuite')
7 files changed, 273 insertions, 0 deletions
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs b/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs new file mode 100644 index 0000000000..7d1d78324a --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -fbyte-code #-} + +module ByteCode where + +import GHC.Exts +import GHC.Word +import GHC.Int +import Types + +#include "Common.hs-incl" diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl b/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl new file mode 100644 index 0000000000..fdce7ec7db --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl @@ -0,0 +1,117 @@ + + +d1w8 :: Word8 -> D1 +d1w8 (W8# x) = D1w8 x + +d1i8 :: Int8 -> D1 +d1i8 (I8# x) = D1i8 x + +d1w16 :: Word16 -> D1 +d1w16 (W16# x) = D1w16 x + +d1i16 :: Int16 -> D1 +d1i16 (I16# x) = D1i16 x + +d1w32 :: Word32 -> D1 +d1w32 (W32# x) = D1w32 x + +d1i32 :: Int32 -> D1 +d1i32 (I32# x) = D1i32 x + +showD1 :: D1 -> String +showD1 (D1w8 x) = show (W8# x) +showD1 (D1i8 x) = show (I8# x) +showD1 (D1w16 x) = show (W16# x) +showD1 (D1i16 x) = show (I16# x) +showD1 (D1w32 x) = show (W32# x) +showD1 (D1i32 x) = show (I32# x) + +d2a :: Word8 -> Word8 -> D2 +d2a (W8# x1) (W8# x2) = D2a x1 x2 + +d2b :: Word8 -> Word16 -> D2 +d2b (W8# x1) (W16# x2) = D2b x1 x2 + +d2c :: Word8 -> Word16 -> Word8 -> D2 +d2c (W8# x1) (W16# x2) (W8# x3)= D2c x1 x2 x3 + +d2d :: Word -> Word8 -> Word -> D2 +d2d (W# x1) (W8# x2) (W# x3) = D2d x1 x2 x3 + +d2e :: Word -> Int8 -> Double -> Float -> Word8 -> D2 +d2e (W# x1) (I8# x2) (D# x3) (F# x4) (W8# x5) = D2e x1 x2 x3 x4 x5 + +d2l :: Int -> D2 +d2l 0 = D2a (wordToWord8# 44##) (wordToWord8# 55##) +d2l 1 = D2b (wordToWord8# 44##) (wordToWord16# 55##) +d2l 2 = D2c (wordToWord8# 44##) (wordToWord16# 5555##) (wordToWord8# 66##) +d2l 3 = D2d 5555## (wordToWord8# 66##) 7777## +d2l _ = D2e 7777## (intToInt8# 66#) 55.55## 44.44# (wordToWord8# 33##) + +showD2 :: D2 -> String +showD2 (D2a x1 x2) = show (W8# x1, W8# x2) +showD2 (D2b x1 x2) = show (W8# x1, W16# x2) +showD2 (D2c x1 x2 x3) = show (W8# x1, W16# x2, W8# x3) +showD2 (D2d x1 x2 x3) = show (W# x1, W8# x2, W# x3) +showD2 (D2e x1 x2 x3 x4 x5) = show (W# x1, I8# x2, D# x3, F# x4, W8# x5) + +-- unboxed function arguments + +type F1 = Int8# -> Float# -> Word16# -> Double# -> Word32# -> Word8# -> (Int8, Float, Word16, Double, Word32, Word8) + +f1 :: F1 +f1 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x6) + +f1a :: Word8# -> F1 +f1a x0 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x0) + +f1a_app :: (Word8# -> F1) -> F1 +f1a_app f = f (wordToWord8# 77##) + +f1_show :: F1 -> String +f1_show f = show $ f (intToInt8# 123#) + 456.789# + (wordToWord16# 8765##) + 123.456## + (wordToWord32# 12345678##) + (wordToWord8# 33##) + + +-- unboxed return values of various sizes + +type U1 = Int8 -> Int8# +unboxed1 :: U1 +unboxed1 0 = intToInt8# 11# +unboxed1 _ = intToInt8# 13# + +unboxed1_a :: U1 -> Int8 -> Int8 +unboxed1_a f x = case f x of x1 -> I8# x1 + + +type U2 = Word16 -> Word16# +unboxed2 :: U2 +unboxed2 0 = wordToWord16# 1111## +unboxed2 _ = wordToWord16# 1333## + +unboxed2_a :: U2 -> Word16 -> Word16 +unboxed2_a f x = case f x of x1 -> W16# x1 + + +type U3 = Word16 -> Float# +unboxed3 :: U3 +unboxed3 0 = 55.55# +unboxed3 _ = 77.77# + +unboxed3_a :: U3 -> Word16 -> Float +unboxed3_a f x = case f x of x1 -> F# x1 + +-- unboxed tuple + +type T1 = Int -> (# Int8#, Word16#, Float#, Int #) + +tuple1 :: T1 +tuple1 x = (# intToInt8# 66#, wordToWord16# 7777##, 99.99#, x #) + +tuple1_a :: T1 -> Int -> (Int8, Word16, Float, Int) +tuple1_a f x = + case f x of (# x1, x2, x3, x4 #) -> (I8# x1, W16# x2, F# x3, x4) diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs b/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs new file mode 100644 index 0000000000..54edad5075 --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Obj where + +import GHC.Exts +import GHC.Word +import GHC.Int +import Types + +#include "Common.hs-incl" diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs new file mode 100644 index 0000000000..898ced4b90 --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_GHC -fbyte-code #-} + +{- + Test constructor packing in GHCi with unboxed fields of various sizes + -} + +module Main where + +import qualified Obj as O +import qualified ByteCode as B + +import GHC.Exts +import GHC.Word + +main :: IO () +main = do + + -- pack a single field + testX "D1w8" B.showD1 O.showD1 B.d1w8 O.d1w8 (\f -> f 33) + testX "D1i8" B.showD1 O.showD1 B.d1i8 O.d1i8 (\f -> f 33) + testX "D1w16" B.showD1 O.showD1 B.d1w16 O.d1w16 (\f -> f 3333) + testX "D1i16" B.showD1 O.showD1 B.d1i16 O.d1i16 (\f -> f 3333) + testX "D1w32" B.showD1 O.showD1 B.d1w32 O.d1w32 (\f -> f 33333333) + testX "D1i32" B.showD1 O.showD1 B.d1i32 O.d1i32 (\f -> f 33333333) + + -- pack multiple fields + testX "D2a" B.showD2 O.showD2 B.d2a O.d2a (\f -> f 44 55) + testX "D2b" B.showD2 O.showD2 B.d2b O.d2b (\f -> f 44 55) + testX "D2c" B.showD2 O.showD2 B.d2c O.d2c (\f -> f 44 5555 66) + testX "D2d" B.showD2 O.showD2 B.d2d O.d2d (\f -> f 5555 66 7777) + testX "D2e" B.showD2 O.showD2 B.d2e O.d2e (\f -> f 7777 66 55.55 44.44 33) + + -- pack multiple fields from literals + testX "D2l 0" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 0) + testX "D2l 1" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 1) + testX "D2l 2" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 2) + testX "D2l 3" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 3) + testX "D2l 4" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 4) + + -- function arguments, not packed + testX' "f1 " B.f1_show O.f1_show B.f1 O.f1 + testX' "f1a" B.f1_show O.f1_show (B.f1a_app B.f1a) (B.f1a_app B.f1a) + testX' "f1b" B.f1_show O.f1_show (B.f1a_app O.f1a) (B.f1a_app B.f1a) + testX' "f1c" B.f1_show O.f1_show (O.f1a_app B.f1a) (B.f1a_app B.f1a) + testX' "f1d" B.f1_show O.f1_show (O.f1a_app O.f1a) (B.f1a_app B.f1a) + + -- unboxed return values and tuples + testX'' "unboxed1 0" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 0) + testX'' "unboxed1 1" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 1) + + testX'' "unboxed2 0" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 0) + testX'' "unboxed2 1" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 1) + + testX'' "unboxed3 0" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 0) + testX'' "unboxed3 1" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 1) + + testX'' "tuple1" B.tuple1_a O.tuple1_a B.tuple1 O.tuple1 (\f -> f 3) + + +testX :: (Eq a, Show a) + => String -> (p -> a) -> (p -> a) -> f -> f -> (f -> p) -> IO () +testX msg a1 a2 b1 b2 ap = + let (r:rs) = [f (ap g) | f <- [a1,a2], g <- [b1,b2]] + in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r) + +testX' :: String -> (f -> String) -> (f -> String) -> f -> f -> IO () +testX' msg a1 a2 b1 b2 = + let (r:rs) = [f g | f <- [a1,a2], g <- [b1,b2]] + in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r) + +testX'' :: (Eq a, Show a) + => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO () +testX'' msg a1 a2 b1 b2 ap = + let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]] + in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r) diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.stdout b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.stdout new file mode 100644 index 0000000000..533ef77cd2 --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.stdout @@ -0,0 +1,28 @@ +D1w8 True "33" +D1i8 True "33" +D1w16 True "3333" +D1i16 True "3333" +D1w32 True "33333333" +D1i32 True "33333333" +D2a True "(44,55)" +D2b True "(44,55)" +D2c True "(44,5555,66)" +D2d True "(5555,66,7777)" +D2e True "(7777,66,55.55,44.44,33)" +D2l 0 True "(44,55)" +D2l 1 True "(44,55)" +D2l 2 True "(44,5555,66)" +D2l 3 True "(5555,66,7777)" +D2l 4 True "(7777,66,55.55,44.44,33)" +f1 True "(123,456.789,8765,123.456,12345678,33)" +f1a True "(123,456.789,8765,123.456,12345678,77)" +f1b True "(123,456.789,8765,123.456,12345678,77)" +f1c True "(123,456.789,8765,123.456,12345678,77)" +f1d True "(123,456.789,8765,123.456,12345678,77)" +unboxed1 0 True 11 +unboxed1 1 True 13 +unboxed2 0 True 1111 +unboxed2 1 True 1333 +unboxed3 0 True 55.55 +unboxed3 1 True 77.77 +tuple1 True (66,7777,99.99,3)
\ No newline at end of file diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs b/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs new file mode 100644 index 0000000000..9b1f1f5a9e --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Types where + +import GHC.Exts +import GHC.Int +import GHC.Word + +data D1 = D1w8 Word8# + | D1i8 Int8# + | D1w16 Word16# + | D1i16 Int16# + | D1w32 Word32# + | D1i32 Int32# + +data D2 = D2a Word8# Word8# + | D2b Word8# Word16# + | D2c Word8# Word16# Word8# + | D2d Word# Word8# Word# + | D2e Word# Int8# Double# Float# Word8# diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T b/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T new file mode 100644 index 0000000000..4bf55043fc --- /dev/null +++ b/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T @@ -0,0 +1,10 @@ +test('PackedDataCon', + [ extra_files(['Obj.hs', 'ByteCode.hs', 'Types.hs', 'Common.hs-incl']), + req_interp, + extra_ways(['ghci']), + when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])), + when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof'])) + ], + compile_and_run, + [''] + ) |