[Git][ghc/ghc][wip/andreask/interpreter_primops] 4 commits: Fix unary ops
Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC Commits: 1f7f27e6 by Andreas Klebinger at 2025-04-14T23:22:13+02:00 Fix unary ops - - - - - 903e5965 by Andreas Klebinger at 2025-04-15T00:02:58+02:00 Fix shift op - - - - - a6e0e0aa by Andreas Klebinger at 2025-04-16T20:12:18+02:00 Fix macro parantheses - - - - - 12f61803 by Andreas Klebinger at 2025-04-17T00:09:50+02:00 More testing - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToByteCode.hs - rts/Interpreter.c - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -147,6 +147,7 @@ defaults fixity = Nothing vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation + div_like = False -- Second argument expected to be non zero - used for tests -- Note [When do out-of-line primops go in primops.txt.pp] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -296,14 +297,18 @@ primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8# primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8# with effect = CanFail + div_like = True primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8# with effect = CanFail + div_like = True + primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #) with effect = CanFail + div_like = True primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# @@ -342,14 +347,17 @@ primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8# primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8# with effect = CanFail + div_like = True primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8# with effect = CanFail + div_like = True primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #) with effect = CanFail + div_like = True primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8# with commutable = True @@ -400,14 +408,17 @@ primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16# primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16# with effect = CanFail + div_like = True primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16# with effect = CanFail + div_like = True primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) with effect = CanFail + div_like = True primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# @@ -446,14 +457,17 @@ primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16# primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16# with effect = CanFail + div_like = True primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16# with effect = CanFail + div_like = True primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) with effect = CanFail + div_like = True primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16# with commutable = True @@ -504,14 +518,17 @@ primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32# primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# with effect = CanFail + div_like = True primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# with effect = CanFail + div_like = True primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) with effect = CanFail + div_like = True primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# @@ -550,14 +567,17 @@ primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32# primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# with effect = CanFail + div_like = True primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# with effect = CanFail + div_like = True primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) with effect = CanFail + div_like = True primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# with commutable = True @@ -608,10 +628,12 @@ primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64# primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# with effect = CanFail + div_like = True primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# with effect = CanFail + div_like = True primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# @@ -650,10 +672,12 @@ primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64# primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# with effect = CanFail + div_like = True primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# with effect = CanFail + div_like = True primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# with commutable = True @@ -737,6 +761,7 @@ primop IntQuotOp "quotInt#" GenPrimOp zero. } with effect = CanFail + div_like = True primop IntRemOp "remInt#" GenPrimOp Int# -> Int# -> Int# @@ -744,11 +769,13 @@ primop IntRemOp "remInt#" GenPrimOp behavior is undefined if the second argument is zero. } with effect = CanFail + div_like = True primop IntQuotRemOp "quotRemInt#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Rounds towards zero.} with effect = CanFail + div_like = True primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int# {Bitwise "and".} @@ -886,19 +913,23 @@ primop WordMul2Op "timesWord2#" GenPrimOp primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word# with effect = CanFail + div_like = True primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word# with effect = CanFail + div_like = True primop WordQuotRemOp "quotRemWord#" GenPrimOp Word# -> Word# -> (# Word#, Word# #) with effect = CanFail + div_like = True primop WordQuotRem2Op "quotRemWord2#" GenPrimOp Word# -> Word# -> Word# -> (# Word#, Word# #) { Takes high word of dividend, then low word of dividend, then divisor. Requires that high word < divisor.} with effect = CanFail + div_like = True primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word# with commutable = True @@ -4166,6 +4197,7 @@ primop VecQuotOp "quot#" GenPrimOp Do not expect high performance. } with effect = CanFail vector = INT_VECTOR_TYPES + div_like = True primop VecRemOp "rem#" GenPrimOp VECTOR -> VECTOR -> VECTOR @@ -4175,6 +4207,8 @@ primop VecRemOp "rem#" GenPrimOp Do not expect high performance. } with effect = CanFail vector = INT_VECTOR_TYPES + div_like = True + primop VecNegOp "negate#" GenPrimOp VECTOR -> VECTOR ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -857,6 +857,17 @@ doPrimOp platform op init_d s p args = Word8AddOp -> sizedPrimOp OP_ADD AddrAddOp -> sizedPrimOp OP_ADD + IntMulOp -> sizedPrimOp OP_MUL + Int64MulOp -> sizedPrimOp OP_MUL + Int32MulOp -> sizedPrimOp OP_MUL + Int16MulOp -> sizedPrimOp OP_MUL + Int8MulOp -> sizedPrimOp OP_MUL + WordMulOp -> sizedPrimOp OP_MUL + Word64MulOp -> sizedPrimOp OP_MUL + Word32MulOp -> sizedPrimOp OP_MUL + Word16MulOp -> sizedPrimOp OP_MUL + Word8MulOp -> sizedPrimOp OP_MUL + IntSubOp -> sizedPrimOp OP_SUB WordSubOp -> sizedPrimOp OP_SUB Int64SubOp -> sizedPrimOp OP_SUB @@ -1009,20 +1020,20 @@ doPrimOp platform op init_d s p args = Int16NegOp -> sizedPrimOp OP_NEG Int8NegOp -> sizedPrimOp OP_NEG - IntToWordOp -> no_op - WordToIntOp -> no_op - Int8ToWord8Op -> no_op - Word8ToInt8Op -> no_op - Int16ToWord16Op -> no_op - Word16ToInt16Op -> no_op - Int32ToWord32Op -> no_op - Word32ToInt32Op -> no_op - Int64ToWord64Op -> no_op - Word64ToInt64Op -> no_op - IntToAddrOp -> no_op - AddrToIntOp -> no_op - ChrOp -> no_op -- Int# and Char# are rep'd the same - OrdOp -> no_op + IntToWordOp -> mk_conv (platformWordWidth platform) + WordToIntOp -> mk_conv (platformWordWidth platform) + Int8ToWord8Op -> mk_conv W8 + Word8ToInt8Op -> mk_conv W8 + Int16ToWord16Op -> mk_conv W16 + Word16ToInt16Op -> mk_conv W16 + Int32ToWord32Op -> mk_conv W32 + Word32ToInt32Op -> mk_conv W32 + Int64ToWord64Op -> mk_conv W64 + Word64ToInt64Op -> mk_conv W64 + IntToAddrOp -> mk_conv (platformWordWidth platform) + AddrToIntOp -> mk_conv (platformWordWidth platform) + ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same + OrdOp -> mk_conv (platformWordWidth platform) IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8 IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16 @@ -1031,6 +1042,7 @@ doPrimOp platform op init_d s p args = _ -> Nothing where + primArg1Width :: StgArg -> Width primArg1Width arg | rep <- (stgArgRepU arg) = case rep of @@ -1080,43 +1092,12 @@ doPrimOp platform op init_d s p args = let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width return $ prim_code `appOL` slide - no_op = Just $ do + mk_conv :: Width -> Maybe (BcM (OrdList BCInstr)) + mk_conv target_width = Just $ do let width = primArg1Width (head args) - prim_code <- terribleNoOp init_d s p undefined args - let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width - return $ prim_code `appOL` slide - --- It's horrible, but still better than calling intToWord ... -terribleNoOp - :: StackDepth - -> Sequel - -> BCEnv - -> BCInstr -- The operator - -> [StgArg] -- Args, in *reverse* order (must be fully applied) - -> BcM BCInstrList -terribleNoOp orig_d _ p _ args = app_code - where - app_code = do - profile <- getProfile - let --platform = profilePlatform profile - - non_voids = - addArgReps (assertNonVoidStgArgs args) - (_, _, args_offsets) = - mkVirtHeapOffsetsWithPadding profile StdHeader non_voids - - do_pushery !d (arg : args) = do - (push, arg_bytes) <- case arg of - (Padding l _) -> return $! pushPadding (ByteOff l) - (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) - more_push_code <- do_pushery (d + arg_bytes) args - return (push `appOL` more_push_code) - do_pushery !_d [] = do - -- let !n_arg_words = bytesToWords platform (d - orig_d) - return (nilOL) - - -- Push on the stack in the reverse order. - do_pushery orig_d (reverse args_offsets) + (push_code, _bytes) <- pushAtom init_d p (head args) + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width + return $ push_code `appOL` slide -- Push the arguments on the stack and emit the given instruction -- Pushes one word per non void arg. ===================================== rts/Interpreter.c ===================================== @@ -249,9 +249,9 @@ See ticket #25750 #define SafeSpWP(n) \ ((StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))) #define SafeSpBP(off_w) \ - ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W(1+off_w/sizeof(StgWord))) ? \ + ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \ Sp_plusB(off_w) : \ - (StgWord*) ((ptrdiff_t)(off_w % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, off_w/sizeof(StgWord)))) + (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord)))) @@ -2270,10 +2270,10 @@ run_BCO: #define UN_SIZED_OP(op,ty) \ { \ if(sizeof(ty) == 8) { \ - ty r = op (*(ty*) ReadSpW64(0)); \ + ty r = op ((ty) ReadSpW64(0)); \ SpW64(0) = (StgWord64) r; \ } else { \ - ty r = op (*(ty*) ReadSpW(0)); \ + ty r = op ((ty) ReadSpW(0)); \ SpW(0) = (StgWord) r; \ } \ goto nextInsn; \ @@ -2293,15 +2293,30 @@ run_BCO: goto nextInsn; \ } +// op :: ty -> Int -> ty +#define SIZED_BIN_OP_TY_INT(op,ty) \ +{ \ + if(sizeof(ty) > sizeof(StgWord)) { \ + ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW(2)); \ + Sp_addW(1); \ + SpW64(0) = (StgWord64) r; \ + } else { \ + ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \ + Sp_addW(1); \ + SpW(0) = (StgWord) r; \ + }; \ + goto nextInsn; \ +} + case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64) case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64) case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64) case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64) case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64) case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64) - case bci_OP_SHL_64: SIZED_BIN_OP(<<, StgWord64) - case bci_OP_LSR_64: SIZED_BIN_OP(>>, StgWord64) - case bci_OP_ASR_64: SIZED_BIN_OP(>>, StgInt64) + case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64) + case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64) + case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64) case bci_OP_NEQ_64: SIZED_BIN_OP(!=, StgWord64) case bci_OP_EQ_64: SIZED_BIN_OP(==, StgWord64) @@ -2325,9 +2340,9 @@ run_BCO: case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32) case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32) case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32) - case bci_OP_SHL_32: SIZED_BIN_OP(<<, StgWord32) - case bci_OP_LSR_32: SIZED_BIN_OP(>>, StgWord32) - case bci_OP_ASR_32: SIZED_BIN_OP(>>, StgInt32) + case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32) + case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32) + case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32) case bci_OP_NEQ_32: SIZED_BIN_OP(!=, StgWord32) case bci_OP_EQ_32: SIZED_BIN_OP(==, StgWord32) @@ -2351,9 +2366,9 @@ run_BCO: case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16) case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16) case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16) - case bci_OP_SHL_16: SIZED_BIN_OP(<<, StgWord16) - case bci_OP_LSR_16: SIZED_BIN_OP(>>, StgWord16) - case bci_OP_ASR_16: SIZED_BIN_OP(>>, StgInt16) + case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16) + case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16) + case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16) case bci_OP_NEQ_16: SIZED_BIN_OP(!=, StgWord16) case bci_OP_EQ_16: SIZED_BIN_OP(==, StgWord16) @@ -2377,9 +2392,9 @@ run_BCO: case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8) case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8) case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8) - case bci_OP_SHL_08: SIZED_BIN_OP(<<, StgWord8) - case bci_OP_LSR_08: SIZED_BIN_OP(>>, StgWord8) - case bci_OP_ASR_08: SIZED_BIN_OP(>>, StgInt8) + case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8) + case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8) + case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8) case bci_OP_NEQ_08: SIZED_BIN_OP(!=, StgWord8) case bci_OP_EQ_08: SIZED_BIN_OP(==, StgWord8) ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -1,3 +1,8 @@ +{- PARTS OF THIS FILE ARE SEMI-AUTOGENERATED. + You can re-generate them by invoking the genprimops utility with --foundation-tests + and then integrating the output in this file. +-} + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,6 +24,7 @@ import Data.Typeable import Data.Proxy import GHC.Int import GHC.Word +import GHC.Word import Data.Function import GHC.Prim import Control.Monad.Reader @@ -108,6 +114,17 @@ arbitraryWord64 = Gen $ do h <- ask liftIO (randomWord64 h) +nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a) +nonZero = do + x <- arbitrary + if x == 0 then nonZero else pure $ NonZero x + +newtype NonZero a = NonZero { getNonZero :: a } + deriving (Eq,Ord,Bounded,Show) + +instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where + arbitrary = nonZero + instance Arbitrary Natural where arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64 @@ -138,10 +155,10 @@ instance Arbitrary Int8 where instance Arbitrary Char where arbitrary = do - let low = fromEnum (minBound :: Char) - high = fromEnum (maxBound :: Char) - x <- arbitrary - if x >= low && x <= high then return (chr x) else arbitrary + let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word + (x::Word) <- arbitrary + let x' = mod x high + return (chr $ fromIntegral x') int64ToInt :: Int64 -> Int int64ToInt (I64# i) = I# (int64ToInt# i) @@ -277,9 +294,8 @@ testMultiplicative _ = Group "Multiplicative" testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test testDividible _ = Group "Divisible" - [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b -> - if b == 0 then True === True - else a === (a `div` b) * b + (a `mod` b) + [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> + a === (a `div` b) * b + (a `mod` b) ] testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) @@ -368,6 +384,9 @@ wInt64# = I64# class TestPrimop f where testPrimop :: String -> f -> f -> Test + testPrimopDivLike :: String -> f -> f -> Test + testPrimopDivLike _ _ _ = error "Div testing not supported for this type." + {- instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2) @@ -383,6 +402,9 @@ instance TestPrimop (Word# -> Int# -> Word#) where -} +twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b +twoNonZero f x (NonZero y) = f x y + main = runTests (Group "ALL" [testNumberRefs, testPrimops]) -- Test an interpreted primop vs a compiled primop @@ -400,9 +422,9 @@ testPrimops = Group "primop" , testPrimop "plusInt8#" Primop.plusInt8# Wrapper.plusInt8# , testPrimop "subInt8#" Primop.subInt8# Wrapper.subInt8# , testPrimop "timesInt8#" Primop.timesInt8# Wrapper.timesInt8# - , testPrimop "quotInt8#" Primop.quotInt8# Wrapper.quotInt8# - , testPrimop "remInt8#" Primop.remInt8# Wrapper.remInt8# - , testPrimop "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8# + , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8# + , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8# + , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8# , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# @@ -418,9 +440,9 @@ testPrimops = Group "primop" , testPrimop "plusWord8#" Primop.plusWord8# Wrapper.plusWord8# , testPrimop "subWord8#" Primop.subWord8# Wrapper.subWord8# , testPrimop "timesWord8#" Primop.timesWord8# Wrapper.timesWord8# - , testPrimop "quotWord8#" Primop.quotWord8# Wrapper.quotWord8# - , testPrimop "remWord8#" Primop.remWord8# Wrapper.remWord8# - , testPrimop "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8# + , testPrimopDivLike "quotWord8#" Primop.quotWord8# Wrapper.quotWord8# + , testPrimopDivLike "remWord8#" Primop.remWord8# Wrapper.remWord8# + , testPrimopDivLike "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8# , testPrimop "andWord8#" Primop.andWord8# Wrapper.andWord8# , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8# , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8# @@ -440,9 +462,9 @@ testPrimops = Group "primop" , testPrimop "plusInt16#" Primop.plusInt16# Wrapper.plusInt16# , testPrimop "subInt16#" Primop.subInt16# Wrapper.subInt16# , testPrimop "timesInt16#" Primop.timesInt16# Wrapper.timesInt16# - , testPrimop "quotInt16#" Primop.quotInt16# Wrapper.quotInt16# - , testPrimop "remInt16#" Primop.remInt16# Wrapper.remInt16# - , testPrimop "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16# + , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16# + , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16# + , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16# , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# @@ -458,9 +480,9 @@ testPrimops = Group "primop" , testPrimop "plusWord16#" Primop.plusWord16# Wrapper.plusWord16# , testPrimop "subWord16#" Primop.subWord16# Wrapper.subWord16# , testPrimop "timesWord16#" Primop.timesWord16# Wrapper.timesWord16# - , testPrimop "quotWord16#" Primop.quotWord16# Wrapper.quotWord16# - , testPrimop "remWord16#" Primop.remWord16# Wrapper.remWord16# - , testPrimop "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16# + , testPrimopDivLike "quotWord16#" Primop.quotWord16# Wrapper.quotWord16# + , testPrimopDivLike "remWord16#" Primop.remWord16# Wrapper.remWord16# + , testPrimopDivLike "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16# , testPrimop "andWord16#" Primop.andWord16# Wrapper.andWord16# , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16# , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16# @@ -480,9 +502,9 @@ testPrimops = Group "primop" , testPrimop "plusInt32#" Primop.plusInt32# Wrapper.plusInt32# , testPrimop "subInt32#" Primop.subInt32# Wrapper.subInt32# , testPrimop "timesInt32#" Primop.timesInt32# Wrapper.timesInt32# - , testPrimop "quotInt32#" Primop.quotInt32# Wrapper.quotInt32# - , testPrimop "remInt32#" Primop.remInt32# Wrapper.remInt32# - , testPrimop "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32# + , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32# + , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32# + , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32# , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# @@ -498,9 +520,9 @@ testPrimops = Group "primop" , testPrimop "plusWord32#" Primop.plusWord32# Wrapper.plusWord32# , testPrimop "subWord32#" Primop.subWord32# Wrapper.subWord32# , testPrimop "timesWord32#" Primop.timesWord32# Wrapper.timesWord32# - , testPrimop "quotWord32#" Primop.quotWord32# Wrapper.quotWord32# - , testPrimop "remWord32#" Primop.remWord32# Wrapper.remWord32# - , testPrimop "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32# + , testPrimopDivLike "quotWord32#" Primop.quotWord32# Wrapper.quotWord32# + , testPrimopDivLike "remWord32#" Primop.remWord32# Wrapper.remWord32# + , testPrimopDivLike "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32# , testPrimop "andWord32#" Primop.andWord32# Wrapper.andWord32# , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32# , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32# @@ -520,8 +542,8 @@ testPrimops = Group "primop" , testPrimop "plusInt64#" Primop.plusInt64# Wrapper.plusInt64# , testPrimop "subInt64#" Primop.subInt64# Wrapper.subInt64# , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64# - , testPrimop "quotInt64#" Primop.quotInt64# Wrapper.quotInt64# - , testPrimop "remInt64#" Primop.remInt64# Wrapper.remInt64# + , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64# + , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64# , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# @@ -537,8 +559,8 @@ testPrimops = Group "primop" , testPrimop "plusWord64#" Primop.plusWord64# Wrapper.plusWord64# , testPrimop "subWord64#" Primop.subWord64# Wrapper.subWord64# , testPrimop "timesWord64#" Primop.timesWord64# Wrapper.timesWord64# - , testPrimop "quotWord64#" Primop.quotWord64# Wrapper.quotWord64# - , testPrimop "remWord64#" Primop.remWord64# Wrapper.remWord64# + , testPrimopDivLike "quotWord64#" Primop.quotWord64# Wrapper.quotWord64# + , testPrimopDivLike "remWord64#" Primop.remWord64# Wrapper.remWord64# , testPrimop "and64#" Primop.and64# Wrapper.and64# , testPrimop "or64#" Primop.or64# Wrapper.or64# , testPrimop "xor64#" Primop.xor64# Wrapper.xor64# @@ -557,9 +579,9 @@ testPrimops = Group "primop" , testPrimop "*#" (Primop.*#) (Wrapper.*#) , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2# , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo# - , testPrimop "quotInt#" Primop.quotInt# Wrapper.quotInt# - , testPrimop "remInt#" Primop.remInt# Wrapper.remInt# - , testPrimop "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt# + , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt# + , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt# + , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt# , testPrimop "andI#" Primop.andI# Wrapper.andI# , testPrimop "orI#" Primop.orI# Wrapper.orI# , testPrimop "xorI#" Primop.xorI# Wrapper.xorI# @@ -585,10 +607,9 @@ testPrimops = Group "primop" , testPrimop "minusWord#" Primop.minusWord# Wrapper.minusWord# , testPrimop "timesWord#" Primop.timesWord# Wrapper.timesWord# , testPrimop "timesWord2#" Primop.timesWord2# Wrapper.timesWord2# - , testPrimop "quotWord#" Primop.quotWord# Wrapper.quotWord# - , testPrimop "remWord#" Primop.remWord# Wrapper.remWord# - , testPrimop "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord# --- , testPrimop "quotRemWord2#" Primop.quotRemWord2# Wrapper.quotRemWord2# + , testPrimopDivLike "quotWord#" Primop.quotWord# Wrapper.quotWord# + , testPrimopDivLike "remWord#" Primop.remWord# Wrapper.remWord# + , testPrimopDivLike "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord# , testPrimop "and#" Primop.and# Wrapper.and# , testPrimop "or#" Primop.or# Wrapper.or# , testPrimop "xor#" Primop.xor# Wrapper.xor# @@ -652,12 +673,15 @@ instance TestPrimop (Char# -> Int#) where instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) instance TestPrimop (Int# -> Int# -> (# Int#,Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1)) instance TestPrimop (Int# -> Char#) where testPrimop s l r = Property s $ \ (uInt#-> x0) -> wChar# (l x0) === wChar# (r x0) @@ -685,12 +709,15 @@ instance TestPrimop (Int16# -> Int# -> Int16#) where instance TestPrimop (Int16# -> Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int16# -> Int16# -> Int16#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) instance TestPrimop (Int16# -> Int16# -> (# Int16#,Int16# #)) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1)) instance TestPrimop (Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -706,12 +733,15 @@ instance TestPrimop (Int32# -> Int# -> Int32#) where instance TestPrimop (Int32# -> Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int32# -> Int32# -> Int32#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) instance TestPrimop (Int32# -> Int32# -> (# Int32#,Int32# #)) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1)) instance TestPrimop (Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -727,9 +757,11 @@ instance TestPrimop (Int64# -> Int# -> Int64#) where instance TestPrimop (Int64# -> Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int64# -> Int64# -> Int64#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) instance TestPrimop (Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -745,12 +777,15 @@ instance TestPrimop (Int8# -> Int# -> Int8#) where instance TestPrimop (Int8# -> Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int8# -> Int8# -> Int8#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) instance TestPrimop (Int8# -> Int8# -> (# Int8#,Int8# #)) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1)) instance TestPrimop (Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -764,20 +799,21 @@ instance TestPrimop (Int8# -> Word8#) where instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) -instance TestPrimop (Word# -> Word# -> Word# -> (# Word#,Word# #)) where - testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) (uWord#-> x2) -> WTUP2(wWord#,wWord#, (l x0 x1 x2)) === WTUP2(wWord#,wWord#, (r x0 x1 x2)) - instance TestPrimop (Word# -> Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word# -> Word# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) instance TestPrimop (Word# -> Word# -> (# Word#,Int# #)) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1)) instance TestPrimop (Word# -> Word# -> (# Word#,Word# #)) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1)) instance TestPrimop (Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -802,12 +838,15 @@ instance TestPrimop (Word16# -> Int# -> Word16#) where instance TestPrimop (Word16# -> Word16# -> Int#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word16# -> Word16# -> Word16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) instance TestPrimop (Word16# -> Word16# -> (# Word16#,Word16# #)) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1)) instance TestPrimop (Word16# -> Int16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wInt16# (l x0) === wInt16# (r x0) @@ -823,12 +862,15 @@ instance TestPrimop (Word32# -> Int# -> Word32#) where instance TestPrimop (Word32# -> Word32# -> Int#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word32# -> Word32# -> Word32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) instance TestPrimop (Word32# -> Word32# -> (# Word32#,Word32# #)) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1)) instance TestPrimop (Word32# -> Int32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wInt32# (l x0) === wInt32# (r x0) @@ -844,9 +886,11 @@ instance TestPrimop (Word64# -> Int# -> Word64#) where instance TestPrimop (Word64# -> Word64# -> Int#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word64# -> Word64# -> Word64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) instance TestPrimop (Word64# -> Int64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wInt64# (l x0) === wInt64# (r x0) @@ -862,12 +906,15 @@ instance TestPrimop (Word8# -> Int# -> Word8#) where instance TestPrimop (Word8# -> Word8# -> Int#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word8# -> Word8# -> Word8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) instance TestPrimop (Word8# -> Word8# -> (# Word8#,Word8# #)) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1)) instance TestPrimop (Word8# -> Int8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wInt8# (l x0) === wInt8# (r x0) ===================================== utils/genprimopcode/Main.hs ===================================== @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} ------------------------------------------------------------------ -- A primop-table mangling program -- -- @@ -693,16 +694,24 @@ gen_foundation_tests (Info _ entries) where testable_tys = nub (sort (mapMaybe (\po -> ty po <$ mkTest po) entries)) - mkInstances ty = unlines $ - [ "instance TestPrimop (" ++ pprTy ty ++ ") where" - , " testPrimop s l r = Property s $ \\ " ++ intercalate " " (zipWith mkArg [0..] (args ty)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" ] - + mkInstances inst_ty = + let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" + in unlines $ + [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where" + , " testPrimop s l r = Property s $ " ++ test_lambda ] + ++ (if mb_divable_tys + then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda] + else []) where - n_args = length (args ty) + arg_tys = args inst_ty + -- eg Int -> Int -> a + mb_divable_tys = case arg_tys of + [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons + _ -> False - mk_body s = res_ty ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")") + mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")") - vs = zipWith (\n _ -> "x" ++ show n) [0..] (args ty) + vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys) mkArg n t = "(" ++ unwrapper t ++ "-> x" ++ show n ++ ")" @@ -714,15 +723,22 @@ gen_foundation_tests (Info _ entries) args (TyF (TyApp (TyCon c) []) t2) = c : args t2 args (TyApp {}) = [] args (TyUTup {}) = [] + -- If you hit this you will need to handle the foundation tests to handle the + -- type it failed on. + args arg_ty = error ("Unexpected primop type:" ++ pprTy arg_ty) res_ty (TyF _ t2) x = res_ty t2 x res_ty (TyApp (TyCon c) []) x = wrapper c ++ x - res_ty (TyUTup args) x = - let wtup = case length args of + res_ty (TyUTup tup_tys) x = + let wtup = case length tup_tys of 2 -> "WTUP2" 3 -> "WTUP3" - in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") args ++ [x]) ++ ")" - + -- Only handles primops returning unboxed tuples up to 3 args currently + _ -> error "Unexpected primop result type" + in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") tup_tys ++ [x]) ++ ")" + -- If you hit this you will need to handle the foundation tests to handle the + -- type it failed on. + res_ty unexpected_ty x = error ("Unexpected primop result type:" ++ pprTy unexpected_ty ++ "," ++ x) wrap qual nm | isLower (head nm) = qual ++ "." ++ nm @@ -734,7 +750,10 @@ gen_foundation_tests (Info _ entries) , poName /= "tagToEnum#" , poName /= "quotRemWord2#" , (testable (ty po)) - = Just $ intercalate " " ["testPrimop", "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName] + = let testPrimOpHow = if is_divLikeOp po + then "testPrimopDivLike" + else "testPrimop" + in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName] | otherwise = Nothing @@ -742,13 +761,15 @@ gen_foundation_tests (Info _ entries) testable (TyF t1 t2) = testable t1 && testable t2 testable (TyC _ t2) = testable t2 testable (TyApp tc tys) = testableTyCon tc && all testable tys - testable (TyVar a) = False + testable (TyVar _a) = False testable (TyUTup tys) = all testable tys testableTyCon (TyCon c) = c `elem` ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" , "Int8#", "Int16#", "Int32#", "Int64#", "Char#"] testableTyCon _ = False + divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" + ,"Int8#", "Int16#", "Int32#", "Int64#"] ------------------------------------------------------------------ -- Create PrimOpInfo text from PrimOpSpecs ----------------------- ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -53,6 +53,19 @@ is_primtype :: Entry -> Bool is_primtype (PrimTypeSpec {}) = True is_primtype _ = False +is_divLikeOp :: Entry -> Bool +is_divLikeOp entry = case entry of + PrimOpSpec{} -> has_div_like + PseudoOpSpec{} -> has_div_like + PrimVecOpSpec{} -> has_div_like + PrimTypeSpec{} -> False + PrimVecTypeSpec{} -> False + Section{} -> False + where + has_div_like = case lookup_attrib "div_like" (opts entry) of + Just (OptionTrue{}) -> True + _ -> False + -- a binding of property to value data Option = OptionFalse String -- name = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/689e4a7d802a9ee253723cb938e023f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/689e4a7d802a9ee253723cb938e023f... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Andreas Klebinger (＠AndreasK)