Commit 06982b6c authored by John Ericson's avatar John Ericson Committed by Marge Bot

Make primops for `{Int,Word}32#`

Progress towards #19026.

The type was added before, but not its primops. We follow the
conventions in 36fcf9ed and
2c959a18 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: default avatarSylvain Henry <hsyl20@gmail.com>
parent e981023e
Pipeline #29607 canceled with stages
......@@ -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#"
......
......@@ -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
......
......@@ -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"
......
......@@ -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))
......
......@@ -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)]
......
{-# 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
#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;
}
{-# 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
#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;
}
......@@ -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'])
......
{-# 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 #-}