diff options
author | John Ericson <git@JohnEricson.me> | 2019-06-03 23:47:10 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-07 00:11:31 -0500 |
commit | 06982b6cc886d65aa325475ddfb4ad38c69b2d96 (patch) | |
tree | a09811c44dd0e4fd774bc2de3fa10ea34f6409f4 | |
parent | e981023eb1cfb2a0f6052763469252feee3e2d51 (diff) | |
download | haskell-06982b6cc886d65aa325475ddfb4ad38c69b2d96.tar.gz |
Make primops for `{Int,Word}32#`
Progress towards #19026.
The type was added before, but not its primops. We follow the
conventions in 36fcf9edee31513db2ddbf716ee0aa79766cbe69 and
2c959a1894311e59cd2fd469c1967491c1e488f3 for names and testing.
Along with the previous 8- and 16-bit primops, this will allow us to
avoid many conversions for 8-, 16-, and 32-bit sized numeric types.
Co-authored-by: Sylvain Henry <hsyl20@gmail.com>
22 files changed, 843 insertions, 18 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index e9a9e96cee..37a3b33979 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -214,18 +214,16 @@ section "The word size story." represented as {\tt Int\#} and {\tt Word\#}, and the operations implemented in terms of the primops on these types, with suitable range restrictions on the results (using - the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families - of primops. The 32-bit sizes are represented using {\tt - Int\#} and {\tt Word\#} when {\tt WORD\_SIZE\_IN\_BITS} - $\geq$ 32; otherwise, these are represented using distinct - primitive types {\tt Int32\#} and {\tt Word32\#}. These (when - needed) have a complete set of corresponding operations; - however, nearly all of these are implemented as external C - functions rather than as primops. Exactly the same story - applies to the 64-bit sizes. All of these details are hidden + the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families of + primops. The 64-bit sizes are represented using {\tt Int\#} + and {\tt Word\#} when {\tt WORD\_SIZE\_IN\_BITS} $\geq$ 64; + otherwise, these are represented using distinct primitive + types {\tt Int64\#} and {\tt Word64\#}. These (when needed) + have a complete set of corresponding operations; however, + nearly all of these are implemented as external C functions + rather than as primops. All of these details are hidden under the {\tt PrelInt} and {\tt PrelWord} modules, which use - {\tt \#if}-defs to invoke the appropriate types and - operators. + {\tt \#if}-defs to invoke the appropriate types and operators. Word size also matters for the families of primops for indexing/reading/writing fixed-size quantities at offsets @@ -458,9 +456,47 @@ primtype Int32# primop Int32ToIntOp "extendInt32#" GenPrimOp Int32# -> Int# primop IntToInt32Op "narrowInt32#" GenPrimOp Int# -> Int32# +primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32# + +primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32# + +primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + can_fail = True + +primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + can_fail = True + +primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) + with + can_fail = True + +primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# + +primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# + with code_size = 0 + +primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int# +primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int# + ------------------------------------------------------------------------ section "Word32#" - {Operations on 32-bit unsigned integers.} + {Operations on 32-bit unsigned words.} ------------------------------------------------------------------------ primtype Word32# @@ -468,6 +504,52 @@ primtype Word32# primop Word32ToWordOp "extendWord32#" GenPrimOp Word32# -> Word# primop WordToWord32Op "narrowWord32#" GenPrimOp Word# -> Word32# +primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32# + +primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + can_fail = True + +primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + can_fail = True + +primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) + with + can_fail = True + +primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32NotOp "not32Word#" GenPrimOp Word32# -> Word32# + +primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# +primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# + +primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# + with code_size = 0 + +primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int# +primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int# + #if WORD_SIZE_IN_BITS < 64 ------------------------------------------------------------------------ section "Int64#" diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 0cd1463b46..4db3167bd7 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -1517,11 +1517,11 @@ primRepSizeB platform = \case Int8Rep -> 1 Int16Rep -> 2 Int32Rep -> 4 - Int64Rep -> wORD64_SIZE + Int64Rep -> 8 Word8Rep -> 1 Word16Rep -> 2 Word32Rep -> 4 - Word64Rep -> wORD64_SIZE + Word64Rep -> 8 FloatRep -> fLOAT_SIZE DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs index 858d5a4101..1e6add2b46 100644 --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -74,7 +74,7 @@ data Platform = Platform data PlatformWordSize = PW4 -- ^ A 32-bit platform | PW8 -- ^ A 64-bit platform - deriving (Eq) + deriving (Eq, Ord) instance Show PlatformWordSize where show PW4 = "4" diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index ef7b0feddc..afb495e9e7 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1079,6 +1079,8 @@ emitPrimOp dflags primop = case primop of -- The rest just translate straightforwardly + Int32ToWord32Op -> \args -> opNop args + Word32ToInt32Op -> \args -> opNop args IntToWordOp -> \args -> opNop args WordToIntOp -> \args -> opNop args IntToAddrOp -> \args -> opNop args @@ -1269,11 +1271,47 @@ emitPrimOp dflags primop = case primop of Int32ToIntOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform)) IntToInt32Op -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32) + Int32NegOp -> \args -> opTranslate args (MO_S_Neg W32) + Int32AddOp -> \args -> opTranslate args (MO_Add W32) + Int32SubOp -> \args -> opTranslate args (MO_Sub W32) + Int32MulOp -> \args -> opTranslate args (MO_Mul W32) + Int32QuotOp -> \args -> opTranslate args (MO_S_Quot W32) + Int32RemOp -> \args -> opTranslate args (MO_S_Rem W32) + + Int32SllOp -> \args -> opTranslate args (MO_Shl W32) + Int32SraOp -> \args -> opTranslate args (MO_S_Shr W32) + Int32SrlOp -> \args -> opTranslate args (MO_U_Shr W32) + + Int32EqOp -> \args -> opTranslate args (MO_Eq W32) + Int32GeOp -> \args -> opTranslate args (MO_S_Ge W32) + Int32GtOp -> \args -> opTranslate args (MO_S_Gt W32) + Int32LeOp -> \args -> opTranslate args (MO_S_Le W32) + Int32LtOp -> \args -> opTranslate args (MO_S_Lt W32) + Int32NeOp -> \args -> opTranslate args (MO_Ne W32) -- Word32# unsigned ops Word32ToWordOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform)) WordToWord32Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32) + Word32AddOp -> \args -> opTranslate args (MO_Add W32) + Word32SubOp -> \args -> opTranslate args (MO_Sub W32) + Word32MulOp -> \args -> opTranslate args (MO_Mul W32) + Word32QuotOp -> \args -> opTranslate args (MO_U_Quot W32) + Word32RemOp -> \args -> opTranslate args (MO_U_Rem W32) + + Word32AndOp -> \args -> opTranslate args (MO_And W32) + Word32OrOp -> \args -> opTranslate args (MO_Or W32) + Word32XorOp -> \args -> opTranslate args (MO_Xor W32) + Word32NotOp -> \args -> opTranslate args (MO_Not W32) + Word32SllOp -> \args -> opTranslate args (MO_Shl W32) + Word32SrlOp -> \args -> opTranslate args (MO_U_Shr W32) + + Word32EqOp -> \args -> opTranslate args (MO_Eq W32) + Word32GeOp -> \args -> opTranslate args (MO_U_Ge W32) + Word32GtOp -> \args -> opTranslate args (MO_U_Gt W32) + Word32LeOp -> \args -> opTranslate args (MO_U_Le W32) + Word32LtOp -> \args -> opTranslate args (MO_U_Lt W32) + Word32NeOp -> \args -> opTranslate args (MO_Ne W32) -- Char# ops @@ -1380,6 +1418,11 @@ emitPrimOp dflags primop = case primop of then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) + Int32QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W32) + else Right (genericIntQuotRemOp W32) + WordQuotRemOp -> \args -> opCallishHandledLater args $ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem (wordWidth platform)) @@ -1400,6 +1443,11 @@ emitPrimOp dflags primop = case primop of then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) + Word32QuotRemOp -> \args -> opCallishHandledLater args $ + if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W32) + else Right (genericWordQuotRemOp W32) + WordAdd2Op -> \args -> opCallishHandledLater args $ if (ncg && (x86ish || ppc)) || llvm then Left (MO_Add2 (wordWidth platform)) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 3c45c8f379..d5ecd102a2 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -1511,14 +1511,18 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR , eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR , + eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR , eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR , eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR, + eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR, eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, extendWord8_RDR, extendInt8_RDR, - extendWord16_RDR, extendInt16_RDR :: RdrName + extendWord16_RDR, extendInt16_RDR, + extendWord32_RDR, extendInt32_RDR + :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1559,6 +1563,12 @@ leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#") gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" ) geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#") +eqInt32_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt32#") +ltInt32_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt32#" ) +leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#") +gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" ) +geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#") + eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#") ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#") leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#") @@ -1577,6 +1587,12 @@ leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#") gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" ) geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#") +eqWord32_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord32#") +ltWord32_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord32#" ) +leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#") +gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" ) +geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#") + eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#") leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#") @@ -1601,6 +1617,8 @@ extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#") extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#") extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#") +extendWord32_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord32#") +extendInt32_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt32#") {- ************************************************************************ @@ -2362,12 +2380,16 @@ ordOpTbl , eqInt8_RDR , geInt8_RDR , gtInt8_RDR )) ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR , eqInt16_RDR , geInt16_RDR , gtInt16_RDR )) + ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR + , eqInt32_RDR , geInt32_RDR , gtInt32_RDR )) ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR )) ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR , eqWord16_RDR, geWord16_RDR, gtWord16_RDR )) + ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR + , eqWord32_RDR, geWord32_RDR, gtWord32_RDR )) ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR @@ -2390,13 +2412,19 @@ boxConTbl = . nlHsApp (nlHsVar extendInt8_RDR)) , (word8PrimTy, nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord8_RDR)) + . nlHsApp (nlHsVar extendWord8_RDR)) , (int16PrimTy, nlHsApp (nlHsVar $ getRdrName intDataCon) . nlHsApp (nlHsVar extendInt16_RDR)) , (word16PrimTy, nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar extendWord16_RDR)) + . nlHsApp (nlHsVar extendWord16_RDR)) + , (int32PrimTy, + nlHsApp (nlHsVar $ getRdrName intDataCon) + . nlHsApp (nlHsVar extendInt32_RDR)) + , (word32PrimTy, + nlHsApp (nlHsVar $ getRdrName wordDataCon) + . nlHsApp (nlHsVar extendWord32_RDR)) ] @@ -2412,6 +2440,8 @@ postfixModTbl ,(word8PrimTy, "##") ,(int16PrimTy, "#") ,(word16PrimTy, "##") + ,(int32PrimTy, "#") + ,(word32PrimTy, "##") ] primConvTbl :: [(Type, String)] @@ -2420,6 +2450,8 @@ primConvTbl = , (word8PrimTy, "narrowWord8#") , (int16PrimTy, "narrowInt16#") , (word16PrimTy, "narrowWord16#") + , (int32PrimTy, "narrowInt32#") + , (word32PrimTy, "narrowWord32#") ] litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt32.hs b/testsuite/tests/ffi/should_run/PrimFFIInt32.hs new file mode 100644 index 0000000000..511e3cec10 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt32.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_int32" + add_all_int32 + :: Int32# -> Int32# -> Int32# -> Int32# -> Int32# + -> Int32# -> Int32# -> Int32# -> Int32# -> Int32# + -> Int32# + +main :: IO () +main = do + let a = narrowInt32# 0# + b = narrowInt32# 1# + c = narrowInt32# 2# + d = narrowInt32# 3# + e = narrowInt32# 4# + f = narrowInt32# 5# + g = narrowInt32# 6# + h = narrowInt32# 7# + i = narrowInt32# 8# + j = narrowInt32# 9# + x = I# (extendInt32# (add_all_int32 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt32.stdout b/testsuite/tests/ffi/should_run/PrimFFIInt32.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt32.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt32_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt32_c.c new file mode 100644 index 0000000000..5671e7d698 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIInt32_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +int32_t add_all_int32( + int32_t a, int32_t b, int32_t c, int32_t d, int32_t e, + int32_t f, int32_t g, int32_t h, int32_t i, int32_t j) { + return a + b + c + d + e + f + g + h + i + j; +} diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord32.hs b/testsuite/tests/ffi/should_run/PrimFFIWord32.hs new file mode 100644 index 0000000000..996bae1b61 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord32.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import GHC.Exts + +foreign import ccall "add_all_word32" + add_all_word32 + :: Word32# -> Word32# -> Word32# -> Word32# -> Word32# + -> Word32# -> Word32# -> Word32# -> Word32# -> Word32# + -> Word32# + +main :: IO () +main = do + let a = narrowWord32# 0## + b = narrowWord32# 1## + c = narrowWord32# 2## + d = narrowWord32# 3## + e = narrowWord32# 4## + f = narrowWord32# 5## + g = narrowWord32# 6## + h = narrowWord32# 7## + i = narrowWord32# 8## + j = narrowWord32# 9## + x = W# (extendWord32# (add_all_word32 a b c d e f g h i j)) + print x diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord32.stdout b/testsuite/tests/ffi/should_run/PrimFFIWord32.stdout new file mode 100644 index 0000000000..ea90ee3198 --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord32.stdout @@ -0,0 +1 @@ +45 diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord32_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord32_c.c new file mode 100644 index 0000000000..40d617b3ee --- /dev/null +++ b/testsuite/tests/ffi/should_run/PrimFFIWord32_c.c @@ -0,0 +1,7 @@ +#include <stdint.h> + +uint32_t add_all_word32( + uint32_t a, uint32_t b, uint32_t c, uint32_t d, uint32_t e, + uint32_t f, uint32_t g, uint32_t h, uint32_t i, uint32_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 95213d38b4..3116946d29 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -212,6 +212,10 @@ test('PrimFFIInt16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt16_c.c' test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c.c']) +test('PrimFFIInt32', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt32_c.c']) + +test('PrimFFIWord32', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord32_c.c']) + test('T493', [omit_ways(['ghci'])], compile_and_run, ['T493_c.c']) test('UnliftedNewtypesByteArrayOffset', [omit_ways(['ghci'])], compile_and_run, ['UnliftedNewtypesByteArrayOffset_c.c']) diff --git a/testsuite/tests/primops/should_run/ArithInt32.hs b/testsuite/tests/primops/should_run/ArithInt32.hs new file mode 100644 index 0000000000..13b3bb026e --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt32.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Int +import Data.List (findIndex) +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Int32# on the stack works (32 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 <- allInt32 + ] + expected = + [ toInt32 + (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 Int32# on the stack" input expected actual + + -- + -- negateInt32# + -- + let input = allInt32 + expected = [ toInt32 (negate a) | a <- input ] + actual = [ apply1 negateInt32# a | a <- input ] + checkResults "negateInt32#" input expected actual + + -- + -- plusInt32# + -- + let input = [ (a, b) | a <- allInt32, b <- allInt32 ] + expected = [ toInt32 (a + b) | (a, b) <- input ] + actual = [ apply2 plusInt32# a b | (a, b) <- input ] + checkResults "plusInt32#" input expected actual + + -- -- + -- -- subInt32# + -- -- + let input = [ (a, b) | a <- allInt32, b <- allInt32 ] + expected = [ toInt32 (a - b) | (a, b) <- input ] + actual = [ apply2 subInt32# a b | (a, b) <- input ] + checkResults "subInt32#" input expected actual + + -- + -- timesInt32# + -- + let input = [ (a, b) | a <- allInt32, b <- allInt32 ] + expected = [ toInt32 (a * b) | (a, b) <- input ] + actual = [ apply2 timesInt32# a b | (a, b) <- input ] + checkResults "timesInt32#" input expected actual + + -- + -- remInt32# + -- + let input = + [ (a, b) | a <- allInt32, b <- allInt32 + -- Don't divide by 0 or cause overflow + , b /= 0, not (a == -2147483648 && b == -1) + ] + expected = [ toInt32 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remInt32# a b | (a, b) <- input ] + checkResults "remInt32#" input expected actual + + -- + -- quotInt32# + -- + let input = + [ (a, b) | a <- allInt32, b <- allInt32 + , b /= 0, not (a == -2147483648 && b == -1) + ] + expected = [ toInt32 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotInt32# a b | (a, b) <- input ] + checkResults "quotInt32#" input expected actual + + -- + -- quotRemInt32# + -- + let input = + [ (a, b) | a <- allInt32, b <- allInt32 + , b /= 0, not (a == -2147483648 && b == -1) + ] + expected = + [ (toInt32 q, toInt32 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemInt32# a b | (a, b) <- input ] + checkResults "quotRemInt32#" 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) + +-- testing across the entire Int32 range blows the memory, +-- hence choosing a smaller range +allInt32 :: [Int] +allInt32 = [ -50 .. 50 ] + +toInt32 :: Int -> Int +toInt32 a = fromIntegral (fromIntegral a :: Int32) + +addMany# + :: Int32# -> Int32# -> Int32# -> Int32# + -> Int32# -> Int32# -> Int32# -> Int32# + -> Int32# -> Int32# -> Int32# -> Int32# + -> Int32# -> Int32# -> Int32# -> Int32# + -> Int32# +addMany# a b c d e f g h i j k l m n o p = + a `plusInt32#` b `plusInt32#` c `plusInt32#` d `plusInt32#` + e `plusInt32#` f `plusInt32#` g `plusInt32#` h `plusInt32#` + i `plusInt32#` j `plusInt32#` k `plusInt32#` l `plusInt32#` + m `plusInt32#` n `plusInt32#` o `plusInt32#` 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# (extendInt32# int32) + where + !int32 = addMany# + (narrowInt32# a) (narrowInt32# b) (narrowInt32# c) (narrowInt32# d) + (narrowInt32# e) (narrowInt32# f) (narrowInt32# g) (narrowInt32# h) + (narrowInt32# i) (narrowInt32# j) (narrowInt32# k) (narrowInt32# l) + (narrowInt32# m) (narrowInt32# n) (narrowInt32# o) (narrowInt32# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Int32# +apply1 :: (Int32# -> Int32#) -> Int -> Int +apply1 opToTest (I# a) = I# (extendInt32# (opToTest (narrowInt32# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Int32# -> Int32# -> Int32#) -> Int -> Int -> Int +apply2 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt32# a, narrowInt32# b #) + r = opToTest sa sb + in I# (extendInt32# r) +{-# NOINLINE apply2 #-} + +apply3 :: (Int32# -> Int32# -> (# Int32#, Int32# #)) -> Int -> Int -> (Int, Int) +apply3 opToTest (I# a) (I# b) = + let (# sa, sb #) = (# narrowInt32# a, narrowInt32# b #) + (# ra, rb #) = opToTest sa sb + in (I# (extendInt32# ra), I# (extendInt32# 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/ArithInt32.stdout b/testsuite/tests/primops/should_run/ArithInt32.stdout new file mode 100644 index 0000000000..7ce360bdab --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithInt32.stdout @@ -0,0 +1,8 @@ +Pass: passing Int32# on the stack +Pass: negateInt32# +Pass: plusInt32# +Pass: subInt32# +Pass: timesInt32# +Pass: remInt32# +Pass: quotInt32# +Pass: quotRemInt32# diff --git a/testsuite/tests/primops/should_run/ArithWord32.hs b/testsuite/tests/primops/should_run/ArithWord32.hs new file mode 100644 index 0000000000..5756732ce0 --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord32.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Data.Word +import Data.Bits +import Data.List (findIndex) +import GHC.Prim +import GHC.Exts + +main :: IO () +main = do + + -- + -- Check if passing Word32# on the stack works (32 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 <- allWord32 + ] + expected = + [ toWord32 + (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 Word32# on the stack" input expected actual + + -- + -- notWord32# + -- + let input = allWord32 + expected = [ toWord32 (complement a) | a <- input ] + actual = [ apply1 notWord32# a | a <- input ] + checkResults "notWord32#" input expected actual + + -- + -- plusWord32# + -- + let input = [ (a, b) | a <- allWord32, b <- allWord32 ] + expected = [ toWord32 (a + b) | (a, b) <- input ] + actual = [ apply2 plusWord32# a b | (a, b) <- input ] + checkResults "plusWord32#" input expected actual + + -- + -- subWord32# + -- + let input = [ (a, b) | a <- allWord32, b <- allWord32 ] + expected = [ toWord32 (a - b) | (a, b) <- input ] + actual = [ apply2 subWord32# a b | (a, b) <- input ] + checkResults "subWord32#" input expected actual + + -- + -- timesWord32# + -- + let input = [ (a, b) | a <- allWord32, b <- allWord32 ] + expected = [ toWord32 (a * b) | (a, b) <- input ] + actual = [ apply2 timesWord32# a b | (a, b) <- input ] + checkResults "timesWord32#" input expected actual + + -- + -- remWord32# + -- + let input = + -- Don't divide by 0. + [ (a, b) | a <- allWord32, b <- allWord32 , b /= 0 ] + expected = [ toWord32 (a `rem` b) | (a, b) <- input ] + actual = [ apply2 remWord32# a b | (a, b) <- input ] + checkResults "remWord32#" input expected actual + + -- + -- quotWord32# + -- + let input = + [ (a, b) | a <- allWord32, b <- allWord32, b /= 0 ] + expected = [ toWord32 (a `quot` b) | (a, b) <- input ] + actual = [ apply2 quotWord32# a b | (a, b) <- input ] + checkResults "quotWord32#" input expected actual + + -- + -- quotRemWord32# + -- + let input = + [ (a, b) | a <- allWord32, b <- allWord32, b /= 0 ] + expected = + [ (toWord32 q, toWord32 r) | (a, b) <- input + , let (q, r) = a `quotRem` b + ] + actual = [ apply3 quotRemWord32# a b | (a, b) <- input ] + checkResults "quotRemWord32#" 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) + +-- testing across the entire Word32 range blows the memory, +-- hence choosing a smaller range +allWord32 :: [Word] +allWord32 = [ 0 .. 100 ] + +toWord32 :: Word -> Word +toWord32 a = fromIntegral (fromIntegral a :: Word32) + +addMany# + :: Word32# -> Word32# -> Word32# -> Word32# + -> Word32# -> Word32# -> Word32# -> Word32# + -> Word32# -> Word32# -> Word32# -> Word32# + -> Word32# -> Word32# -> Word32# -> Word32# + -> Word32# +addMany# a b c d e f g h i j k l m n o p = + a `plusWord32#` b `plusWord32#` c `plusWord32#` d `plusWord32#` + e `plusWord32#` f `plusWord32#` g `plusWord32#` h `plusWord32#` + i `plusWord32#` j `plusWord32#` k `plusWord32#` l `plusWord32#` + m `plusWord32#` n `plusWord32#` o `plusWord32#` 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# (extendWord32# word32) + where + !word32 = + addMany# + (narrowWord32# a) (narrowWord32# b) (narrowWord32# c) (narrowWord32# d) + (narrowWord32# e) (narrowWord32# f) (narrowWord32# g) (narrowWord32# h) + (narrowWord32# i) (narrowWord32# j) (narrowWord32# k) (narrowWord32# l) + (narrowWord32# m) (narrowWord32# n) (narrowWord32# o) (narrowWord32# p) +{-# NOINLINE addMany #-} + +-- Convenient and also tests higher order functions on Word32# +apply1 :: (Word32# -> Word32#) -> Word -> Word +apply1 opToTest (W# a) = W# (extendWord32# (opToTest (narrowWord32# a))) +{-# NOINLINE apply1 #-} + +apply2 :: (Word32# -> Word32# -> Word32#) -> Word -> Word -> Word +apply2 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord32# a, narrowWord32# b #) + r = opToTest sa sb + in W# (extendWord32# r) +{-# NOINLINE apply2 #-} + +apply3 + :: (Word32# -> Word32# -> (# Word32#, Word32# #)) -> Word -> Word -> (Word, Word) +apply3 opToTest (W# a) (W# b) = + let (# sa, sb #) = (# narrowWord32# a, narrowWord32# b #) + (# ra, rb #) = opToTest sa sb + in (W# (extendWord32# ra), W# (extendWord32# 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/ArithWord32.stdout b/testsuite/tests/primops/should_run/ArithWord32.stdout new file mode 100644 index 0000000000..cd05038fab --- /dev/null +++ b/testsuite/tests/primops/should_run/ArithWord32.stdout @@ -0,0 +1,8 @@ +Pass: passing Word32# on the stack +Pass: notWord32# +Pass: plusWord32# +Pass: subWord32# +Pass: timesWord32# +Pass: remWord32# +Pass: quotWord32# +Pass: quotRemWord32# diff --git a/testsuite/tests/primops/should_run/CmpInt32.hs b/testsuite/tests/primops/should_run/CmpInt32.hs new file mode 100644 index 0000000000..6f52ccecb1 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt32.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Int +import Data.List (findIndex) +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 Int32# +data TestInt32 = T32 Int32# + deriving (Eq, Ord) + +mkT32 :: Int -> TestInt32 +mkT32 (I# a) = T32 (narrowInt32# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allInt32, b <- allInt32 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT32 a == mkT32 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT32 a /= mkT32 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT32 a < mkT32 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT32 a > mkT32 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT32 a <= mkT32 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT32 a >= mkT32 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) + +-- testing across the entire Int32 range blows the memory, +-- hence choosing a smaller range +allInt32 :: [Int] +allInt32 = [ -50 .. 50 ] diff --git a/testsuite/tests/primops/should_run/CmpInt32.stdout b/testsuite/tests/primops/should_run/CmpInt32.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpInt32.stdout @@ -0,0 +1,6 @@ +Pass: (==) +Pass: (/=) +Pass: (<) +Pass: (>) +Pass: (<=) +Pass: (>=) diff --git a/testsuite/tests/primops/should_run/CmpWord32.hs b/testsuite/tests/primops/should_run/CmpWord32.hs new file mode 100644 index 0000000000..5e422aecab --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord32.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Data.Word +import Data.List (findIndex) +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 Word32# +data TestWord32 = T32 Word32# + deriving (Eq, Ord) + +mkT32 :: Word -> TestWord32 +mkT32 (W# a) = T32 (narrowWord32# a) + +main :: IO () +main = do + let input = [ (a, b) | a <- allWord32, b <- allWord32 ] + + -- + -- (==) + -- + let expected = [ a == b | (a, b) <- input ] + actual = [ mkT32 a == mkT32 b | (a, b) <- input ] + checkResults "(==)" input expected actual + + -- + -- (/=) + -- + let expected = [ a /= b | (a, b) <- input ] + actual = [ mkT32 a /= mkT32 b | (a, b) <- input ] + checkResults "(/=)" input expected actual + + -- + -- (<) + -- + let expected = [ a < b | (a, b) <- input ] + actual = [ mkT32 a < mkT32 b | (a, b) <- input ] + checkResults "(<)" input expected actual + + -- + -- (>) + -- + let expected = [ a > b | (a, b) <- input ] + actual = [ mkT32 a > mkT32 b | (a, b) <- input ] + checkResults "(>)" input expected actual + + -- + -- (<=) + -- + let expected = [ a <= b | (a, b) <- input ] + actual = [ mkT32 a <= mkT32 b | (a, b) <- input ] + checkResults "(<=)" input expected actual + + -- + -- (>=) + -- + let expected = [ a >= b | (a, b) <- input ] + actual = [ mkT32 a >= mkT32 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) + +-- testing across the entire Word32 range blows the memory, +-- hence choosing a smaller range +allWord32 :: [Word] +allWord32 = [ 0 .. 100 ] diff --git a/testsuite/tests/primops/should_run/CmpWord32.stdout b/testsuite/tests/primops/should_run/CmpWord32.stdout new file mode 100644 index 0000000000..191d2b4b26 --- /dev/null +++ b/testsuite/tests/primops/should_run/CmpWord32.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 index e11a4934e6..ddeb661ec4 100644 --- a/testsuite/tests/primops/should_run/ShowPrim.hs +++ b/testsuite/tests/primops/should_run/ShowPrim.hs @@ -10,13 +10,20 @@ data Test1 = Test1 Int8# Word8# data Test2 = Test2 Int16# Word16# deriving (Show) +data Test3 = Test3 Int32# Word32# + deriving (Show) + test1 :: Test1 test1 = Test1 (narrowInt8# 1#) (narrowWord8# 2##) test2 :: Test2 test2 = Test2 (narrowInt16# 1#) (narrowWord16# 2##) +test3 :: Test3 +test3 = Test3 (narrowInt32# 1#) (narrowWord32# 2##) + main :: IO () main = do print test1 print test2 + print test3 diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout index e2801b44fb..a5dc75f39d 100644 --- a/testsuite/tests/primops/should_run/ShowPrim.stdout +++ b/testsuite/tests/primops/should_run/ShowPrim.stdout @@ -1,2 +1,3 @@ Test1 (narrowInt8# 1#) (narrowWord8# 2##) Test2 (narrowInt16# 1#) (narrowWord16# 2##) +Test3 (narrowInt32# 1#) (narrowWord32# 2##) |