diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for wide-word +## 0.1.0.7 -- 2018-11-16 + +* Switch to Hedgehog for testing. + ## 0.1.0.3 -- 2017-04-05 * Make it build with ghc 8.2. diff --git a/Data/WideWord.hs b/Data/WideWord.hs deleted file mode 100644 --- a/Data/WideWord.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Data.WideWord - ( module X - ) where - -import Data.WideWord.Int128 as X -import Data.WideWord.Word128 as X diff --git a/Data/WideWord/Int128.hs b/Data/WideWord/Int128.hs deleted file mode 100644 --- a/Data/WideWord/Int128.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - ------------------------------------------------------------------------------ ----- | ----- Module : Data.WideWord.Int128 ----- ----- Maintainer : erikd@mega-nerd.com ----- Stability : experimental ----- Portability : non-portable (GHC extensions and primops) ----- ----- This module provides an opaque signed 128 bit value with the usual set ----- of typeclass instances one would expect for a fixed width unsigned integer ----- type. ----- Operations like addition, subtraction and multiplication etc provide a ----- "modulo 2^128" result as one would expect from a fixed width unsigned word. -------------------------------------------------------------------------------- - -#include - -module Data.WideWord.Int128 - ( Int128 (..) - , byteSwapInt128 - , showHexInt128 - , zeroInt128 - ) where - -import Control.DeepSeq (NFData (..)) - -import Data.Bits (Bits (..), FiniteBits (..), shiftL) - -import Data.WideWord.Word128 - -import Numeric - -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (Storable (..)) - -import GHC.Enum (predError, succError) -import GHC.Int -import GHC.Prim -import GHC.Real ((%)) -import GHC.Word - - -data Int128 = Int128 - { int128Hi64 :: {-# UNPACK #-} !Word64 - , int128Lo64 :: {-# UNPACK #-} !Word64 - } - deriving Eq - - -byteSwapInt128 :: Int128 -> Int128 -byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a1) (byteSwap64 a0) - - -showHexInt128 :: Int128 -> String -showHexInt128 (Int128 a1 a0) - | a1 == 0 = showHex a0 "" - | otherwise = showHex a1 zeros ++ showHex a0 "" - where - h0 = showHex a0 "" - zeros = replicate (16 - length h0) '0' - -instance Show Int128 where - show = show . toInteger - -instance Read Int128 where - readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s] - -instance Ord Int128 where - compare = compare128 - -instance Bounded Int128 where - minBound = Int128 0x8000000000000000 0 - maxBound = Int128 0x7fffffffffffffff maxBound - -instance Enum Int128 where - succ = succ128 - pred = pred128 - toEnum = toEnum128 - fromEnum = fromEnum128 - -instance Num Int128 where - (+) = plus128 - (-) = minus128 - (*) = times128 - negate = negate128 - abs = abs128 - signum = signum128 - fromInteger = fromInteger128 - -instance Bits Int128 where - (.&.) = and128 - (.|.) = or128 - xor = xor128 - complement = complement128 - shiftL = shiftL128 - unsafeShiftL = shiftL128 - shiftR = shiftR128 - unsafeShiftR = shiftR128 - rotateL = rotateL128 - rotateR = rotateR128 - - bitSize _ = 128 - bitSizeMaybe _ = Just 128 - isSigned _ = False - - testBit = testBit128 - bit = bit128 - - popCount = popCount128 - -instance FiniteBits Int128 where - finiteBitSize _ = 128 - countLeadingZeros = countLeadingZeros128 - countTrailingZeros = countTrailingZeros128 - -instance Real Int128 where - toRational x = toInteger128 x % 1 - -instance Integral Int128 where - quot n d = fst (quotRem128 n d) - rem n d = snd (quotRem128 n d) - div n d = fst (divMod128 n d) - mod n d = snd (divMod128 n d) - quotRem = quotRem128 - divMod = divMod128 - toInteger = toInteger128 - -instance Storable Int128 where - sizeOf _ = 2 * sizeOf (0 :: Word64) - alignment _ = 2 * alignment (0 :: Word64) - peek = peek128 - peekElemOff = peekElemOff128 - poke = poke128 - pokeElemOff = pokeElemOff128 - -instance NFData Int128 where - rnf (Int128 a1 a0) = rnf a1 `seq` rnf a0 - --- ----------------------------------------------------------------------------- --- Rewrite rules. - -{-# RULES -"fromIntegral :: Int128 -> Int128" fromIntegral = id :: Int128 -> Int128 -"fromIntegral :: Word128 -> Int128" fromIntegral = \(Word128 a1 a0) -> Int128 a1 a0 -"fromIntegral :: Int128 -> Word128" fromIntegral = \(Int128 a1 a0) -> Word128 a1 a0 - #-} - --- ----------------------------------------------------------------------------- --- Functions for `Ord` instance. - -compare128 :: Int128 -> Int128 -> Ordering -compare128 (Int128 a1 a0) (Int128 b1 b0) = - case compare (int64OfWord64 a1) (int64OfWord64 b1) of - EQ -> compare a0 b0 - LT -> LT - GT -> GT - where - int64OfWord64 (W64# w) = I64# (word2Int# w) - --- ----------------------------------------------------------------------------- --- Functions for `Enum` instance. - - -succ128 :: Int128 -> Int128 -succ128 (Int128 a1 a0) - | a1 == 0x7fffffffffffffff && a0 == maxBound = succError "Int128" - | otherwise = - case a0 + 1 of - 0 -> Int128 (a1 + 1) 0 - s -> Int128 a1 s - -pred128 :: Int128 -> Int128 -pred128 (Int128 a1 a0) - | a1 == 0x8000000000000000 && a0 == 0 = predError "Int128" - | otherwise = - case a0 of - 0 -> Int128 (a1 - 1) maxBound - _ -> Int128 a1 (a0 - 1) - -{-# INLINABLE toEnum128 #-} -toEnum128 :: Int -> Int128 -toEnum128 i = Int128 0 (toEnum i) - -{-# INLINABLE fromEnum128 #-} -fromEnum128 :: Int128 -> Int -fromEnum128 (Int128 _ a0) = fromEnum a0 - --- ----------------------------------------------------------------------------- --- Functions for `Num` instance. - -{-# INLINABLE plus128 #-} -plus128 :: Int128 -> Int128 -> Int128 -plus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# s1) (W64# s0) - where - !(# c1, s0 #) = plusWord2# a0 b0 - s1a = plusWord# a1 b1 - s1 = plusWord# c1 s1a - -{-# INLINABLE minus128 #-} -minus128 :: Int128 -> Int128 -> Int128 -minus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# d1) (W64# d0) - where - !(# d0, c1 #) = subWordC# a0 b0 - a1c = minusWord# a1 (int2Word# c1) - d1 = minusWord# a1c b1 - -times128 :: Int128 -> Int128 -> Int128 -times128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# p1) (W64# p0) - where - !(# c1, p0 #) = timesWord2# a0 b0 - p1a = timesWord# a1 b0 - p1b = timesWord# a0 b1 - p1c = plusWord# p1a p1b - p1 = plusWord# p1c c1 - -{-# INLINABLE negate128 #-} -negate128 :: Int128 -> Int128 -negate128 (Int128 (W64# a1) (W64# a0)) = - case plusWord2# (not# a0) 1## of - (# c, s #) -> Int128 (W64# (plusWord# (not# a1) c)) (W64# s) - -{-# INLINABLE abs128 #-} -abs128 :: Int128 -> Int128 -abs128 i@(Int128 a1 _) - | testBit a1 63 = negate128 i - | otherwise = i - -{-# INLINABLE signum128 #-} -signum128 :: Int128 -> Int128 -signum128 (Int128 a1 a0) - | a1 == 0 && a0 == 0 = zeroInt128 - | testBit a1 63 = minusOneInt128 - | otherwise = oneInt128 - -{-# INLINABLE complement128 #-} -complement128 :: Int128 -> Int128 -complement128 (Int128 a1 a0) = Int128 (complement a1) (complement a0) - -fromInteger128 :: Integer -> Int128 -fromInteger128 i = - Int128 (fromIntegral $ i `shiftR` 64) (fromIntegral i) - --- ----------------------------------------------------------------------------- --- Functions for `Bits` instance. - -{-# INLINABLE and128 #-} -and128 :: Int128 -> Int128 -> Int128 -and128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# (and# a1 b1)) (W64# (and# a0 b0)) - -{-# INLINABLE or128 #-} -or128 :: Int128 -> Int128 -> Int128 -or128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# (or# a1 b1)) (W64# (or# a0 b0)) - -{-# INLINABLE xor128 #-} -xor128 :: Int128 -> Int128 -> Int128 -xor128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = - Int128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0)) - --- Probably not worth inlining this. -shiftL128 :: Int128 -> Int -> Int128 -shiftL128 w@(Int128 a1 a0) s - | s == 0 = w - | s < 0 = shiftL128 w (128 - (abs s `mod` 128)) - | s >= 128 = zeroInt128 - | s == 64 = Int128 a0 0 - | s > 64 = Int128 (a0 `shiftL` (s - 64)) 0 - | otherwise = - Int128 s1 s0 - where - s0 = a0 `shiftL` s - s1 = a1 `shiftL` s + a0 `shiftR` (64 - s) - --- Probably not worth inlining this. -shiftR128 :: Int128 -> Int -> Int128 -shiftR128 i@(Int128 a1 a0) s - | s < 0 = zeroInt128 - | s == 0 = i - | topBitSetWord64 a1 = complement128 (shiftR128 (complement128 i) s) - | s >= 128 = zeroInt128 - | s == 64 = Int128 0 a1 - | s > 64 = Int128 0 (a1 `shiftR` (s - 64)) - | otherwise = Int128 s1 s0 - where - s1 = a1 `shiftR` s - s0 = a0 `shiftR` s + a1 `shiftL` (64 - s) - -rotateL128 :: Int128 -> Int -> Int128 -rotateL128 w@(Int128 a1 a0) r - | r < 0 = zeroInt128 - | r == 0 = w - | r >= 128 = rotateL128 w (r `mod` 128) - | r == 64 = Int128 a0 a1 - | r > 64 = rotateL128 (Int128 a0 a1) (r `mod` 64) - | otherwise = - Int128 s1 s0 - where - s0 = a0 `shiftL` r + a1 `shiftR` (64 - r) - s1 = a1 `shiftL` r + a0 `shiftR` (64 - r) - -rotateR128 :: Int128 -> Int -> Int128 -rotateR128 w@(Int128 a1 a0) r - | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) - | r == 0 = w - | r >= 128 = rotateR128 w (r `mod` 128) - | r == 64 = Int128 a0 a1 - | r > 64 = rotateR128 (Int128 a0 a1) (r `mod` 64) - | otherwise = - Int128 s1 s0 - where - s0 = a0 `shiftR` r + a1 `shiftL` (64 - r) - s1 = a1 `shiftR` r + a0 `shiftL` (64 - r) - -testBit128 :: Int128 -> Int -> Bool -testBit128 (Int128 a1 a0) i - | i < 0 = False - | i >= 128 = False - | i >= 64 = testBit a1 (i - 64) - | otherwise = testBit a0 i - -bit128 :: Int -> Int128 -bit128 indx - | indx < 0 = zeroInt128 - | indx >= 128 = zeroInt128 - | otherwise = shiftL128 oneInt128 indx - -popCount128 :: Int128 -> Int -popCount128 (Int128 a1 a0) = popCount a1 + popCount a0 - --- ----------------------------------------------------------------------------- --- Functions for `FiniteBits` instance. - -countLeadingZeros128 :: Int128 -> Int -countLeadingZeros128 (Int128 a1 a0) = - case countLeadingZeros a1 of - 64 -> 64 + countLeadingZeros a0 - res -> res - -countTrailingZeros128 :: Int128 -> Int -countTrailingZeros128 (Int128 a1 a0) = - case countTrailingZeros a0 of - 64 -> 64 + countTrailingZeros a1 - res -> res - --- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. - -quotRem128 :: Int128 -> Int128 -> (Int128, Int128) -quotRem128 numer denom - | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr)) - | numerIsNegative = (word128ToInt128 (negate wq), word128ToInt128 (negate wr)) - | denomIsNegative = (word128ToInt128 (negate wq), word128ToInt128 wr) - | otherwise = (word128ToInt128 wq, word128ToInt128 wr) - where - (wq, wr) = quotRem absNumerW absDenomW - absNumerW = int128ToWord128 $ abs128 numer - absDenomW = int128ToWord128 $ abs128 denom - numerIsNegative = topBitSetWord64 $ int128Hi64 numer - denomIsNegative = topBitSetWord64 $ int128Hi64 denom - - -divMod128 :: Int128 -> Int128 -> (Int128, Int128) -divMod128 numer denom - | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr)) - | numerIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (absDenomW - wr)) - | denomIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (negate $ absDenomW - wr)) - | otherwise = (word128ToInt128 wq, word128ToInt128 wr) - where - (wq, wr) = quotRem absNumerW absDenomW - numerIsNegative = topBitSetWord64 $ int128Hi64 numer - denomIsNegative = topBitSetWord64 $ int128Hi64 denom - absNumerW = int128ToWord128 $ abs128 numer - absDenomW = int128ToWord128 $ abs128 denom - - -toInteger128 :: Int128 -> Integer -toInteger128 i@(Int128 a1 a0) - | popCount a1 == 64 && popCount a0 == 64 = -1 - | not (testBit a1 63) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 - | otherwise = - case negate128 i of - Int128 n1 n0 -> negate (fromIntegral n1 `shiftL` 64 + fromIntegral n0) - --- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. - -peek128 :: Ptr Int128 -> IO Int128 -peek128 ptr = - Int128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0 - -peekElemOff128 :: Ptr Int128 -> Int -> IO Int128 -peekElemOff128 ptr idx = - Int128 <$> peekElemOff (castPtr ptr) (2 * idx + index1) - <*> peekElemOff (castPtr ptr) (2 * idx + index0) - -poke128 :: Ptr Int128 -> Int128 -> IO () -poke128 ptr (Int128 a1 a0) = - pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0 - -pokeElemOff128 :: Ptr Int128 -> Int -> Int128 -> IO () -pokeElemOff128 ptr idx (Int128 a1 a0) = do - pokeElemOff (castPtr ptr) (2 * idx + index0) a0 - pokeElemOff (castPtr ptr) (2 * idx + index1) a1 - --- ----------------------------------------------------------------------------- --- Helpers. - -{-# INLINE int128ToWord128 #-} -int128ToWord128 :: Int128 -> Word128 -int128ToWord128 (Int128 a1 a0) = Word128 a1 a0 - -{-# INLINE topBitSetWord64 #-} -topBitSetWord64 :: Word64 -> Bool -topBitSetWord64 w = testBit w 63 - -{-# INLINE word128ToInt128 #-} -word128ToInt128 :: Word128 -> Int128 -word128ToInt128 (Word128 a1 a0) = Int128 a1 a0 - --- ----------------------------------------------------------------------------- --- Constants. - -zeroInt128 :: Int128 -zeroInt128 = Int128 0 0 - -oneInt128 :: Int128 -oneInt128 = Int128 0 1 - -minusOneInt128 :: Int128 -minusOneInt128 = Int128 maxBound maxBound - -index0, index1 :: Int -#if WORDS_BIGENDIAN -index0 = 1 -index1 = 0 -#else -index0 = 0 -index1 = 1 -#endif diff --git a/Data/WideWord/Word128.hs b/Data/WideWord/Word128.hs deleted file mode 100644 --- a/Data/WideWord/Word128.hs +++ /dev/null @@ -1,454 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - ------------------------------------------------------------------------------ ----- | ----- Module : Data.WideWord.Word128 ----- ----- Maintainer : erikd@mega-nerd.com ----- Stability : experimental ----- Portability : non-portable (GHC extensions and primops) ----- ----- This module provides an opaque unsigned 128 bit value with the usual set ----- of typeclass instances one would expect for a fixed width unsigned integer ----- type. ----- Operations like addition, subtraction and multiplication etc provide a ----- "modulo 2^128" result as one would expect from a fixed width unsigned word. -------------------------------------------------------------------------------- - -#include - -module Data.WideWord.Word128 - ( Word128 (..) - , byteSwapWord128 - , showHexWord128 - , zeroWord128 - ) where - -import Control.DeepSeq (NFData (..)) - -import Data.Bits (Bits (..), FiniteBits (..), shiftL) - -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (Storable (..)) - -import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2# - , quotRemWord2#, subWordC#, timesWord#, timesWord2#, xor#) -import GHC.Enum (predError, succError) -import GHC.Real ((%), divZeroError) -import GHC.Word (Word64 (..), byteSwap64) - -import Numeric (showHex) - - -data Word128 = Word128 - { word128Hi64 :: {-# UNPACK #-} !Word64 - , word128Lo64 :: {-# UNPACK #-} !Word64 - } - deriving Eq - - -byteSwapWord128 :: Word128 -> Word128 -byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a1) (byteSwap64 a0) - - -showHexWord128 :: Word128 -> String -showHexWord128 (Word128 a1 a0) - | a1 == 0 = showHex a0 "" - | otherwise = showHex a1 zeros ++ showHex a0 "" - where - h0 = showHex a0 "" - zeros = replicate (16 - length h0) '0' - -instance Show Word128 where - show = show . toInteger128 - -instance Read Word128 where - readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s] - -instance Ord Word128 where - compare = compare128 - -instance Bounded Word128 where - minBound = zeroWord128 - maxBound = Word128 maxBound maxBound - -instance Enum Word128 where - succ = succ128 - pred = pred128 - toEnum = toEnum128 - fromEnum = fromEnum128 - -instance Num Word128 where - (+) = plus128 - (-) = minus128 - (*) = times128 - negate = negate128 - abs = id - signum = signum128 - fromInteger = fromInteger128 - -instance Bits Word128 where - (.&.) = and128 - (.|.) = or128 - xor = xor128 - complement = complement128 - shiftL = shiftL128 - unsafeShiftL = shiftL128 - shiftR = shiftR128 - unsafeShiftR = shiftR128 - rotateL = rotateL128 - rotateR = rotateR128 - - bitSize _ = 128 - bitSizeMaybe _ = Just 128 - isSigned _ = False - - testBit = testBit128 - bit = bit128 - - popCount = popCount128 - -instance FiniteBits Word128 where - finiteBitSize _ = 128 - countLeadingZeros = countLeadingZeros128 - countTrailingZeros = countTrailingZeros128 - -instance Real Word128 where - toRational x = toInteger128 x % 1 - -instance Integral Word128 where - quot n d = fst (quotRem128 n d) - rem n d = snd (quotRem128 n d) - div n d = fst (quotRem128 n d) - mod n d = snd (quotRem128 n d) - quotRem = quotRem128 - divMod = quotRem128 - toInteger = toInteger128 - -instance Storable Word128 where - sizeOf _ = 2 * sizeOf (0 :: Word64) - alignment _ = 2 * alignment (0 :: Word64) - peek = peek128 - peekElemOff = peekElemOff128 - poke = poke128 - pokeElemOff = pokeElemOff128 - -instance NFData Word128 where - rnf (Word128 a1 a0) = rnf a1 `seq` rnf a0 - --- ----------------------------------------------------------------------------- --- Rewrite rules. - -{-# RULES -"fromIntegral :: Word128 -> Word128" fromIntegral = id :: Word128 -> Word128 - #-} - -{-# RULES -"fromIntegral :: Int -> Word128" fromIntegral = \(I# i#) -> Word128 (W64# 0##) (W64# (int2Word# i#)) -"fromIntegral :: Word- > Word128" fromIntegral = Word128 0 . fromIntegral -"fromIntegral :: Word32 -> Word128" fromIntegral = Word128 0 . fromIntegral -"fromIntegral :: Word64 -> Word128" fromIntegral = Word128 0 - -"fromIntegral :: Word128 -> Int" fromIntegral = \(Word128 _ w) -> fromIntegral w -"fromIntegral :: Word128 -> Word" fromIntegral = \(Word128 _ w) -> fromIntegral w -"fromIntegral :: Word128 -> Word32" fromIntegral = \(Word128 _ w) -> fromIntegral w -"fromIntegral :: Word128 -> Word64" fromIntegral = \(Word128 _ w) -> w - #-} - --- ----------------------------------------------------------------------------- --- Functions for `Ord` instance. - -compare128 :: Word128 -> Word128 -> Ordering -compare128 (Word128 a1 a0) (Word128 b1 b0) = - case compare a1 b1 of - EQ -> compare a0 b0 - LT -> LT - GT -> GT - --- ----------------------------------------------------------------------------- --- Functions for `Enum` instance. - -succ128 :: Word128 -> Word128 -succ128 (Word128 a1 a0) - | a1 == maxBound && a0 == maxBound = succError "Word128" - | otherwise = - case a0 + 1 of - 0 -> Word128 (a1 + 1) 0 - s -> Word128 a1 s - -pred128 :: Word128 -> Word128 -pred128 (Word128 a1 a0) - | a1 == 0 && a0 == 0 = predError "Word128" - | otherwise = - case a0 of - 0 -> Word128 (a1 - 1) maxBound - _ -> Word128 a1 (a0 - 1) - -{-# INLINABLE toEnum128 #-} -toEnum128 :: Int -> Word128 -toEnum128 i = Word128 0 (toEnum i) - -{-# INLINABLE fromEnum128 #-} -fromEnum128 :: Word128 -> Int -fromEnum128 (Word128 _ a0) = fromEnum a0 - --- ----------------------------------------------------------------------------- --- Functions for `Num` instance. - -{-# INLINABLE plus128 #-} -plus128 :: Word128 -> Word128 -> Word128 -plus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# s1) (W64# s0) - where - !(# c1, s0 #) = plusWord2# a0 b0 - s1a = plusWord# a1 b1 - s1 = plusWord# c1 s1a - -{-# INLINABLE minus128 #-} -minus128 :: Word128 -> Word128 -> Word128 -minus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# d1) (W64# d0) - where - !(# d0, c1 #) = subWordC# a0 b0 - a1c = minusWord# a1 (int2Word# c1) - d1 = minusWord# a1c b1 - -times128 :: Word128 -> Word128 -> Word128 -times128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# p1) (W64# p0) - where - !(# c1, p0 #) = timesWord2# a0 b0 - p1a = timesWord# a1 b0 - p1b = timesWord# a0 b1 - p1c = plusWord# p1a p1b - p1 = plusWord# p1c c1 - -{-# INLINABLE negate128 #-} -negate128 :: Word128 -> Word128 -negate128 (Word128 (W64# a1) (W64# a0)) = - case plusWord2# (not# a0) 1## of - (# c, s #) -> Word128 (W64# (plusWord# (not# a1) c)) (W64# s) - -{-# INLINABLE signum128 #-} -signum128 :: Word128 -> Word128 -signum128 (Word128 (W64# 0##) (W64# 0##)) = zeroWord128 -signum128 _ = oneWord128 - -fromInteger128 :: Integer -> Word128 -fromInteger128 i = - Word128 (fromIntegral $ i `shiftR` 64) (fromIntegral i) - --- ----------------------------------------------------------------------------- --- Functions for `Bits` instance. - -{-# INLINABLE and128 #-} -and128 :: Word128 -> Word128 -> Word128 -and128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# (and# a1 b1)) (W64# (and# a0 b0)) - -{-# INLINABLE or128 #-} -or128 :: Word128 -> Word128 -> Word128 -or128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# (or# a1 b1)) (W64# (or# a0 b0)) - -{-# INLINABLE xor128 #-} -xor128 :: Word128 -> Word128 -> Word128 -xor128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = - Word128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0)) - -{-# INLINABLE complement128 #-} -complement128 :: Word128 -> Word128 -complement128 (Word128 a1 a0) = Word128 (complement a1) (complement a0) - --- Probably not worth inlining this. -shiftL128 :: Word128 -> Int -> Word128 -shiftL128 w@(Word128 a1 a0) s - | s == 0 = w - | s < 0 = shiftL128 w (128 - (abs s `mod` 128)) - | s >= 128 = zeroWord128 - | s == 64 = Word128 a0 0 - | s > 64 = Word128 (a0 `shiftL` (s - 64)) 0 - | otherwise = - Word128 s1 s0 - where - s0 = a0 `shiftL` s - s1 = a1 `shiftL` s + a0 `shiftR` (64 - s) - --- Probably not worth inlining this. -shiftR128 :: Word128 -> Int -> Word128 -shiftR128 w@(Word128 a1 a0) s - | s < 0 = zeroWord128 - | s == 0 = w - | s >= 128 = zeroWord128 - | s == 64 = Word128 0 a1 - | s > 64 = Word128 0 (a1 `shiftR` (s - 64)) - | otherwise = - Word128 s1 s0 - where - s1 = a1 `shiftR` s - s0 = a0 `shiftR` s + a1 `shiftL` (64 - s) - -rotateL128 :: Word128 -> Int -> Word128 -rotateL128 w@(Word128 a1 a0) r - | r < 0 = zeroWord128 - | r == 0 = w - | r >= 128 = rotateL128 w (r `mod` 128) - | r == 64 = Word128 a0 a1 - | r > 64 = rotateL128 (Word128 a0 a1) (r `mod` 64) - | otherwise = - Word128 s1 s0 - where - s0 = a0 `shiftL` r + a1 `shiftR` (64 - r) - s1 = a1 `shiftL` r + a0 `shiftR` (64 - r) - -rotateR128 :: Word128 -> Int -> Word128 -rotateR128 w@(Word128 a1 a0) r - | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) - | r == 0 = w - | r >= 128 = rotateR128 w (r `mod` 128) - | r == 64 = Word128 a0 a1 - | r > 64 = rotateR128 (Word128 a0 a1) (r `mod` 64) - | otherwise = - Word128 s1 s0 - where - s0 = a0 `shiftR` r + a1 `shiftL` (64 - r) - s1 = a1 `shiftR` r + a0 `shiftL` (64 - r) - -testBit128 :: Word128 -> Int -> Bool -testBit128 (Word128 a1 a0) i - | i < 0 = False - | i >= 128 = False - | i >= 64 = testBit a1 (i - 64) - | otherwise = testBit a0 i - -bit128 :: Int -> Word128 -bit128 indx - | indx < 0 = zeroWord128 - | indx >= 128 = zeroWord128 - | otherwise = shiftL128 oneWord128 indx - -popCount128 :: Word128 -> Int -popCount128 (Word128 a1 a0) = popCount a1 + popCount a0 - --- ----------------------------------------------------------------------------- --- Functions for `FiniteBits` instance. - -countLeadingZeros128 :: Word128 -> Int -countLeadingZeros128 (Word128 a1 a0) = - case countLeadingZeros a1 of - 64 -> 64 + countLeadingZeros a0 - res -> res - -countTrailingZeros128 :: Word128 -> Int -countTrailingZeros128 (Word128 a1 a0) = - case countTrailingZeros a0 of - 64 -> 64 + countTrailingZeros a1 - res -> res - --- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. - -quotRem128 :: Word128 -> Word128 -> (Word128, Word128) -quotRem128 num@(Word128 n1 n0) den@(Word128 d1 d0) - | n1 == 0 && d1 == 0 = quotRemTwo n0 d0 - | n1 < d1 = (zeroWord128, num) - | d1 == 0 = quotRemThree num d0 - | otherwise = quotRemFour num den - - -quotRemFour :: Word128 -> Word128 -> (Word128, Word128) -quotRemFour num@(Word128 n1 _) den@(Word128 d1 d0) - | n1 == d1 = quotRemFourX num d0 - | otherwise = (q, r) - where - qtest = quot n1 d1 - diff = times128 den (Word128 0 qtest) - (q, r) = case compare128 num diff of - EQ -> (Word128 0 qtest, zeroWord128) - GT -> (Word128 0 qtest, minus128 num diff) - LT -> let qx = Word128 0 (qtest - 1) - diffx = times128 den qx - in (qx, minus128 num diffx) - - -{-# INLINE quotRemFourX #-} -quotRemFourX :: Word128 -> Word64 -> (Word128, Word128) -quotRemFourX num@(Word128 _ n0) d0 = - case compare n0 d0 of - LT -> (zeroWord128, num) - EQ -> (oneWord128, zeroWord128) - GT -> (Word128 0 1, Word128 0 (n0 - d0)) - - -{-# INLINE quotRemThree #-} -quotRemThree :: Word128 -> Word64 -> (Word128, Word128) -quotRemThree num@(Word128 n1 n0) den - | den == 0 = divZeroError - | den == 1 = (num, zeroWord128) - | n1 < den = case quotRemWord2 n1 n0 den of - (q, r) -> (Word128 0 q, Word128 0 r) - | otherwise = - case quotRem n1 den of - (q1, r1) -> case quotRemWord2 r1 n0 den of - (q0, r0) -> (Word128 q1 q0, Word128 0 r0) - -{-# INLINE quotRemWord2 #-} -quotRemWord2 :: Word64 -> Word64 -> Word64 -> (Word64, Word64) -quotRemWord2 (W64# n1) (W64# n0) (W64# d) = - case quotRemWord2# n1 n0 d of - (# q, r #) -> (W64# q, W64# r) - - -{-# INLINE quotRemTwo #-} -quotRemTwo :: Word64 -> Word64 -> (Word128, Word128) -quotRemTwo n0 d0 = - case quotRem n0 d0 of - (q, r) -> (Word128 0 q, Word128 0 r) - -toInteger128 :: Word128 -> Integer -toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 - --- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. - -peek128 :: Ptr Word128 -> IO Word128 -peek128 ptr = - Word128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0 - -peekElemOff128 :: Ptr Word128 -> Int -> IO Word128 -peekElemOff128 ptr idx = - Word128 <$> peekElemOff (castPtr ptr) (2 * idx + index1) - <*> peekElemOff (castPtr ptr) (2 * idx + index0) - -poke128 :: Ptr Word128 -> Word128 -> IO () -poke128 ptr (Word128 a1 a0) = - pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0 - -pokeElemOff128 :: Ptr Word128 -> Int -> Word128 -> IO () -pokeElemOff128 ptr idx (Word128 a1 a0) = do - pokeElemOff (castPtr ptr) (2 * idx + index0) a0 - pokeElemOff (castPtr ptr) (2 * idx + index1) a1 - --- ----------------------------------------------------------------------------- --- Constants. - -zeroWord128 :: Word128 -zeroWord128 = Word128 0 0 - -oneWord128 :: Word128 -oneWord128 = Word128 0 1 - --- Use these indices to get the peek/poke ordering endian correct. -index0, index1 :: Int -#if WORDS_BIGENDIAN -index0 = 1 -index1 = 0 -#else -index0 = 0 -index1 = 1 -#endif diff --git a/src/Data/WideWord.hs b/src/Data/WideWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/WideWord.hs @@ -0,0 +1,6 @@ +module Data.WideWord + ( module X + ) where + +import Data.WideWord.Int128 as X +import Data.WideWord.Word128 as X diff --git a/src/Data/WideWord/Int128.hs b/src/Data/WideWord/Int128.hs new file mode 100644 --- /dev/null +++ b/src/Data/WideWord/Int128.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +----------------------------------------------------------------------------- +---- | +---- Module : Data.WideWord.Int128 +---- +---- Maintainer : erikd@mega-nerd.com +---- Stability : experimental +---- Portability : non-portable (GHC extensions and primops) +---- +---- This module provides an opaque signed 128 bit value with the usual set +---- of typeclass instances one would expect for a fixed width unsigned integer +---- type. +---- Operations like addition, subtraction and multiplication etc provide a +---- "modulo 2^128" result as one would expect from a fixed width unsigned word. +------------------------------------------------------------------------------- + +#include + +module Data.WideWord.Int128 + ( Int128 (..) + , byteSwapInt128 + , showHexInt128 + , zeroInt128 + ) where + +import Control.DeepSeq (NFData (..)) + +import Data.Bits (Bits (..), FiniteBits (..), shiftL) + +import Data.WideWord.Word128 + +import Numeric + +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable (..)) + +import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2# + , subWordC#, timesWord#, timesWord2#, word2Int#, xor#) +import GHC.Enum (predError, succError) +import GHC.Int (Int64 (..)) +import GHC.Real ((%)) +import GHC.Word (Word64 (..), byteSwap64) + + +data Int128 = Int128 + { int128Hi64 :: {-# UNPACK #-} !Word64 + , int128Lo64 :: {-# UNPACK #-} !Word64 + } + deriving Eq + + +byteSwapInt128 :: Int128 -> Int128 +byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a0) (byteSwap64 a1) + + +showHexInt128 :: Int128 -> String +showHexInt128 (Int128 a1 a0) + | a1 == 0 = showHex a0 "" + | otherwise = showHex a1 zeros ++ showHex a0 "" + where + h0 = showHex a0 "" + zeros = replicate (16 - length h0) '0' + +instance Show Int128 where + show = show . toInteger + +instance Read Int128 where + readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s] + +instance Ord Int128 where + compare = compare128 + +instance Bounded Int128 where + minBound = Int128 0x8000000000000000 0 + maxBound = Int128 0x7fffffffffffffff maxBound + +instance Enum Int128 where + succ = succ128 + pred = pred128 + toEnum = toEnum128 + fromEnum = fromEnum128 + +instance Num Int128 where + (+) = plus128 + (-) = minus128 + (*) = times128 + negate = negate128 + abs = abs128 + signum = signum128 + fromInteger = fromInteger128 + +instance Bits Int128 where + (.&.) = and128 + (.|.) = or128 + xor = xor128 + complement = complement128 + shiftL = shiftL128 + unsafeShiftL = shiftL128 + shiftR = shiftR128 + unsafeShiftR = shiftR128 + rotateL = rotateL128 + rotateR = rotateR128 + + bitSize _ = 128 + bitSizeMaybe _ = Just 128 + isSigned _ = False + + testBit = testBit128 + bit = bit128 + + popCount = popCount128 + +instance FiniteBits Int128 where + finiteBitSize _ = 128 + countLeadingZeros = countLeadingZeros128 + countTrailingZeros = countTrailingZeros128 + +instance Real Int128 where + toRational x = toInteger128 x % 1 + +instance Integral Int128 where + quot n d = fst (quotRem128 n d) + rem n d = snd (quotRem128 n d) + div n d = fst (divMod128 n d) + mod n d = snd (divMod128 n d) + quotRem = quotRem128 + divMod = divMod128 + toInteger = toInteger128 + +instance Storable Int128 where + sizeOf _ = 2 * sizeOf (0 :: Word64) + alignment _ = 2 * alignment (0 :: Word64) + peek = peek128 + peekElemOff = peekElemOff128 + poke = poke128 + pokeElemOff = pokeElemOff128 + +instance NFData Int128 where + rnf (Int128 a1 a0) = rnf a1 `seq` rnf a0 + +-- ----------------------------------------------------------------------------- +-- Rewrite rules. + +{-# RULES +"fromIntegral :: Int128 -> Int128" fromIntegral = id :: Int128 -> Int128 +"fromIntegral :: Word128 -> Int128" fromIntegral = \(Word128 a1 a0) -> Int128 a1 a0 +"fromIntegral :: Int128 -> Word128" fromIntegral = \(Int128 a1 a0) -> Word128 a1 a0 + #-} + +-- ----------------------------------------------------------------------------- +-- Functions for `Ord` instance. + +compare128 :: Int128 -> Int128 -> Ordering +compare128 (Int128 a1 a0) (Int128 b1 b0) = + case compare (int64OfWord64 a1) (int64OfWord64 b1) of + EQ -> compare a0 b0 + LT -> LT + GT -> GT + where + int64OfWord64 (W64# w) = I64# (word2Int# w) + +-- ----------------------------------------------------------------------------- +-- Functions for `Enum` instance. + + +succ128 :: Int128 -> Int128 +succ128 (Int128 a1 a0) + | a1 == 0x7fffffffffffffff && a0 == maxBound = succError "Int128" + | otherwise = + case a0 + 1 of + 0 -> Int128 (a1 + 1) 0 + s -> Int128 a1 s + +pred128 :: Int128 -> Int128 +pred128 (Int128 a1 a0) + | a1 == 0x8000000000000000 && a0 == 0 = predError "Int128" + | otherwise = + case a0 of + 0 -> Int128 (a1 - 1) maxBound + _ -> Int128 a1 (a0 - 1) + +{-# INLINABLE toEnum128 #-} +toEnum128 :: Int -> Int128 +toEnum128 i = Int128 0 (toEnum i) + +{-# INLINABLE fromEnum128 #-} +fromEnum128 :: Int128 -> Int +fromEnum128 (Int128 _ a0) = fromEnum a0 + +-- ----------------------------------------------------------------------------- +-- Functions for `Num` instance. + +{-# INLINABLE plus128 #-} +plus128 :: Int128 -> Int128 -> Int128 +plus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# s1) (W64# s0) + where + !(# c1, s0 #) = plusWord2# a0 b0 + s1a = plusWord# a1 b1 + s1 = plusWord# c1 s1a + +{-# INLINABLE minus128 #-} +minus128 :: Int128 -> Int128 -> Int128 +minus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# d1) (W64# d0) + where + !(# d0, c1 #) = subWordC# a0 b0 + a1c = minusWord# a1 (int2Word# c1) + d1 = minusWord# a1c b1 + +times128 :: Int128 -> Int128 -> Int128 +times128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# p1) (W64# p0) + where + !(# c1, p0 #) = timesWord2# a0 b0 + p1a = timesWord# a1 b0 + p1b = timesWord# a0 b1 + p1c = plusWord# p1a p1b + p1 = plusWord# p1c c1 + +{-# INLINABLE negate128 #-} +negate128 :: Int128 -> Int128 +negate128 (Int128 (W64# a1) (W64# a0)) = + case plusWord2# (not# a0) 1## of + (# c, s #) -> Int128 (W64# (plusWord# (not# a1) c)) (W64# s) + +{-# INLINABLE abs128 #-} +abs128 :: Int128 -> Int128 +abs128 i@(Int128 a1 _) + | testBit a1 63 = negate128 i + | otherwise = i + +{-# INLINABLE signum128 #-} +signum128 :: Int128 -> Int128 +signum128 (Int128 a1 a0) + | a1 == 0 && a0 == 0 = zeroInt128 + | testBit a1 63 = minusOneInt128 + | otherwise = oneInt128 + +{-# INLINABLE complement128 #-} +complement128 :: Int128 -> Int128 +complement128 (Int128 a1 a0) = Int128 (complement a1) (complement a0) + +fromInteger128 :: Integer -> Int128 +fromInteger128 i = + Int128 (fromIntegral $ i `shiftR` 64) (fromIntegral i) + +-- ----------------------------------------------------------------------------- +-- Functions for `Bits` instance. + +{-# INLINABLE and128 #-} +and128 :: Int128 -> Int128 -> Int128 +and128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# (and# a1 b1)) (W64# (and# a0 b0)) + +{-# INLINABLE or128 #-} +or128 :: Int128 -> Int128 -> Int128 +or128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# (or# a1 b1)) (W64# (or# a0 b0)) + +{-# INLINABLE xor128 #-} +xor128 :: Int128 -> Int128 -> Int128 +xor128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) = + Int128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0)) + +-- Probably not worth inlining this. +shiftL128 :: Int128 -> Int -> Int128 +shiftL128 w@(Int128 a1 a0) s + | s == 0 = w + | s < 0 = shiftL128 w (128 - (abs s `mod` 128)) + | s >= 128 = zeroInt128 + | s == 64 = Int128 a0 0 + | s > 64 = Int128 (a0 `shiftL` (s - 64)) 0 + | otherwise = + Int128 s1 s0 + where + s0 = a0 `shiftL` s + s1 = a1 `shiftL` s + a0 `shiftR` (64 - s) + +-- Probably not worth inlining this. +shiftR128 :: Int128 -> Int -> Int128 +shiftR128 i@(Int128 a1 a0) s + | s < 0 = zeroInt128 + | s == 0 = i + | topBitSetWord64 a1 = complement128 (shiftR128 (complement128 i) s) + | s >= 128 = zeroInt128 + | s == 64 = Int128 0 a1 + | s > 64 = Int128 0 (a1 `shiftR` (s - 64)) + | otherwise = Int128 s1 s0 + where + s1 = a1 `shiftR` s + s0 = a0 `shiftR` s + a1 `shiftL` (64 - s) + +rotateL128 :: Int128 -> Int -> Int128 +rotateL128 w@(Int128 a1 a0) r + | r < 0 = zeroInt128 + | r == 0 = w + | r >= 128 = rotateL128 w (r `mod` 128) + | r == 64 = Int128 a0 a1 + | r > 64 = rotateL128 (Int128 a0 a1) (r `mod` 64) + | otherwise = + Int128 s1 s0 + where + s0 = a0 `shiftL` r + a1 `shiftR` (64 - r) + s1 = a1 `shiftL` r + a0 `shiftR` (64 - r) + +rotateR128 :: Int128 -> Int -> Int128 +rotateR128 w@(Int128 a1 a0) r + | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) + | r == 0 = w + | r >= 128 = rotateR128 w (r `mod` 128) + | r == 64 = Int128 a0 a1 + | r > 64 = rotateR128 (Int128 a0 a1) (r `mod` 64) + | otherwise = + Int128 s1 s0 + where + s0 = a0 `shiftR` r + a1 `shiftL` (64 - r) + s1 = a1 `shiftR` r + a0 `shiftL` (64 - r) + +testBit128 :: Int128 -> Int -> Bool +testBit128 (Int128 a1 a0) i + | i < 0 = False + | i >= 128 = False + | i >= 64 = testBit a1 (i - 64) + | otherwise = testBit a0 i + +bit128 :: Int -> Int128 +bit128 indx + | indx < 0 = zeroInt128 + | indx >= 128 = zeroInt128 + | otherwise = shiftL128 oneInt128 indx + +popCount128 :: Int128 -> Int +popCount128 (Int128 a1 a0) = popCount a1 + popCount a0 + +-- ----------------------------------------------------------------------------- +-- Functions for `FiniteBits` instance. + +countLeadingZeros128 :: Int128 -> Int +countLeadingZeros128 (Int128 a1 a0) = + case countLeadingZeros a1 of + 64 -> 64 + countLeadingZeros a0 + res -> res + +countTrailingZeros128 :: Int128 -> Int +countTrailingZeros128 (Int128 a1 a0) = + case countTrailingZeros a0 of + 64 -> 64 + countTrailingZeros a1 + res -> res + +-- ----------------------------------------------------------------------------- +-- Functions for `Integral` instance. + +quotRem128 :: Int128 -> Int128 -> (Int128, Int128) +quotRem128 numer denom + | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr)) + | numerIsNegative = (word128ToInt128 (negate wq), word128ToInt128 (negate wr)) + | denomIsNegative = (word128ToInt128 (negate wq), word128ToInt128 wr) + | otherwise = (word128ToInt128 wq, word128ToInt128 wr) + where + (wq, wr) = quotRem absNumerW absDenomW + absNumerW = int128ToWord128 $ abs128 numer + absDenomW = int128ToWord128 $ abs128 denom + numerIsNegative = topBitSetWord64 $ int128Hi64 numer + denomIsNegative = topBitSetWord64 $ int128Hi64 denom + + +divMod128 :: Int128 -> Int128 -> (Int128, Int128) +divMod128 numer denom + | numerIsNegative && denomIsNegative = (word128ToInt128 wq, word128ToInt128 (negate wr)) + | numerIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (absDenomW - wr)) + | denomIsNegative = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (negate $ absDenomW - wr)) + | otherwise = (word128ToInt128 wq, word128ToInt128 wr) + where + (wq, wr) = quotRem absNumerW absDenomW + numerIsNegative = topBitSetWord64 $ int128Hi64 numer + denomIsNegative = topBitSetWord64 $ int128Hi64 denom + absNumerW = int128ToWord128 $ abs128 numer + absDenomW = int128ToWord128 $ abs128 denom + + +toInteger128 :: Int128 -> Integer +toInteger128 i@(Int128 a1 a0) + | popCount a1 == 64 && popCount a0 == 64 = -1 + | not (testBit a1 63) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 + | otherwise = + case negate128 i of + Int128 n1 n0 -> negate (fromIntegral n1 `shiftL` 64 + fromIntegral n0) + +-- ----------------------------------------------------------------------------- +-- Functions for `Integral` instance. + +peek128 :: Ptr Int128 -> IO Int128 +peek128 ptr = + Int128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0 + +peekElemOff128 :: Ptr Int128 -> Int -> IO Int128 +peekElemOff128 ptr idx = + Int128 <$> peekElemOff (castPtr ptr) (2 * idx + index1) + <*> peekElemOff (castPtr ptr) (2 * idx + index0) + +poke128 :: Ptr Int128 -> Int128 -> IO () +poke128 ptr (Int128 a1 a0) = + pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0 + +pokeElemOff128 :: Ptr Int128 -> Int -> Int128 -> IO () +pokeElemOff128 ptr idx (Int128 a1 a0) = do + pokeElemOff (castPtr ptr) (2 * idx + index0) a0 + pokeElemOff (castPtr ptr) (2 * idx + index1) a1 + +-- ----------------------------------------------------------------------------- +-- Helpers. + +{-# INLINE int128ToWord128 #-} +int128ToWord128 :: Int128 -> Word128 +int128ToWord128 (Int128 a1 a0) = Word128 a1 a0 + +{-# INLINE topBitSetWord64 #-} +topBitSetWord64 :: Word64 -> Bool +topBitSetWord64 w = testBit w 63 + +{-# INLINE word128ToInt128 #-} +word128ToInt128 :: Word128 -> Int128 +word128ToInt128 (Word128 a1 a0) = Int128 a1 a0 + +-- ----------------------------------------------------------------------------- +-- Constants. + +zeroInt128 :: Int128 +zeroInt128 = Int128 0 0 + +oneInt128 :: Int128 +oneInt128 = Int128 0 1 + +minusOneInt128 :: Int128 +minusOneInt128 = Int128 maxBound maxBound + +index0, index1 :: Int +#if WORDS_BIGENDIAN +index0 = 1 +index1 = 0 +#else +index0 = 0 +index1 = 1 +#endif diff --git a/src/Data/WideWord/Word128.hs b/src/Data/WideWord/Word128.hs new file mode 100644 --- /dev/null +++ b/src/Data/WideWord/Word128.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +----------------------------------------------------------------------------- +---- | +---- Module : Data.WideWord.Word128 +---- +---- Maintainer : erikd@mega-nerd.com +---- Stability : experimental +---- Portability : non-portable (GHC extensions and primops) +---- +---- This module provides an opaque unsigned 128 bit value with the usual set +---- of typeclass instances one would expect for a fixed width unsigned integer +---- type. +---- Operations like addition, subtraction and multiplication etc provide a +---- "modulo 2^128" result as one would expect from a fixed width unsigned word. +------------------------------------------------------------------------------- + +#include + +module Data.WideWord.Word128 + ( Word128 (..) + , byteSwapWord128 + , showHexWord128 + , zeroWord128 + ) where + +import Control.DeepSeq (NFData (..)) + +import Data.Bits (Bits (..), FiniteBits (..), shiftL) + +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable (..)) + +import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2# + , quotRemWord2#, subWordC#, timesWord#, timesWord2#, xor#) +import GHC.Enum (predError, succError) +import GHC.Real ((%), divZeroError) +import GHC.Word (Word64 (..), byteSwap64) + +import Numeric (showHex) + + +data Word128 = Word128 + { word128Hi64 :: {-# UNPACK #-} !Word64 + , word128Lo64 :: {-# UNPACK #-} !Word64 + } + deriving Eq + + +byteSwapWord128 :: Word128 -> Word128 +byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a0) (byteSwap64 a1) + + +showHexWord128 :: Word128 -> String +showHexWord128 (Word128 a1 a0) + | a1 == 0 = showHex a0 "" + | otherwise = showHex a1 zeros ++ showHex a0 "" + where + h0 = showHex a0 "" + zeros = replicate (16 - length h0) '0' + +instance Show Word128 where + show = show . toInteger128 + +instance Read Word128 where + readsPrec p s = [(fromInteger128 (x :: Integer), r) | (x, r) <- readsPrec p s] + +instance Ord Word128 where + compare = compare128 + +instance Bounded Word128 where + minBound = zeroWord128 + maxBound = Word128 maxBound maxBound + +instance Enum Word128 where + succ = succ128 + pred = pred128 + toEnum = toEnum128 + fromEnum = fromEnum128 + +instance Num Word128 where + (+) = plus128 + (-) = minus128 + (*) = times128 + negate = negate128 + abs = id + signum = signum128 + fromInteger = fromInteger128 + +instance Bits Word128 where + (.&.) = and128 + (.|.) = or128 + xor = xor128 + complement = complement128 + shiftL = shiftL128 + unsafeShiftL = shiftL128 + shiftR = shiftR128 + unsafeShiftR = shiftR128 + rotateL = rotateL128 + rotateR = rotateR128 + + bitSize _ = 128 + bitSizeMaybe _ = Just 128 + isSigned _ = False + + testBit = testBit128 + bit = bit128 + + popCount = popCount128 + +instance FiniteBits Word128 where + finiteBitSize _ = 128 + countLeadingZeros = countLeadingZeros128 + countTrailingZeros = countTrailingZeros128 + +instance Real Word128 where + toRational x = toInteger128 x % 1 + +instance Integral Word128 where + quot n d = fst (quotRem128 n d) + rem n d = snd (quotRem128 n d) + div n d = fst (quotRem128 n d) + mod n d = snd (quotRem128 n d) + quotRem = quotRem128 + divMod = quotRem128 + toInteger = toInteger128 + +instance Storable Word128 where + sizeOf _ = 2 * sizeOf (0 :: Word64) + alignment _ = 2 * alignment (0 :: Word64) + peek = peek128 + peekElemOff = peekElemOff128 + poke = poke128 + pokeElemOff = pokeElemOff128 + +instance NFData Word128 where + rnf (Word128 a1 a0) = rnf a1 `seq` rnf a0 + +-- ----------------------------------------------------------------------------- +-- Rewrite rules. + +{-# RULES +"fromIntegral :: Word128 -> Word128" fromIntegral = id :: Word128 -> Word128 + #-} + +{-# RULES +"fromIntegral :: Int -> Word128" fromIntegral = \(I# i#) -> Word128 (W64# 0##) (W64# (int2Word# i#)) +"fromIntegral :: Word- > Word128" fromIntegral = Word128 0 . fromIntegral +"fromIntegral :: Word32 -> Word128" fromIntegral = Word128 0 . fromIntegral +"fromIntegral :: Word64 -> Word128" fromIntegral = Word128 0 + +"fromIntegral :: Word128 -> Int" fromIntegral = \(Word128 _ w) -> fromIntegral w +"fromIntegral :: Word128 -> Word" fromIntegral = \(Word128 _ w) -> fromIntegral w +"fromIntegral :: Word128 -> Word32" fromIntegral = \(Word128 _ w) -> fromIntegral w +"fromIntegral :: Word128 -> Word64" fromIntegral = \(Word128 _ w) -> w + #-} + +-- ----------------------------------------------------------------------------- +-- Functions for `Ord` instance. + +compare128 :: Word128 -> Word128 -> Ordering +compare128 (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> compare a0 b0 + LT -> LT + GT -> GT + +-- ----------------------------------------------------------------------------- +-- Functions for `Enum` instance. + +succ128 :: Word128 -> Word128 +succ128 (Word128 a1 a0) + | a1 == maxBound && a0 == maxBound = succError "Word128" + | otherwise = + case a0 + 1 of + 0 -> Word128 (a1 + 1) 0 + s -> Word128 a1 s + +pred128 :: Word128 -> Word128 +pred128 (Word128 a1 a0) + | a1 == 0 && a0 == 0 = predError "Word128" + | otherwise = + case a0 of + 0 -> Word128 (a1 - 1) maxBound + _ -> Word128 a1 (a0 - 1) + +{-# INLINABLE toEnum128 #-} +toEnum128 :: Int -> Word128 +toEnum128 i = Word128 0 (toEnum i) + +{-# INLINABLE fromEnum128 #-} +fromEnum128 :: Word128 -> Int +fromEnum128 (Word128 _ a0) = fromEnum a0 + +-- ----------------------------------------------------------------------------- +-- Functions for `Num` instance. + +{-# INLINABLE plus128 #-} +plus128 :: Word128 -> Word128 -> Word128 +plus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# s1) (W64# s0) + where + !(# c1, s0 #) = plusWord2# a0 b0 + s1a = plusWord# a1 b1 + s1 = plusWord# c1 s1a + +{-# INLINABLE minus128 #-} +minus128 :: Word128 -> Word128 -> Word128 +minus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# d1) (W64# d0) + where + !(# d0, c1 #) = subWordC# a0 b0 + a1c = minusWord# a1 (int2Word# c1) + d1 = minusWord# a1c b1 + +times128 :: Word128 -> Word128 -> Word128 +times128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# p1) (W64# p0) + where + !(# c1, p0 #) = timesWord2# a0 b0 + p1a = timesWord# a1 b0 + p1b = timesWord# a0 b1 + p1c = plusWord# p1a p1b + p1 = plusWord# p1c c1 + +{-# INLINABLE negate128 #-} +negate128 :: Word128 -> Word128 +negate128 (Word128 (W64# a1) (W64# a0)) = + case plusWord2# (not# a0) 1## of + (# c, s #) -> Word128 (W64# (plusWord# (not# a1) c)) (W64# s) + +{-# INLINABLE signum128 #-} +signum128 :: Word128 -> Word128 +signum128 (Word128 (W64# 0##) (W64# 0##)) = zeroWord128 +signum128 _ = oneWord128 + +fromInteger128 :: Integer -> Word128 +fromInteger128 i = + Word128 (fromIntegral $ i `shiftR` 64) (fromIntegral i) + +-- ----------------------------------------------------------------------------- +-- Functions for `Bits` instance. + +{-# INLINABLE and128 #-} +and128 :: Word128 -> Word128 -> Word128 +and128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# (and# a1 b1)) (W64# (and# a0 b0)) + +{-# INLINABLE or128 #-} +or128 :: Word128 -> Word128 -> Word128 +or128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# (or# a1 b1)) (W64# (or# a0 b0)) + +{-# INLINABLE xor128 #-} +xor128 :: Word128 -> Word128 -> Word128 +xor128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = + Word128 (W64# (xor# a1 b1)) (W64# (xor# a0 b0)) + +{-# INLINABLE complement128 #-} +complement128 :: Word128 -> Word128 +complement128 (Word128 a1 a0) = Word128 (complement a1) (complement a0) + +-- Probably not worth inlining this. +shiftL128 :: Word128 -> Int -> Word128 +shiftL128 w@(Word128 a1 a0) s + | s == 0 = w + | s < 0 = shiftL128 w (128 - (abs s `mod` 128)) + | s >= 128 = zeroWord128 + | s == 64 = Word128 a0 0 + | s > 64 = Word128 (a0 `shiftL` (s - 64)) 0 + | otherwise = + Word128 s1 s0 + where + s0 = a0 `shiftL` s + s1 = a1 `shiftL` s + a0 `shiftR` (64 - s) + +-- Probably not worth inlining this. +shiftR128 :: Word128 -> Int -> Word128 +shiftR128 w@(Word128 a1 a0) s + | s < 0 = zeroWord128 + | s == 0 = w + | s >= 128 = zeroWord128 + | s == 64 = Word128 0 a1 + | s > 64 = Word128 0 (a1 `shiftR` (s - 64)) + | otherwise = + Word128 s1 s0 + where + s1 = a1 `shiftR` s + s0 = a0 `shiftR` s + a1 `shiftL` (64 - s) + +rotateL128 :: Word128 -> Int -> Word128 +rotateL128 w@(Word128 a1 a0) r + | r < 0 = zeroWord128 + | r == 0 = w + | r >= 128 = rotateL128 w (r `mod` 128) + | r == 64 = Word128 a0 a1 + | r > 64 = rotateL128 (Word128 a0 a1) (r `mod` 64) + | otherwise = + Word128 s1 s0 + where + s0 = a0 `shiftL` r + a1 `shiftR` (64 - r) + s1 = a1 `shiftL` r + a0 `shiftR` (64 - r) + +rotateR128 :: Word128 -> Int -> Word128 +rotateR128 w@(Word128 a1 a0) r + | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) + | r == 0 = w + | r >= 128 = rotateR128 w (r `mod` 128) + | r == 64 = Word128 a0 a1 + | r > 64 = rotateR128 (Word128 a0 a1) (r `mod` 64) + | otherwise = + Word128 s1 s0 + where + s0 = a0 `shiftR` r + a1 `shiftL` (64 - r) + s1 = a1 `shiftR` r + a0 `shiftL` (64 - r) + +testBit128 :: Word128 -> Int -> Bool +testBit128 (Word128 a1 a0) i + | i < 0 = False + | i >= 128 = False + | i >= 64 = testBit a1 (i - 64) + | otherwise = testBit a0 i + +bit128 :: Int -> Word128 +bit128 indx + | indx < 0 = zeroWord128 + | indx >= 128 = zeroWord128 + | otherwise = shiftL128 oneWord128 indx + +popCount128 :: Word128 -> Int +popCount128 (Word128 a1 a0) = popCount a1 + popCount a0 + +-- ----------------------------------------------------------------------------- +-- Functions for `FiniteBits` instance. + +countLeadingZeros128 :: Word128 -> Int +countLeadingZeros128 (Word128 a1 a0) = + case countLeadingZeros a1 of + 64 -> 64 + countLeadingZeros a0 + res -> res + +countTrailingZeros128 :: Word128 -> Int +countTrailingZeros128 (Word128 a1 a0) = + case countTrailingZeros a0 of + 64 -> 64 + countTrailingZeros a1 + res -> res + +-- ----------------------------------------------------------------------------- +-- Functions for `Integral` instance. + +quotRem128 :: Word128 -> Word128 -> (Word128, Word128) +quotRem128 num@(Word128 n1 n0) den@(Word128 d1 d0) + | n1 == 0 && d1 == 0 = quotRemTwo n0 d0 + | n1 < d1 = (zeroWord128, num) + | d1 == 0 = quotRemThree num d0 + | otherwise = quotRemFour num den + + +quotRemFour :: Word128 -> Word128 -> (Word128, Word128) +quotRemFour num@(Word128 n1 _) den@(Word128 d1 d0) + | n1 == d1 = quotRemFourX num d0 + | otherwise = (q, r) + where + qtest = quot n1 d1 + diff = times128 den (Word128 0 qtest) + (q, r) = case compare128 num diff of + EQ -> (Word128 0 qtest, zeroWord128) + GT -> (Word128 0 qtest, minus128 num diff) + LT -> let qx = Word128 0 (qtest - 1) + diffx = times128 den qx + in (qx, minus128 num diffx) + + +{-# INLINE quotRemFourX #-} +quotRemFourX :: Word128 -> Word64 -> (Word128, Word128) +quotRemFourX num@(Word128 _ n0) d0 = + case compare n0 d0 of + LT -> (zeroWord128, num) + EQ -> (oneWord128, zeroWord128) + GT -> (Word128 0 1, Word128 0 (n0 - d0)) + + +{-# INLINE quotRemThree #-} +quotRemThree :: Word128 -> Word64 -> (Word128, Word128) +quotRemThree num@(Word128 n1 n0) den + | den == 0 = divZeroError + | den == 1 = (num, zeroWord128) + | n1 < den = case quotRemWord2 n1 n0 den of + (q, r) -> (Word128 0 q, Word128 0 r) + | otherwise = + case quotRem n1 den of + (q1, r1) -> case quotRemWord2 r1 n0 den of + (q0, r0) -> (Word128 q1 q0, Word128 0 r0) + +{-# INLINE quotRemWord2 #-} +quotRemWord2 :: Word64 -> Word64 -> Word64 -> (Word64, Word64) +quotRemWord2 (W64# n1) (W64# n0) (W64# d) = + case quotRemWord2# n1 n0 d of + (# q, r #) -> (W64# q, W64# r) + + +{-# INLINE quotRemTwo #-} +quotRemTwo :: Word64 -> Word64 -> (Word128, Word128) +quotRemTwo n0 d0 = + case quotRem n0 d0 of + (q, r) -> (Word128 0 q, Word128 0 r) + +toInteger128 :: Word128 -> Integer +toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 + +-- ----------------------------------------------------------------------------- +-- Functions for `Integral` instance. + +peek128 :: Ptr Word128 -> IO Word128 +peek128 ptr = + Word128 <$> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0 + +peekElemOff128 :: Ptr Word128 -> Int -> IO Word128 +peekElemOff128 ptr idx = + Word128 <$> peekElemOff (castPtr ptr) (2 * idx + index1) + <*> peekElemOff (castPtr ptr) (2 * idx + index0) + +poke128 :: Ptr Word128 -> Word128 -> IO () +poke128 ptr (Word128 a1 a0) = + pokeElemOff (castPtr ptr) index1 a1 >> pokeElemOff (castPtr ptr) index0 a0 + +pokeElemOff128 :: Ptr Word128 -> Int -> Word128 -> IO () +pokeElemOff128 ptr idx (Word128 a1 a0) = do + pokeElemOff (castPtr ptr) (2 * idx + index0) a0 + pokeElemOff (castPtr ptr) (2 * idx + index1) a1 + +-- ----------------------------------------------------------------------------- +-- Constants. + +zeroWord128 :: Word128 +zeroWord128 = Word128 0 0 + +oneWord128 :: Word128 +oneWord128 = Word128 0 1 + +-- Use these indices to get the peek/poke ordering endian correct. +index0, index1 :: Int +#if WORDS_BIGENDIAN +index0 = 1 +index1 = 0 +#else +index0 = 0 +index1 = 1 +#endif diff --git a/test/Test/Data/WideWord/Gen.hs b/test/Test/Data/WideWord/Gen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/WideWord/Gen.hs @@ -0,0 +1,50 @@ +module Test.Data.WideWord.Gen where + +import Data.Int (Int8, Int16, Int32, Int64) +import Data.WideWord +import Data.Word (Word8, Word16, Word32, Word64) + +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +genInt8 :: Gen Int8 +genInt8 = + Gen.int8 Range.constantBounded + +genInt16 :: Gen Int16 +genInt16 = + Gen.int16 Range.constantBounded + +genInt32 :: Gen Int32 +genInt32 = + Gen.int32 Range.constantBounded + +genInt64 :: Gen Int64 +genInt64 = + Gen.int64 Range.constantBounded + +genInt128 :: Gen Int128 +genInt128 = + Int128 <$> genWord64 <*> genWord64 + +genWord8 :: Gen Word8 +genWord8 = + Gen.word8 Range.constantBounded + +genWord16 :: Gen Word16 +genWord16 = + Gen.word16 Range.constantBounded + +genWord32 :: Gen Word32 +genWord32 = + Gen.word32 Range.constantBounded + +genWord64 :: Gen Word64 +genWord64 = + Gen.word64 Range.constantBounded + +genWord128 :: Gen Word128 +genWord128 = + Word128 <$> genWord64 <*> genWord64 diff --git a/test/Test/Data/WideWord/Int128.hs b/test/Test/Data/WideWord/Int128.hs --- a/test/Test/Data/WideWord/Int128.hs +++ b/test/Test/Data/WideWord/Int128.hs @@ -1,178 +1,296 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Int128 - ( testInt128 + ( tests ) where -import Control.Exception (evaluate) +import Control.Exception (ArithException, evaluate, try) +import Control.Monad.IO.Class (liftIO) -import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros, popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor) -import Data.Int (Int16) -import Data.Word (Word32, Word64) -import Data.WideWord +import Data.Bifunctor (bimap) +import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros + , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor) +import Data.Word (Word64, byteSwap64) +import Data.WideWord -import Foreign (allocaBytes) -import Foreign.Storable (Storable (..)) +import Foreign (allocaBytes) +import Foreign.Storable (Storable (..)) -import Test.Hspec (Spec, describe, errorCall, it, shouldBe, shouldThrow) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck.Modifiers (NonZero (..)) +import Hedgehog (Property, (===), discover) +import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Data.WideWord.Gen -testInt128 :: Spec -testInt128 = describe "Int128:" $ do - prop "constructor and accessors" $ \ (h, l) -> - let i128 = Int128 h l in - (int128Hi64 i128, int128Lo64 i128) `shouldBe` (h, l) - prop "byte swap" $ \ (h, l) -> - let i128 = byteSwapInt128 $ byteSwapInt128 (Int128 h l) in - (int128Hi64 i128, int128Lo64 i128) `shouldBe` (h, l) - - prop "derivied Eq instance" $ \ (a1, a0, b1, b0) -> - (Int128 a1 a0 == Int128 b1 b0) `shouldBe` (a1 == b1 && a0 == b0) - - prop "toInteger" $ \ (a1, a0) -> - toInteger (Int128 a1 a0) `shouldBe` mkInteger a1 a0 +-- Set the number of times to run each property test here. +propertyCount :: H.PropertyT IO () -> Property +propertyCount = + H.withTests 10000 . H.property - prop "negate" $ \ (a1, a0) -> - toInteger (negate (Int128 a1 a0)) `shouldBe` negate (mkInteger a1 a0) +prop_constructor_and_accessors :: Property +prop_constructor_and_accessors = + propertyCount $ do + (h, l) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + let i128 = Int128 h l + (int128Hi64 i128, int128Lo64 i128) === (h, l) - prop "fromInteger" $ \ (a1, a0) -> do - let i128 = fromInteger $ mkInteger a1 a0 - (int128Hi64 i128, int128Lo64 i128) `shouldBe` (a1, a0) +prop_byte_swap :: Property +prop_byte_swap = + propertyCount $ do + h <- H.forAll genWord64 + l <- H.forAll $ Gen.filter (/= h) genWord64 + let w128 = Int128 h l + swapped = byteSwapInt128 w128 + (byteSwapInt128 swapped, byteSwap64 (fromIntegral h), byteSwap64 (fromIntegral l)) + === (w128, int128Lo64 swapped, int128Hi64 swapped) - prop "Ord instance" $ \ (a1, a0, b1, b0) -> - compare (Int128 a1 a0) (Int128 b1 b0) `shouldBe` compare (mkInteger a1 a0) (mkInteger b1 b0) +prop_derivied_eq_instance :: Property +prop_derivied_eq_instance = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + (b1, b0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + (Int128 a1 a0 == Int128 b1 b0) === (a1 == b1 && a0 == b0) - prop "show / read" $ \ (a1, a0) -> - toInteger (read (show $ Int128 a1 a0) :: Int128) `shouldBe` mkInteger a1 a0 +prop_ord_instance :: Property +prop_ord_instance = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + compare a b === compare (toInteger128 a) (toInteger128 b) - prop "succ" $ \ (a1, a0) -> do - let i128 = Int128 a1 a0 - if i128 == maxBound - then evaluate (succ i128) `shouldThrow` errorCall "Enum.succ{Int128}: tried to take `succ' of maxBound" - else toInteger128 (succ i128) `shouldBe` succ (mkInteger a1 a0) +prop_show_instance :: Property +prop_show_instance = + propertyCount $ do + i128 <- H.forAll genInt128 + show i128 === show (toInteger128 i128) - prop "pred" $ \ (a1, a0) -> do - let i128 = Int128 a1 a0 - if i128 == minBound - then evaluate (pred i128) `shouldThrow` errorCall "Enum.pred{Int128}: tried to take `pred' of minBound" - else toInteger128 (pred i128) `shouldBe` pred (mkInteger a1 a0) +prop_read_instance :: Property +prop_read_instance = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + read (show $ Int128 a1 a0) === Int128 a1 a0 - it "succ maxBound throws error" $ - evaluate (succ (maxBound :: Int128)) `shouldThrow` errorCall "Enum.succ{Int128}: tried to take `succ' of maxBound" +prop_succ :: Property +prop_succ = + propertyCount $ do + i128 <- H.forAll genInt128 + res <- liftIO . try $ evaluate (succ i128) + bimap showArithException toInteger128 res + === if i128 == maxBound + then Left "Enum.succ{Int128}: tried to take `succ' of maxBound" + else Right $ succ (toInteger128 i128) - it "pred minBount throws error" $ - evaluate (pred (minBound :: Int128)) `shouldThrow` errorCall "Enum.pred{Int128}: tried to take `pred' of minBound" +prop_pred :: Property +prop_pred = + propertyCount $ do + i128 <- H.forAll genInt128 + res <- liftIO . try $ evaluate (pred i128) + bimap showArithException toInteger128 res + === if i128 == 0 + then Left "Enum.pred{Int128}: tried to take `pred' of minBound" + else Right $ pred (toInteger128 i128) - prop "toEnum / fromEnum" $ \ (a0 :: Word32) -> do +prop_toEnum_fromEnum :: Property +prop_toEnum_fromEnum = + propertyCount $ do + a0 <- H.forAll genWord32 let i128 = Int128 0 (fromIntegral a0) e128 = fromEnum i128 - toInteger e128 `shouldBe` toInteger a0 - toInteger (toEnum e128 :: Int128) `shouldBe` toInteger a0 + toInteger e128 === toInteger a0 + toInteger128 (toEnum e128 :: Int128) === toInteger a0 - prop "complement" $ \ (a1, a0) -> - toInteger (complement $ Int128 a1 a0) `shouldBe` mkInteger (complement a1) (complement a0) +prop_addition :: Property +prop_addition = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + toInteger128 (a + b) === correctInt128 (toInteger128 a + toInteger128 b) - prop "negate" $ \ (a1, a0) -> - toInteger (negate (Int128 a1 a0)) `shouldBe` negate (mkInteger a1 a0) +prop_subtraction :: Property +prop_subtraction = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + let ai = toInteger128 a + bi = toInteger128 b + expected = ai + (1 `shiftL` 128) - bi + toInteger128 (a - b) === correctInt128 expected - prop "abs" $ \ (a1, a0) -> - toInteger (abs (Int128 a1 a0)) `shouldBe` abs (mkInteger a1 a0) +prop_multiplication :: Property +prop_multiplication = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + toInteger128 (a * b) === correctInt128 (toInteger128 a * toInteger128 b) - prop "signum" $ \ (a1, a0) -> - toInteger (signum $ Int128 a1 a0) `shouldBe` signum (mkInteger a1 a0) +prop_negate :: Property +prop_negate = + propertyCount $ do + i128 <- H.forAll genInt128 + toInteger128 (negate i128) === correctInt128 (negate $ toInteger128 i128) - prop "logical and/or/xor" $ \ (a1, a0, b1, b0) -> do - toInteger (Int128 a1 a0 .&. Int128 b1 b0) `shouldBe` (mkInteger a1 a0 .&. mkInteger b1 b0) - toInteger (Int128 a1 a0 .|. Int128 b1 b0) `shouldBe` (mkInteger a1 a0 .|. mkInteger b1 b0) - toInteger (xor (Int128 a1 a0) (Int128 b1 b0)) `shouldBe` xor (mkInteger a1 a0) (mkInteger b1 b0) +prop_abs :: Property +prop_abs = + propertyCount $ do + i128 <- H.forAll genInt128 + toInteger128 (abs i128) === correctInt128 (abs $ toInteger128 i128) - prop "testBit" $ \ (a1, a0) (b :: Int16) -> do - let idx = fromIntegral b - expected +prop_signum :: Property +prop_signum = + propertyCount $ do + i128 <- H.forAll genInt128 + toInteger128 (signum i128) === signum (toInteger128 i128) + +prop_fromInteger :: Property +prop_fromInteger = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + let i128 = fromInteger $ mkInteger a1 a0 + (int128Hi64 i128, int128Lo64 i128) === (a1, a0) + +prop_bitwise_and :: Property +prop_bitwise_and = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + toInteger128 (a .&. b) === (toInteger128 a .&. toInteger128 b) + +prop_bitwise_or :: Property +prop_bitwise_or = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + toInteger128 (a .|. b) === (toInteger128 a .|. toInteger128 b) + +prop_bitwise_xor :: Property +prop_bitwise_xor = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 + toInteger128 (xor a b) === xor (toInteger128 a) (toInteger128 b) + +prop_complement :: Property +prop_complement = + propertyCount $ do + i128 <- H.forAll genWord128 + H.assert $ complement i128 /= i128 + complement (complement i128) === i128 + +prop_logical_shift_left :: Property +prop_logical_shift_left = + propertyCount $ do + i128 <- H.forAll genInt128 + shift <- H.forAll $ Gen.int (Range.linear 0 130) + toInteger128 (shiftL i128 shift) === correctInt128 (shiftL (toInteger128 i128) shift) + +prop_logical_shift_right :: Property +prop_logical_shift_right = + propertyCount $ do + i128 <- H.forAll genInt128 + shift <- H.forAll $ Gen.int (Range.linear 0 130) + toInteger128 (shiftR i128 shift) === shiftR (toInteger128 i128) shift + +prop_logical_rotate_left :: Property +prop_logical_rotate_left = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) + toInteger (rotateL (Int128 a1 a0) rot) === correctInt128 (toInteger $ rotateL (Word128 a1 a0) rot) + +prop_logical_rotate_right :: Property +prop_logical_rotate_right = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) + toInteger (rotateR (Int128 a1 a0) rot) === correctInt128 (toInteger $ rotateR (Word128 a1 a0) rot) + +prop_testBit :: Property +prop_testBit = + propertyCount $ do + i128 <- H.forAll genInt128 + idx <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200) + let expected | idx < 0 = False | idx >= 128 = False - | otherwise = testBit (mkInteger a1 a0) idx - testBit (Int128 a1 a0) idx `shouldBe` expected + | otherwise = testBit (toInteger128 i128) idx + testBit i128 idx === expected - prop "bit" $ \ (b :: Int16) -> do +prop_bit :: Property +prop_bit = + propertyCount $ do + b <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200) let idx = fromIntegral b expected | idx < 0 = 0 | idx >= 128 = 0 | idx == 127 = toInteger128 (minBound :: Int128) | otherwise = bit idx - toInteger (bit idx :: Int128) `shouldBe` expected + toInteger128 (bit idx :: Int128) === expected - prop "popCount" $ \ (a1, a0) -> - popCount (Int128 a1 a0) `shouldBe` popCount a1 + popCount a0 +prop_popCount :: Property +prop_popCount = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + popCount (Int128 a1 a0) === popCount a1 + popCount a0 - prop "countLeadingZeros" $ \ (a1, a0) -> do +prop_countLeadingZeros :: Property +prop_countLeadingZeros = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let expected = if a1 == 0 then 64 + countLeadingZeros a0 else countLeadingZeros a1 - countLeadingZeros (Int128 a1 a0) `shouldBe` expected + countLeadingZeros (Int128 a1 a0) === expected - prop "countTrailingZeros" $ \ (a1, a0) -> do +prop_countTrailingZeros :: Property +prop_countTrailingZeros = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let expected = if a0 == 0 then 64 + countTrailingZeros a1 else countTrailingZeros a0 - countTrailingZeros (Int128 a1 a0) `shouldBe` expected - - - prop "addition" $ \ (a1, a0, b1, b0) -> - toInteger (Int128 a1 a0 + Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 + mkInteger b1 b0) - - prop "subtraction" $ \ (a1, a0, b1, b0) -> - toInteger (Int128 a1 a0 - Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 - mkInteger b1 b0) - - prop "multiplication" $ \ (a1, a0, b1, b0) -> - toInteger (Int128 a1 a0 * Int128 b1 b0) `shouldBe` correctInt128 (mkInteger a1 a0 * mkInteger b1 b0) - - prop "logical shiftL" $ \ (a1, a0) shift -> - let safeShift = if shift < 0 then 128 - (abs shift `mod` 128) else shift in - toInteger (shiftL (Int128 a1 a0) shift) `shouldBe` correctInt128 (shiftL (mkInteger a1 a0) safeShift) - - prop "logical shiftR" $ \ (a1, a0) shift -> - let expected = if shift < 0 then 0 else correctInt128 (shiftR (mkInteger a1 a0) shift) in - toInteger (shiftR (Int128 a1 a0) shift) `shouldBe` expected - - -- Use `Int16` here to force a uniform distribution across the `Int16` range - -- (standard QuickCkeck generator for `Int` doesn't give an even distribution). - prop "logical rotateL" $ \ (a1, a0) (r :: Int16) -> do - let rot = fromIntegral r - toInteger (rotateL (Int128 a1 a0) rot) `shouldBe` correctInt128 (toInteger $ rotateL (Word128 a1 a0) rot) - - prop "logical rotateR" $ \ (a1, a0) (r :: Int16) -> do - let rot = fromIntegral r - toInteger (rotateR (Int128 a1 a0) rot) `shouldBe` correctInt128 (toInteger $ rotateR (Word128 a1 a0) rot) + countTrailingZeros (Int128 a1 a0) === expected - prop "quotRem" $ \ (a1, a0, NonZero b1, b0) -> do - let (aq128, ar128) = quotRem (Int128 a1 a0) (Int128 b1 b0) - (toInteger aq128, toInteger ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger b1 b0) +-- Don't need to test `quot` or `rem` because they are implemented by applying +-- `fst` or `snd` to the output of `quotRem`. +prop_quotRem :: Property +prop_quotRem = + propertyCount $ do + num <- H.forAll genInt128 + den <- H.forAll $ Gen.filter (/= 0) genInt128 + let (q, r) = quotRem num den + (toInteger128 q, toInteger128 r) === quotRem (toInteger128 num) (toInteger128 den) - prop "divMod" $ \ (a1, a0, NonZero b1, b0) -> do - let (aq128, ar128) = divMod (Int128 a1 a0) (Int128 b1 b0) - (toInteger aq128, toInteger ar128) `shouldBe` divMod (mkInteger a1 a0) (mkInteger b1 b0) +prop_divMod :: Property +prop_divMod = + propertyCount $ do + num <- H.forAll genInt128 + den <- H.forAll $ Gen.filter (/= 0) genInt128 + let (d, m) = divMod num den + (toInteger128 d, toInteger128 m) === divMod (toInteger128 num) (toInteger128 den) - prop "peek / poke" $ \ (a1, a0) -> do - ar <- allocaBytes (sizeOf zeroInt128) $ \ ptr -> do - poke ptr $ Int128 a1 a0 - peek ptr - toInteger128 ar `shouldBe` mkInteger a1 a0 +prop_peek_and_poke :: Property +prop_peek_and_poke = + propertyCount $ do + i128 <- H.forAll genInt128 + ar <- liftIO $ + allocaBytes (sizeOf zeroInt128) $ \ ptr -> do + poke ptr i128 + peek ptr + toInteger128 ar === toInteger128 i128 - prop "peekElemOff / pokeElemOff" $ \ (a1, a0, b1, b0) -> do - (ar, br) <- allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do - pokeElemOff ptr 0 $ Int128 a1 a0 - pokeElemOff ptr 1 $ Int128 b1 b0 +prop_peekElemOff_pokeElemOff :: Property +prop_peekElemOff_pokeElemOff = + propertyCount $ do + a128 <- H.forAll genInt128 + b128 <- H.forAll genInt128 + (ar, br) <- liftIO $ + allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do + pokeElemOff ptr 0 a128 + pokeElemOff ptr 1 b128 (,) <$> peekElemOff ptr 0 <*> peekElemOff ptr 1 - (toInteger128 ar, toInteger128 br) `shouldBe` (mkInteger a1 a0, mkInteger b1 b0) - + (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128) -- ----------------------------------------------------------------------------- +mkInteger :: Word64 -> Word64 -> Integer +mkInteger a1 a0 = fromIntegral a1 `shiftL` 64 + fromIntegral a0 + -- Convert an `Integer` to the `Integer` with the same bit pattern as the -- corresponding `Int128`. correctInt128 :: Integer -> Integer @@ -183,11 +301,14 @@ minBoundInt128 = fromIntegral (minBound :: Int128) maxBoundInt128 = fromIntegral (maxBound :: Int128) -mkInteger :: Word64 -> Word64 -> Integer -mkInteger a1 a0 - | testBit a1 63 = negate (fromIntegral (complement a1) `shiftL` 64 + fromIntegral (complement a0) + 1) - | otherwise = fromIntegral a1 `shiftL` 64 + fromIntegral a0 - - toInteger128 :: Int128 -> Integer toInteger128 = toInteger + +showArithException :: ArithException -> String +showArithException = show + +-- ----------------------------------------------------------------------------- + +tests :: IO Bool +tests = + H.checkParallel $$discover diff --git a/test/Test/Data/WideWord/Word128.hs b/test/Test/Data/WideWord/Word128.hs --- a/test/Test/Data/WideWord/Word128.hs +++ b/test/Test/Data/WideWord/Word128.hs @@ -1,113 +1,200 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Word128 - ( testWord128 + ( tests ) where -import Control.Exception (evaluate) +import Control.Exception (ArithException, evaluate, try) +import Control.Monad.IO.Class (liftIO) -import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros, popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor) -import Data.Int (Int16) -import Data.Word (Word32, Word64) -import Data.WideWord +import Data.Bifunctor (bimap) +import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros + , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor) +import Data.Word (Word64, byteSwap64) +import Data.WideWord -import Foreign (allocaBytes) -import Foreign.Storable (Storable (..)) +import Foreign (allocaBytes) +import Foreign.Storable (Storable (..)) -import Test.Hspec (Spec, describe, errorCall, it, shouldBe, shouldThrow) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck.Modifiers (NonZero (..)) +import Hedgehog (Property, (===), discover) +import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Data.WideWord.Gen -testWord128 :: Spec -testWord128 = describe "Word128:" $ do - prop "constructor and accessors" $ \ (h, l) -> - let w128 = Word128 h l in - (word128Hi64 w128, word128Lo64 w128) `shouldBe` (h, l) - prop "byte swap" $ \ (h, l) -> - let w128 = byteSwapWord128 $ byteSwapWord128 (Word128 h l) in - (word128Hi64 w128, word128Lo64 w128) `shouldBe` (h, l) +-- Set the number of times to run each property test here. +propertyCount :: H.PropertyT IO () -> Property +propertyCount = + H.withTests 10000 . H.property - prop "derivied Eq instance" $ \ (a1, a0, b1, b0) -> - (Word128 a1 a0 == Word128 b1 b0) `shouldBe` (a1 == b1 && a0 == b0) +prop_constructor_and_accessors :: Property +prop_constructor_and_accessors = + propertyCount $ do + (h, l) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + let w128 = Word128 h l + (word128Hi64 w128, word128Lo64 w128) === (h, l) - prop "Ord instance" $ \ (a1, a0, b1, b0) -> - compare (Word128 a1 a0) (Word128 b1 b0) `shouldBe` compare (mkInteger a1 a0) (mkInteger b1 b0) +prop_byte_swap :: Property +prop_byte_swap = + propertyCount $ do + h <- H.forAll genWord64 + l <- H.forAll $ Gen.filter (/= h) genWord64 + let w128 = Word128 h l + swapped = byteSwapWord128 w128 + (byteSwapWord128 swapped, byteSwap64 h, byteSwap64 l) + === (w128, word128Lo64 swapped, word128Hi64 swapped) - prop "show" $ \ (a1, a0) -> - show (Word128 a1 a0) `shouldBe` show (mkInteger a1 a0) +prop_derivied_eq_instance :: Property +prop_derivied_eq_instance = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + (b1, b0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + (Word128 a1 a0 == Word128 b1 b0) === (a1 == b1 && a0 == b0) - prop "read" $ \ (a1, a0) -> - read (show $ Word128 a1 a0) `shouldBe` Word128 a1 a0 +prop_ord_instance :: Property +prop_ord_instance = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + compare a b === compare (toInteger128 a) (toInteger128 b) - prop "succ" $ \ (a1, a0) -> - if a1 == maxBound && a0 == maxBound - then evaluate (succ $ Word128 a1 a0) `shouldThrow` errorCall "Enum.succ{Word128}: tried to take `succ' of maxBound" - else toInteger128 (succ $ Word128 a1 a0) `shouldBe` succ (mkInteger a1 a0) +prop_show_instance :: Property +prop_show_instance = + propertyCount $ do + w128 <- H.forAll genWord128 + show w128 === show (toInteger128 w128) - prop "pred" $ \ (a1, a0) -> - if a1 == 0 && a0 == 0 - then evaluate (pred $ Word128 a1 a0) `shouldThrow` errorCall "Enum.pred{Word128}: tried to take `pred' of minBound" - else toInteger128 (pred $ Word128 a1 a0) `shouldBe` pred (mkInteger a1 a0) +prop_read_instance :: Property +prop_read_instance = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + read (show $ Word128 a1 a0) === Word128 a1 a0 - it "succ maxBound throws error" $ - evaluate (succ $ Word128 maxBound maxBound) `shouldThrow` errorCall "Enum.succ{Word128}: tried to take `succ' of maxBound" +prop_read_show :: Property +prop_read_show = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + H.tripping (Word128 a1 a0) show (Just . read) - it "pred minBount throws error" $ - evaluate (pred $ Word128 0 0) `shouldThrow` errorCall "Enum.pred{Word128}: tried to take `pred' of minBound" +prop_succ :: Property +prop_succ = + propertyCount $ do + w128 <- H.forAll genWord128 + res <- liftIO . try $ evaluate (succ w128) + bimap showArithException toInteger128 res + === if w128 == maxBound + then Left "Enum.succ{Word128}: tried to take `succ' of maxBound" + else Right $ succ (toInteger128 w128) - prop "toEnum / fromEnum" $ \ (a0 :: Word32) -> do +prop_pred :: Property +prop_pred = + propertyCount $ do + w128 <- H.forAll genWord128 + res <- liftIO . try $ evaluate (pred w128) + bimap showArithException toInteger128 res + === if w128 == 0 + then Left "Enum.pred{Word128}: tried to take `pred' of minBound" + else Right $ pred (toInteger128 w128) + +prop_toEnum_fromEnum :: Property +prop_toEnum_fromEnum = + propertyCount $ do + a0 <- H.forAll genWord32 let w128 = Word128 0 (fromIntegral a0) e128 = fromEnum w128 - toInteger e128 `shouldBe` toInteger a0 - toInteger128 (toEnum e128 :: Word128) `shouldBe` toInteger a0 + toInteger e128 === toInteger a0 + toInteger128 (toEnum e128 :: Word128) === toInteger a0 - prop "addition" $ \ (a1, a0, b1, b0) -> - toInteger128 (Word128 a1 a0 + Word128 b1 b0) `shouldBe` correctWord128 (mkInteger a1 a0 + mkInteger b1 b0) +prop_addition :: Property +prop_addition = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + toInteger128 (a + b) === correctWord128 (toInteger128 a + toInteger128 b) - prop "subtraction" $ \ (a1, a0, b1, b0) -> do - let ai = mkInteger a1 a0 - bi = mkInteger b1 b0 +prop_subtraction :: Property +prop_subtraction = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + let ai = toInteger128 a + bi = toInteger128 b expected = ai + (1 `shiftL` 128) - bi - toInteger128 (Word128 a1 a0 - Word128 b1 b0) `shouldBe` correctWord128 expected + toInteger128 (a - b) === correctWord128 expected - prop "multiplication" $ \ (a1, a0, b1, b0) -> - toInteger128 (Word128 a1 a0 * Word128 b1 b0) `shouldBe` correctWord128 (mkInteger a1 a0 * mkInteger b1 b0) +prop_multiplication :: Property +prop_multiplication = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + toInteger128 (a * b) === correctWord128 (toInteger128 a * toInteger128 b) - prop "negate" $ \ (a1, a0) -> - toInteger128 (negate (Word128 a1 a0)) `shouldBe` correctWord128 (negate $ mkInteger a1 a0) +prop_negate :: Property +prop_negate = + propertyCount $ do + w128 <- H.forAll genWord128 + toInteger128 (negate w128) === correctWord128 (negate $ toInteger128 w128) - prop "abs" $ \ (a1, a0) -> - toInteger128 (abs (Word128 a1 a0)) `shouldBe` correctWord128 (abs $ mkInteger a1 a0) +prop_abs :: Property +prop_abs = + propertyCount $ do + w128 <- H.forAll genWord128 + toInteger128 (abs w128) === correctWord128 (abs $ toInteger128 w128) - prop "signum" $ \ (a1, a0) -> - toInteger128 (signum $ Word128 a1 a0) `shouldBe` signum (mkInteger a1 a0) +prop_signum :: Property +prop_signum = + propertyCount $ do + w128 <- H.forAll genWord128 + toInteger128 (signum w128) === signum (toInteger128 w128) - prop "fromInteger" $ \ (a1, a0) -> do +prop_fromInteger :: Property +prop_fromInteger = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let w128 = fromInteger $ mkInteger a1 a0 - (word128Hi64 w128, word128Lo64 w128) `shouldBe` (a1, a0) + (word128Hi64 w128, word128Lo64 w128) === (a1, a0) - prop "logical and/or/xor" $ \ (a1, a0, b1, b0) -> do - toInteger128 (Word128 a1 a0 .&. Word128 b1 b0) `shouldBe` (mkInteger a1 a0 .&. mkInteger b1 b0) - toInteger128 (Word128 a1 a0 .|. Word128 b1 b0) `shouldBe` (mkInteger a1 a0 .|. mkInteger b1 b0) - toInteger128 (xor (Word128 a1 a0) (Word128 b1 b0)) `shouldBe` xor (mkInteger a1 a0) (mkInteger b1 b0) +prop_bitwise_and :: Property +prop_bitwise_and = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + toInteger128 (a .&. b) === (toInteger128 a .&. toInteger128 b) - prop "complement" $ \ (a1, a0) -> - toInteger128 (complement $ Word128 a1 a0) `shouldBe` mkInteger (complement a1) (complement a0) +prop_bitwise_or :: Property +prop_bitwise_or = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + toInteger128 (a .|. b) === (toInteger128 a .|. toInteger128 b) - prop "logical shiftL" $ \ (a1, a0) shift -> - let safeShift = if shift < 0 then 128 - (abs shift `mod` 128) else shift in - toInteger128 (shiftL (Word128 a1 a0) shift) `shouldBe` correctWord128 (shiftL (mkInteger a1 a0) safeShift) +prop_bitwise_xor :: Property +prop_bitwise_xor = + propertyCount $ do + (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 + toInteger128 (xor a b) === xor (toInteger128 a) (toInteger128 b) - prop "logical shiftR" $ \ (a1, a0) shift -> - let expected = if shift < 0 then 0 else correctWord128 (shiftR (mkInteger a1 a0) shift) in - toInteger128 (shiftR (Word128 a1 a0) shift) `shouldBe` expected +prop_complement :: Property +prop_complement = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 + toInteger128 (complement $ Word128 a1 a0) === mkInteger (complement a1) (complement a0) - -- Use `Int16` here to force a uniform distribution across the `Int16` range - -- (standard QuickCkeck generator for `Int` doesn't give an even distribution). - prop "logical rotateL" $ \ (a1, a0) (r :: Int16) -> do - let rot = fromIntegral r - i128 = mkInteger a1 a0 +prop_logical_shift_left :: Property +prop_logical_shift_left = + propertyCount $ do + w128 <- H.forAll genWord128 + shift <- H.forAll $ Gen.int (Range.linear 0 130) + toInteger128 (shiftL w128 shift) === correctWord128 (shiftL (toInteger128 w128) shift) + +prop_logical_shift_right :: Property +prop_logical_shift_right = + propertyCount $ do + w128 <- H.forAll genWord128 + shift <- H.forAll $ Gen.int (Range.linear 0 130) + toInteger128 (shiftR w128 shift) === shiftR (toInteger128 w128) shift + +prop_logical_rotate_left :: Property +prop_logical_rotate_left = + propertyCount $ do + w128 <- H.forAll genWord128 + rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) + let i128 = toInteger128 w128 expected | rot < 0 = 0 | otherwise = @@ -116,81 +203,107 @@ erot | rot < 0 = 128 - (abs rot `mod` 128) | otherwise = rot `mod` 128 - toInteger128 (rotateL (Word128 a1 a0) rot) `shouldBe` expected + toInteger128 (rotateL w128 rot) === expected - prop "logical rotateR" $ \ (a1, a0) (r :: Int16) -> do - let rot = fromIntegral r - i128 = mkInteger a1 a0 +prop_logical_rotate_right :: Property +prop_logical_rotate_right = + propertyCount $ do + w128 <- H.forAll genWord128 + rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000) + let i128 = toInteger128 w128 expected = correctWord128 $ i128 `shiftR` erot + i128 `shiftL` (128 - erot) where erot | rot < 0 = 128 - (abs rot `mod` 128) | otherwise = rot `mod` 128 - toInteger128 (rotateR (Word128 a1 a0) rot) `shouldBe` expected + toInteger128 (rotateR w128 rot) === expected - prop "testBit" $ \ (a1, a0) (b :: Int16) -> do - let idx = fromIntegral b - expected +prop_testBit :: Property +prop_testBit = + propertyCount $ do + w128 <- H.forAll genWord128 + idx <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200) + let expected | idx < 0 = False | idx >= 128 = False - | otherwise = testBit (mkInteger a1 a0) idx - testBit (Word128 a1 a0) idx `shouldBe` expected + | otherwise = testBit (toInteger128 w128) idx + testBit w128 idx === expected - prop "bit" $ \ (b :: Int16) -> do +prop_bit :: Property +prop_bit = + propertyCount $ do + b <- H.forAll $ Gen.int (Range.linearFrom 0 (-200) 200) let idx = fromIntegral b expected | idx < 0 = 0 | idx >= 128 = 0 | otherwise = bit idx - toInteger128 (bit idx :: Word128) `shouldBe` expected + toInteger128 (bit idx :: Word128) === expected - prop "popCount" $ \ (a1, a0) -> - popCount (Word128 a1 a0) `shouldBe` popCount (mkInteger a1 a0) +prop_popCount :: Property +prop_popCount = + propertyCount $ do + w128 <- H.forAll genWord128 + popCount w128 === popCount (toInteger128 w128) - prop "countLeadingZeros" $ \ (a1, a0) -> do +prop_countLeadingZeros :: Property +prop_countLeadingZeros = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let expected = if a1 == 0 then 64 + countLeadingZeros a0 else countLeadingZeros a1 - countLeadingZeros (Word128 a1 a0) `shouldBe` expected + countLeadingZeros (Word128 a1 a0) === expected - prop "countTrailingZeros" $ \ (a1, a0) -> do +prop_countTrailingZeros :: Property +prop_countTrailingZeros = + propertyCount $ do + (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let expected = if a0 == 0 then 64 + countTrailingZeros a1 else countTrailingZeros a0 - countTrailingZeros (Word128 a1 a0) `shouldBe` expected - - prop "quotRem (both upper words zero)" $ \ (a0, NonZero b0) -> do - let (aq128, ar128) = quotRem (Word128 0 a0) (Word128 0 b0) - (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger 0 a0) (mkInteger 0 b0) - - prop "quotRem (denominator upper word zero)" $ \ (NonZero a1, a0, NonZero b0) -> do - let (aq128, ar128) = quotRem (Word128 a1 a0) (Word128 0 b0) - (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger 0 b0) + countTrailingZeros (Word128 a1 a0) === expected - -- Don't need to test `quot` or `rem` because they are implemented by applying - -- `fst` or `snd` to the output of `quotRem`. - prop "quotRem (full)" $ \ (a1, a0, NonZero b1, b0) -> do - let (aq128, ar128) = quotRem (Word128 a1 a0) (Word128 b1 b0) - (toInteger128 aq128, toInteger128 ar128) `shouldBe` quotRem (mkInteger a1 a0) (mkInteger b1 b0) +-- Don't need to test `quot` or `rem` because they are implemented by applying +-- `fst` or `snd` to the output of `quotRem`. +prop_quotRem :: Property +prop_quotRem = + propertyCount $ do + num <- H.forAll genWord128 + den <- H.forAll $ Gen.filter (/= 0) genWord128 + let (q, r) = quotRem num den + (toInteger128 q, toInteger128 r) === quotRem (toInteger128 num) (toInteger128 den) - -- For unsigned values `quotRem` and `divMod` should give the same results. - prop "divMod (full)" $ \ (a1, a0, NonZero b1, b0) -> do - let (aq128, ar128) = divMod (Word128 a1 a0) (Word128 b1 b0) - (toInteger128 aq128, toInteger128 ar128) `shouldBe` divMod (mkInteger a1 a0) (mkInteger b1 b0) +prop_divMod :: Property +prop_divMod = + propertyCount $ do + num <- H.forAll genWord128 + den <- H.forAll $ Gen.filter (/= 0) genWord128 + let (d, m) = divMod num den + (toInteger128 d, toInteger128 m) === divMod (toInteger128 num) (toInteger128 den) - prop "peek / poke" $ \ (a1, a0) -> do - ar <- allocaBytes (sizeOf zeroWord128) $ \ ptr -> do - poke ptr $ Word128 a1 a0 - peek ptr - toInteger128 ar `shouldBe` mkInteger a1 a0 +prop_peek_and_poke :: Property +prop_peek_and_poke = + propertyCount $ do + w128 <- H.forAll genWord128 + ar <- liftIO $ + allocaBytes (sizeOf zeroWord128) $ \ ptr -> do + poke ptr w128 + peek ptr + toInteger128 ar === toInteger128 w128 - prop "peekElemOff / pokeElemOff" $ \ (a1, a0, b1, b0) -> do - (ar, br) <- allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do - pokeElemOff ptr 0 $ Word128 a1 a0 - pokeElemOff ptr 1 $ Word128 b1 b0 +prop_peekElemOff_pokeElemOff :: Property +prop_peekElemOff_pokeElemOff = + propertyCount $ do + a128 <- H.forAll genWord128 + b128 <- H.forAll genWord128 + (ar, br) <- liftIO $ + allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do + pokeElemOff ptr 0 a128 + pokeElemOff ptr 1 b128 (,) <$> peekElemOff ptr 0 <*> peekElemOff ptr 1 - (toInteger128 ar, toInteger128 br) `shouldBe` (mkInteger a1 a0, mkInteger b1 b0) + (toInteger128 ar, toInteger128 br) === (toInteger128 a128, toInteger128 b128) -- ----------------------------------------------------------------------------- @@ -206,3 +319,12 @@ toInteger128 :: Word128 -> Integer toInteger128 = toInteger + +showArithException :: ArithException -> String +showArithException = show + +-- ----------------------------------------------------------------------------- + +tests :: IO Bool +tests = + H.checkParallel $$discover diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,26 +1,18 @@ -import Control.Monad (when) - -import Test.Data.WideWord.Int128 -import Test.Data.WideWord.Word128 - -import Test.Hspec (Spec) -import Test.Hspec.Runner (configQuickCheckMaxSuccess, defaultConfig, hspecWithResult, summaryFailures) - -import System.Exit (exitFailure, exitSuccess) +import Control.Monad (unless) +import System.Exit (exitFailure) +import qualified Test.Data.WideWord.Int128 +import qualified Test.Data.WideWord.Word128 main :: IO () -main = do - summary <- hspecWithResult config testAll - when (summaryFailures summary == 0) - exitSuccess - exitFailure - where - config = defaultConfig { configQuickCheckMaxSuccess = Just 100000 } - -testAll :: Spec -testAll = do - testWord128 - testInt128 +main = runTests + [ Test.Data.WideWord.Int128.tests + , Test.Data.WideWord.Word128.tests + ] +runTests :: [IO Bool] -> IO () +runTests tests = do + result <- and <$> sequence tests + unless result + exitFailure diff --git a/wide-word.cabal b/wide-word.cabal --- a/wide-word.cabal +++ b/wide-word.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wide-word -version: 0.1.0.6 +version: 0.1.0.7 synopsis: Data types for large but fixed width signed and unsigned integers description: A library to provide data types for large (ie > 64 bits) but fixed width signed @@ -28,12 +28,12 @@ library default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs - hs-source-dirs: . - other-extensions: StrictData + hs-source-dirs: src + other-extensions: StrictData exposed-modules: Data.WideWord - , Data.WideWord.Word128 - , Data.WideWord.Int128 + Data.WideWord.Word128 + Data.WideWord.Int128 build-depends: base >= 4.8 && < 5.0 , deepseq >= 1.3 && < 1.5 @@ -47,12 +47,12 @@ main-is: test.hs hs-source-dirs: test - other-modules: Test.Data.WideWord.Int128 - , Test.Data.WideWord.Word128 + other-modules: Test.Data.WideWord.Gen + Test.Data.WideWord.Int128 + Test.Data.WideWord.Word128 build-depends: base >= 4.8 && < 5.0 , bytestring >= 0.10 , ghc-prim - , hspec >= 2.3 && < 2.6 - , QuickCheck >= 2.9 + , hedgehog == 0.6.* , wide-word