wide-word 0.1.3.0 → 0.1.4.0
raw patch · 14 files changed
+868/−352 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.WideWord.Word64: mkWord64 :: Word32 -> Word32 -> Word64
+ Data.WideWord.Word64: plusCarrySum :: Word64 -> Word64 -> (Word64, Word64)
+ Data.WideWord.Word64: quotRem2Word64 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)
+ Data.WideWord.Word64: showHexWord64 :: Word64 -> String
+ Data.WideWord.Word64: subCarryDiff :: Word64 -> Word64 -> (Word64, Word64)
+ Data.WideWord.Word64: timesCarryProd :: Word64 -> Word64 -> (Word64, Word64)
+ Data.WideWord.Word64: word64Hi32 :: Word64 -> Word32
+ Data.WideWord.Word64: word64Lo32 :: Word64 -> Word32
+ Data.WideWord.Word64: zeroWord64 :: Word64
Files
- ChangeLog.md +8/−0
- src/Data/WideWord.hs +1/−0
- src/Data/WideWord/Compat.hs +0/−11
- src/Data/WideWord/Int128.hs +41/−62
- src/Data/WideWord/Word128.hs +37/−51
- src/Data/WideWord/Word256.hs +153/−177
- src/Data/WideWord/Word64.hs +161/−0
- test/Test/Data/WideWord/Gen.hs +15/−11
- test/Test/Data/WideWord/Int128.hs +2/−1
- test/Test/Data/WideWord/Word128.hs +6/−5
- test/Test/Data/WideWord/Word64.hs +399/−0
- test/laws.hs +37/−29
- test/test.hs +2/−0
- wide-word.cabal +6/−5
ChangeLog.md view
@@ -1,5 +1,13 @@ # Revision history for wide-word +## 0.1.4.0 -- 2022-12-24++* Add support for building on 32 bit architectures with ghc-9.2 or later.++## 0.1.3.0 -- 2022-12-01++* Add Hashable instances for Int128, Word128, and Word256.+ ## 0.1.2.0 -- 2022-??-?? * Add Hashable instances for Int128, Word128, and Word256.
src/Data/WideWord.hs view
@@ -3,5 +3,6 @@ ) where import Data.WideWord.Int128 as X+import Data.WideWord.Word64 as X import Data.WideWord.Word128 as X import Data.WideWord.Word256 as X
src/Data/WideWord/Compat.hs view
@@ -13,7 +13,6 @@ , minusWord# , subWordC# , not#- , isZeroWord# , or# , and# , xor#@@ -86,16 +85,6 @@ quotRemWord2# a b c = case GHC.Base.quotRemWord2# (word64ToWord# a) (word64ToWord# b) (word64ToWord# c) of (# x, y #) -> (# wordToWord64# x, wordToWord64# y #)-#endif--isZeroWord#-#if MIN_VERSION_base(4,17,0)- :: Word64# -> Bool-isZeroWord# a = GHC.Base.isTrue# (GHC.Base.eqWord# (word64ToWord# a) 0##)-#else- :: Word# -> Bool-isZeroWord# 0## = True-isZeroWord# _ = False #endif compatWordLiteral#
src/Data/WideWord/Int128.hs view
@@ -23,8 +23,6 @@ ---- "modulo 2^128" result as one would expect from a fixed width unsigned word. ------------------------------------------------------------------------------- -#include <MachDeps.h>- module Data.WideWord.Int128 ( Int128 (..) , byteSwapInt128@@ -52,19 +50,14 @@ import GHC.Enum (predError, succError) import GHC.Exts ((+#), (*#), State#, Int#, Addr#, ByteArray#, MutableByteArray#) import GHC.Generics-import GHC.Int (Int64 (..)) import GHC.Real ((%))-import GHC.Word (Word64 (..), Word32, byteSwap64)--#if WORD_SIZE_IN_BITS < 64-import GHC.IntWord64-#endif+import GHC.Word (Word32, Word64, byteSwap64) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) import Data.Hashable (Hashable,hashWithSalt) -import Data.WideWord.Compat+import Data.WideWord.Word64 #if MIN_VERSION_base(4,17,0) #define ONE (wordToWord64# 1##)@@ -235,28 +228,26 @@ -- Functions for `Ord` instance. compare128 :: Int128 -> Int128 -> Ordering-compare128 (Int128 a1 a0) (Int128 b1 b0) =- compare (int64OfWord64 a1) (int64OfWord64 b1) <> compare a0 b0- where- int64OfWord64 (W64# w) = I64# (word2Int# w)+compare128 a b = compare (toInteger128 a) (toInteger128 b) -- ----------------------------------------------------------------------------- -- Functions for `Enum` instance. - succ128 :: Int128 -> Int128 succ128 (Int128 a1 a0)- | a0 == maxBound = if a1 == 0x7fffffffffffffff- then succError "Int128"- else Int128 (a1 + 1) 0+ | a0 == maxBound =+ if a1 == 0x7fffffffffffffff+ then succError "Int128"+ else Int128 (a1 + 1) 0 | otherwise = Int128 a1 (a0 + 1) pred128 :: Int128 -> Int128 pred128 (Int128 a1 a0)- | a0 == 0 = if a1 == 0x8000000000000000- then predError "Int128"- else Int128 (a1 - 1) maxBound+ | a0 == 0 =+ if a1 == 0x8000000000000000+ then predError "Int128"+ else Int128 (a1 - 1) maxBound | otherwise = Int128 a1 (a0 - 1) @@ -273,37 +264,37 @@ {-# INLINABLE plus128 #-} plus128 :: Int128 -> Int128 -> Int128-plus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =- Int128 (W64# s1) (W64# s0)+plus128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 s1 s0 where- !(# c1, s0 #) = plusWord2# a0 b0- s1a = plusWord# a1 b1- s1 = plusWord# c1 s1a+ !(c1, s0) = plusCarrySum a0 b0+ s1a = a1 + b1+ s1 = c1 + s1a {-# INLINABLE minus128 #-} minus128 :: Int128 -> Int128 -> Int128-minus128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =- Int128 (W64# d1) (W64# d0)+minus128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 d1 d0 where- !(# d0, c1 #) = subWordC# a0 b0- a1c = minusWord# a1 (int2Word# c1)- d1 = minusWord# a1c b1+ !(c1, d0) = subCarryDiff a0 b0+ a1c = a1 - c1+ d1 = a1c - b1 times128 :: Int128 -> Int128 -> Int128-times128 (Int128 (W64# a1) (W64# a0)) (Int128 (W64# b1) (W64# b0)) =- Int128 (W64# p1) (W64# p0)+times128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 p1 p0 where- !(# c1, p0 #) = timesWord2# a0 b0- p1a = timesWord# a1 b0- p1b = timesWord# a0 b1- p1c = plusWord# p1a p1b- p1 = plusWord# p1c c1+ !(c1, p0) = timesCarryProd a0 b0+ p1a = a1 * b0+ p1b = a0 * b1+ p1c = p1a + p1b+ p1 = p1c + c1 {-# INLINABLE negate128 #-} negate128 :: Int128 -> Int128-negate128 (Int128 (W64# a1) (W64# a0)) =- case plusWord2# (not# a0) (compatWordLiteral# 1##) of- (# c, s #) -> Int128 (W64# (plusWord# (not# a1) c)) (W64# s)+negate128 (Int128 a1 a0) =+ case plusCarrySum (complement a0) 1 of+ (c, s) -> Int128 (complement a1 + c) s {-# INLINABLE abs128 #-} abs128 :: Int128 -> Int128@@ -331,18 +322,18 @@ {-# 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))+and128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 (a1 .&. b1) (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))+or128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 (a1 .|. b1) (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))+xor128 (Int128 a1 a0) (Int128 b1 b0) =+ Int128 (xor a1 b1) (xor a0 b0) -- Probably not worth inlining this. shiftL128 :: Int128 -> Int -> Int128@@ -353,10 +344,7 @@ | 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)+ Int128 (a1 `shiftL` s + a0 `shiftR` (64 - s)) (a0 `shiftL` s) -- Probably not worth inlining this. shiftR128 :: Int128 -> Int -> Int128@@ -367,10 +355,7 @@ | 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)+ | otherwise = Int128 (a1 `shiftR` s) (a0 `shiftR` s + a1 `shiftL` (64 - s)) rotateL128 :: Int128 -> Int -> Int128 rotateL128 w@(Int128 a1 a0) r@@ -380,10 +365,7 @@ | 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)+ Int128 (a1 `shiftL` r + a0 `shiftR` (64 - r)) (a0 `shiftL` r + a1 `shiftR` (64 - r)) rotateR128 :: Int128 -> Int -> Int128 rotateR128 w@(Int128 a1 a0) r@@ -393,10 +375,7 @@ | 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)+ Int128 (a1 `shiftR` r + a0 `shiftL` (64 - r)) (a0 `shiftR` r + a1 `shiftL` (64 - r)) testBit128 :: Int128 -> Int -> Bool testBit128 (Int128 a1 a0) i
src/Data/WideWord/Word128.hs view
@@ -39,6 +39,7 @@ #if ! MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>)) #endif+import Data.WideWord.Word64 import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable (..))@@ -46,15 +47,10 @@ import GHC.Base (Int (..)) import GHC.Enum (predError, succError) import GHC.Exts ((*#), (+#), Int#, State#, ByteArray#, MutableByteArray#, Addr#)-import GHC.Generics+import GHC.Generics (Generic) import GHC.Real ((%), divZeroError)-import GHC.Word (Word64 (..), Word32, byteSwap64)--#if WORD_SIZE_IN_BITS < 64-import GHC.IntWord64-#endif+import GHC.Word (Word32, Word64, byteSwap64) -import Data.WideWord.Compat import Numeric (showHex) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#)@@ -138,6 +134,7 @@ instance Real Word128 where toRational x = toInteger128 x % 1 +-- For unsigned values, quotRem is the same as divMod. instance Integral Word128 where quot n d = fst (quotRem128 n d) rem n d = snd (quotRem128 n d)@@ -261,42 +258,40 @@ {-# INLINABLE plus128 #-} plus128 :: Word128 -> Word128 -> Word128-plus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =- Word128 (W64# s1) (W64# s0)+plus128 (Word128 a1 a0) (Word128 b1 b0) =+ Word128 s1 s0 where- !(# c1, s0 #) = plusWord2# a0 b0- s1a = plusWord# a1 b1- s1 = plusWord# c1 s1a+ !(c1, s0) = plusCarrySum a0 b0+ !s1 = a1 + b1 + c1 {-# INLINABLE minus128 #-} minus128 :: Word128 -> Word128 -> Word128-minus128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =- Word128 (W64# d1) (W64# d0)+minus128 (Word128 a1 a0) (Word128 b1 b0) =+ Word128 d1 d0 where- !(# d0, c1 #) = subWordC# a0 b0- a1c = minusWord# a1 (int2Word# c1)- d1 = minusWord# a1c b1+ !(c1, d0) = subCarryDiff a0 b0+ !d1 = a1 - c1 - b1 times128 :: Word128 -> Word128 -> Word128-times128 (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) =- Word128 (W64# p1) (W64# p0)+times128 (Word128 a1 a0) (Word128 b1 b0) =+ Word128 p1 p0 where- !(# c1, p0 #) = timesWord2# a0 b0- p1a = timesWord# a1 b0- p1b = timesWord# a0 b1- p1c = plusWord# p1a p1b- p1 = plusWord# p1c c1+ !(c1, p0) = timesCarryProd a0 b0+ !p1a = a1 * b0+ !p1b = a0 * b1+ !p1c = p1a + p1b+ !p1 = p1c + c1 {-# INLINABLE negate128 #-} negate128 :: Word128 -> Word128-negate128 (Word128 (W64# a1) (W64# a0)) =- case plusWord2# (not# a0) (compatWordLiteral# 1##) of- (# c, s #) -> Word128 (W64# (plusWord# (not# a1) c)) (W64# s)+negate128 (Word128 a1 a0) =+ case plusCarrySum (complement a0) 1 of+ (c, s) -> Word128 (complement a1 + c) s {-# INLINABLE signum128 #-} signum128 :: Word128 -> Word128-signum128 (Word128 (W64# a) (W64# b)) =- if isZeroWord# a && isZeroWord# b+signum128 (Word128 a b) =+ if a == 0 && b == 0 then zeroWord128 else oneWord128 @@ -309,18 +304,15 @@ {-# 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))+and128 (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 .&. b1) (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))+or128 (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 .|. b1) (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))+xor128 (Word128 a1 a0) (Word128 b1 b0) = Word128 (xor a1 b1) (xor a0 b0) {-# INLINABLE complement128 #-} complement128 :: Word128 -> Word128@@ -356,8 +348,8 @@ rotateL128 :: Word128 -> Int -> Word128 rotateL128 w@(Word128 a1 a0) r- | r < 0 = zeroWord128 | r == 0 = w+ | r < 0 = zeroWord128 | r >= 128 = rotateL128 w (r `mod` 128) | r == 64 = Word128 a0 a1 | r > 64 = rotateL128 (Word128 a0 a1) (r `mod` 64)@@ -369,8 +361,8 @@ rotateR128 :: Word128 -> Int -> Word128 rotateR128 w@(Word128 a1 a0) r- | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) | r == 0 = w+ | r < 0 = rotateR128 w (128 - (abs r `mod` 128)) | r >= 128 = rotateR128 w (r `mod` 128) | r == 64 = Word128 a0 a1 | r > 64 = rotateR128 (Word128 a0 a1) (r `mod` 64)@@ -442,30 +434,24 @@ {-# INLINE halfTimes128 #-} halfTimes128 :: Word128 -> Word64 -> Word128-halfTimes128 (Word128 (W64# a1) (W64# a0)) (W64# b0) =- Word128 (W64# p1) (W64# p0)+halfTimes128 (Word128 a1 a0) b0 =+ Word128 p1 p0 where- !(# c1, p0 #) = timesWord2# a0 b0- p1a = timesWord# a1 b0- p1 = plusWord# p1a c1+ !(c1, p0) = timesCarryProd a0 b0+ p1a = a1 * b0+ p1 = p1a + c1 {-# INLINE quotRemThree #-} quotRemThree :: Word128 -> Word64 -> (Word128, Word128) quotRemThree num@(Word128 n1 n0) den | den == 0 = divZeroError | den == 1 = (num, zeroWord128)- | n1 < den = case quotRemWord64 n1 n0 den of+ | n1 < den = case quotRem2Word64 n1 n0 den of (q, r) -> (Word128 0 q, Word128 0 r) | otherwise = case quotRem n1 den of- (q1, r1) -> case quotRemWord64 r1 n0 den of- (q0, r0) -> (Word128 q1 q0, Word128 0 r0)--{-# INLINE quotRemWord64 #-}-quotRemWord64 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)-quotRemWord64 (W64# n1) (W64# n0) (W64# d) =- case quotRemWord2# n1 n0 d of- (# q, r #) -> (W64# q, W64# r)+ (q1, r1) -> case quotRem2Word64 r1 n0 den of+ (q0, r0) -> (Word128 q1 q0, Word128 0 r0) {-# INLINE quotRemTwo #-} quotRemTwo :: Word64 -> Word64 -> (Word128, Word128)
src/Data/WideWord/Word256.hs view
@@ -22,8 +22,6 @@ ---- "modulo 2^256" result as one would expect from a fixed width unsigned word. ------------------------------------------------------------------------------- -#include <MachDeps.h>- module Data.WideWord.Word256 ( Word256 (..) , showHexWord256@@ -45,21 +43,19 @@ import GHC.Base (Int (..)) import GHC.Enum (predError, succError) import GHC.Exts ((*#), (+#), Int#, State#, ByteArray#, MutableByteArray#, Addr#)-import GHC.Generics+import GHC.Generics (Generic) import GHC.Real ((%))-import GHC.Word (Word64 (..), Word32)--import Data.WideWord.Compat+import GHC.Word (Word32, Word64) -#if WORD_SIZE_IN_BITS < 64-import GHC.IntWord64-#endif+import Data.WideWord.Word64 import Numeric (showHex) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) import Data.Hashable (Hashable,hashWithSalt) +{- HLINT ignore "Use guards" -}+ data Word256 = Word256 { word256hi :: !Word64 , word256m1 :: !Word64@@ -74,11 +70,12 @@ showHexWord256 :: Word256 -> String showHexWord256 (Word256 a3 a2 a1 a0)- | a3 == 0 = if a2 == 0- then if a1 == 0- then showHex a0 ""- else showHex a1 zeros0 ++ showHex a0 ""- else showHex a2 zeros1 ++ showHex a1 zeros0 ++ showHex a0 ""+ | a3 == 0 =+ if a2 == 0+ then if a1 == 0+ then showHex a0 ""+ else showHex a1 zeros0 ++ showHex a0 ""+ else showHex a2 zeros1 ++ showHex a1 zeros0 ++ showHex a0 "" | otherwise = showHex a3 zeros2 ++ showHex a2 zeros1 ++ showHex a1 zeros0 ++ showHex a0 ""@@ -147,6 +144,7 @@ instance Real Word256 where toRational x = toInteger256 x % 1 +-- For unsigned values, quotRem is the same as divMod. instance Integral Word256 where quot n d = fst (quotRem256 n d) rem n d = snd (quotRem256 n d)@@ -243,25 +241,27 @@ succ256 :: Word256 -> Word256 succ256 (Word256 a3 a2 a1 a0)- | a0 == maxBound = if a1 == maxBound- then if a2 == maxBound- then if a3 == maxBound- then succError "Word256"- else Word256 (a3 + 1) 0 0 0- else Word256 a3 (a2 + 1) 0 0- else Word256 a3 a2 (a1 + 1) 0+ | a0 == maxBound =+ if a1 == maxBound+ then if a2 == maxBound+ then if a3 == maxBound+ then succError "Word256"+ else Word256 (a3 + 1) 0 0 0+ else Word256 a3 (a2 + 1) 0 0+ else Word256 a3 a2 (a1 + 1) 0 | otherwise = Word256 a3 a2 a1 (a0 + 1) pred256 :: Word256 -> Word256 pred256 (Word256 a3 a2 a1 a0)- | a0 == 0 = if a1 == 0- then if a2 == 0- then if a3 == 0- then predError "Word256"- else Word256 (a3 - 1) maxBound maxBound maxBound- else Word256 a3 (a2 - 1) maxBound maxBound- else Word256 a3 a2 (a1 - 1) maxBound+ | a0 == 0 =+ if a1 == 0+ then if a2 == 0+ then if a3 == 0+ then predError "Word256"+ else Word256 (a3 - 1) maxBound maxBound maxBound+ else Word256 a3 (a2 - 1) maxBound maxBound+ else Word256 a3 a2 (a1 - 1) maxBound | otherwise = Word256 a3 a2 a1 (a0 - 1) @@ -278,133 +278,114 @@ {-# INLINABLE plus256 #-} plus256 :: Word256 -> Word256 -> Word256-plus256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)+plus256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 s3 s2 s1 s0 where- !(# c1, s0 #) = plusWord2# a0 b0- !(# c2a, s1a #) = plusWord2# a1 b1- !(# c2b, s1 #) = plusWord2# s1a c1- c2 = plusWord# c2a c2b- !(# c3a, s2a #) = plusWord2# a2 b2- !(# c3b, s2 #) = plusWord2# s2a c2- c3 = plusWord# c3a c3b- s3 = plusWord# a3 (plusWord# b3 c3)+ !(c1, s0) = plusCarrySum a0 b0+ !(c2a, s1a) = plusCarrySum a1 b1+ !(c2b, s1) = plusCarrySum s1a c1+ !c2 = c2a + c2b+ !(c3a, s2a) = plusCarrySum a2 b2+ !(c3b, s2) = plusCarrySum s2a c2+ !c3 = c3a + c3b+ !s3 = a3 + b3 + c3 {-# INLINABLE minus256 #-} minus256 :: Word256 -> Word256 -> Word256-minus256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)+minus256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 s3 s2 s1 s0 where- !(# s0, v1 #) = subWordC# a0 b0- !(# s1, v2 #) =- case compatCaseOnIntLiteral# v1 of- 0# -> subWordC# a1 b1- _ ->- case compatCaseOnWordLiteral# a1 of- 0## -> (# minusWord# (compatWordLiteral# 0xFFFFFFFFFFFFFFFF##) b1, compatIntLiteral# 1# #)- _ -> subWordC# (minusWord# a1 (compatWordLiteral# 1##)) b1- !(# s2, v3 #) =- case compatCaseOnIntLiteral# v2 of- 0# -> subWordC# a2 b2- _ ->- case compatCaseOnWordLiteral# a2 of- 0## -> (# minusWord# (compatWordLiteral# 0xFFFFFFFFFFFFFFFF##) b2, compatIntLiteral# 1# #)- _ -> subWordC# (minusWord# a2 (compatWordLiteral# 1##)) b2+ !(v1, s0) = subCarryDiff a0 b0+ !(v2, s1) =+ if v1 == 0+ then subCarryDiff a1 b1+ else if a1 == 0+ then (0xFFFFFFFFFFFFFFFF - b1, 1)+ else subCarryDiff (a1 - 1) b1+ !(v3, s2) =+ if v2 == 0+ then subCarryDiff a2 b2+ else if a1 == 0+ then (0xFFFFFFFFFFFFFFFF - b2, 1)+ else subCarryDiff (a2 - 1) b2 !s3 =- case compatCaseOnIntLiteral# v3 of- 0# -> minusWord# a3 b3- _ -> minusWord# (minusWord# a3 (compatWordLiteral# 1##)) b3+ if v3 == 0+ then a3 - b3+ else (a3 - 1) - b3 times256 :: Word256 -> Word256 -> Word256-times256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# r3) (W64# r2) (W64# r1) (W64# r0)+times256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 r3 r2 r1 r0 where- !(# c00, p00 #) = timesWord2# a0 b0- !(# c01, p01 #) = timesWord2# a0 b1- !(# c02, p02 #) = timesWord2# a0 b2- !p03 = timesWord# a0 b3- !(# c10, p10 #) = timesWord2# a1 b0- !(# c11, p11 #) = timesWord2# a1 b1- !p12 = timesWord# a1 b2- !(# c20, p20 #) = timesWord2# a2 b0- !p21 = timesWord# a2 b1- !p30 = timesWord# a3 b0+ !(c00, p00) = timesCarryProd a0 b0+ !(c01, p01) = timesCarryProd a0 b1+ !(c02, p02) = timesCarryProd a0 b2+ !p03 = a0 * b3+ !(c10, p10) = timesCarryProd a1 b0+ !(c11, p11) = timesCarryProd a1 b1+ !p12 = a1 * b2+ !(c20, p20) = timesCarryProd a2 b0+ !p21 = a2 * b1+ !p30 = a3 * b0 !r0 = p00 !c1 = c00- !(# c2x, r1a #) = plusWord2# p01 p10- !(# c2y, r1b #) = plusWord2# r1a c1- !(# c3w, c2 #) = plusWord2# c2x c2y+ !(c2x, r1a) = plusCarrySum p01 p10+ !(c2y, r1b) = plusCarrySum r1a c1+ !(c3w, c2) = plusCarrySum c2x c2y !r1 = r1b- !(# c3x, r2a #) = plusWord2# p11 p20- !(# c3y, r2b #) = plusWord2# p02 r2a- !(# c3z, r2c #) = plusWord2# r2b c2- !(# c3s, r2d #) = plusWord2# r2c c01- !(# c3t, r2e #) = plusWord2# r2d c10+ !(c3x, r2a) = plusCarrySum p11 p20+ !(c3y, r2b) = plusCarrySum p02 r2a+ !(c3z, r2c) = plusCarrySum r2b c2+ !(c3s, r2d) = plusCarrySum r2c c01+ !(c3t, r2e) = plusCarrySum r2d c10 !r2 = r2e- !r3 = p30 `plusWord#` p21 `plusWord#` p12 `plusWord#`- p03 `plusWord#` c3w `plusWord#` c3x `plusWord#`- c3y `plusWord#` c3z `plusWord#` c3s `plusWord#`- c3t `plusWord#` c02 `plusWord#` c11 `plusWord#`- c20+ !r3 = p30 + p21 + p12 + p03 + c3w + c3x ++ c3y + c3z + c3s + c3t + c02 + c11 + c20 {-# INLINABLE negate256 #-} negate256 :: Word256 -> Word256-negate256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0)) =- case plusWord2# (not# a0) (compatWordLiteral# 1##) of- (# c1, s0 #) -> case plusWord2# (not# a1) c1 of- (# c2, s1 #) -> case plusWord2# (not# a2) c2 of- (# c3, s2 #) -> case plusWord# (not# a3) c3 of- s3 -> Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)+negate256 (Word256 a3 a2 a1 a0) =+ case plusCarrySum (complement a0) 1 of+ (c1, s0) -> case plusCarrySum (complement a1) c1 of+ (c2, s1) -> case plusCarrySum (complement a2) c2 of+ (c3, s2) -> case complement a3 + c3 of+ s3 -> Word256 s3 s2 s1 s0 {-# INLINABLE signum256 #-} signum256 :: Word256 -> Word256-signum256 (Word256 (W64# a) (W64# b) (W64# c) (W64# d))- | isZeroWord# a- , isZeroWord# b- , isZeroWord# c- , isZeroWord# d- = zeroWord256- | otherwise = oneWord256+signum256 (Word256 a b c d) =+ if a == 0 && b == 0 && c == 0 && d == 0+ then zeroWord256+ else oneWord256 fromInteger256 :: Integer -> Word256-fromInteger256 i = Word256- (fromInteger $ i `shiftR` 192)- (fromInteger $ i `shiftR` 128)- (fromInteger $ i `shiftR` 64)- (fromInteger i)+fromInteger256 i =+ Word256+ (fromInteger $ i `shiftR` 192) (fromInteger $ i `shiftR` 128)+ (fromInteger $ i `shiftR` 64) (fromInteger i) -- ----------------------------------------------------------------------------- -- Functions for `Bits` instance. {-# INLINABLE and256 #-} and256 :: Word256 -> Word256 -> Word256-and256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# (and# a3 b3)) (W64# (and# a2 b2))- (W64# (and# a1 b1)) (W64# (and# a0 b0))+and256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 (a3 .&. b3) (a2 .&. b2) (a1 .&. b1) (a0 .&. b0) {-# INLINABLE or256 #-} or256 :: Word256 -> Word256 -> Word256-or256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# (or# a3 b3)) (W64# (or# a2 b2))- (W64# (or# a1 b1)) (W64# (or# a0 b0))+or256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 (a3 .|. b3) (a2 .|. b2) (a1 .|. b1) (a0 .|. b0) {-# INLINABLE xor256 #-} xor256 :: Word256 -> Word256 -> Word256-xor256 (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))- (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =- Word256 (W64# (xor# a3 b3)) (W64# (xor# a2 b2))- (W64# (xor# a1 b1)) (W64# (xor# a0 b0))+xor256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =+ Word256 (xor a3 b3) (xor a2 b2) (xor a1 b1) (xor a0 b0) {-# INLINABLE complement256 #-} complement256 :: Word256 -> Word256-complement256 (Word256 a3 a2 a1 a0) = Word256- (complement a3) (complement a2)- (complement a1) (complement a0)+complement256 (Word256 a3 a2 a1 a0) =+ Word256 (complement a3) (complement a2) (complement a1) (complement a0) -- Probably not worth inlining this. shiftL256 :: Word256 -> Int -> Word256@@ -413,22 +394,24 @@ | s == 0 = w | s > 192 = Word256 (a0 `shiftL` (s - 192)) 0 0 0 | s == 192 = Word256 a0 0 0 0- | s > 128 = Word256- (a1 `shiftL` (s - 128) + a0 `shiftR` (192 - s))- (a0 `shiftL` (s - 128))- 0 0+ | s > 128 =+ Word256+ (a1 `shiftL` (s - 128) + a0 `shiftR` (192 - s))+ (a0 `shiftL` (s - 128)) 0 0 | s == 128 = Word256 a1 a0 0 0- | s > 64 = Word256- (a2 `shiftL` (s - 64) + a1 `shiftR` (128 - s))- (a1 `shiftL` (s - 64) + a0 `shiftR` (128 - s))- (a0 `shiftL` (s - 64))- 0+ | s > 64 =+ Word256+ (a2 `shiftL` (s - 64) + a1 `shiftR` (128 - s))+ (a1 `shiftL` (s - 64) + a0 `shiftR` (128 - s))+ (a0 `shiftL` (s - 64))+ 0 | s == 64 = Word256 a2 a1 a0 0- | otherwise = Word256- (a3 `shiftL` s + a2 `shiftR` (64 - s))- (a2 `shiftL` s + a1 `shiftR` (64 - s))- (a1 `shiftL` s + a0 `shiftR` (64 - s))- (a0 `shiftL` s)+ | otherwise =+ Word256+ (a3 `shiftL` s + a2 `shiftR` (64 - s))+ (a2 `shiftL` s + a1 `shiftR` (64 - s))+ (a1 `shiftL` s + a0 `shiftR` (64 - s))+ (a0 `shiftL` s) shiftR256 :: Word256 -> Int -> Word256 shiftR256 w@(Word256 a3 a2 a1 a0) s@@ -437,20 +420,19 @@ | s >= 256 = zeroWord256 | s > 192 = Word256 0 0 0 (a3 `shiftR` (s - 192)) | s == 192 = Word256 0 0 0 a3- | s > 128 = Word256 0 0- (a3 `shiftR` (s - 128))- (a2 `shiftR` (s - 128) + a3 `shiftL` (192 - s))+ | s > 128 =+ Word256 0 0 (a3 `shiftR` (s - 128)) (a2 `shiftR` (s - 128) + a3 `shiftL` (192 - s)) | s == 128 = Word256 0 0 a3 a2- | s > 64 = Word256 0- (a3 `shiftR` (s - 64))- (a2 `shiftR` (s - 64) + a3 `shiftL` (128 - s))- (a1 `shiftR` (s - 64) + a2 `shiftL` (128 - s))+ | s > 64 =+ Word256 0 (a3 `shiftR` (s - 64))+ (a2 `shiftR` (s - 64) + a3 `shiftL` (128 - s))+ (a1 `shiftR` (s - 64) + a2 `shiftL` (128 - s)) | s == 64 = Word256 0 a3 a2 a1- | otherwise = Word256- (a3 `shiftR` s)- (a2 `shiftR` s + a3 `shiftL` (64 - s))- (a1 `shiftR` s + a2 `shiftL` (64 - s))- (a0 `shiftR` s + a1 `shiftL` (64 - s))+ | otherwise =+ Word256 (a3 `shiftR` s)+ (a2 `shiftR` s + a3 `shiftL` (64 - s))+ (a1 `shiftR` s + a2 `shiftL` (64 - s))+ (a0 `shiftR` s + a1 `shiftL` (64 - s)) rotateL256 :: Word256 -> Int -> Word256 rotateL256 w@(Word256 a3 a2 a1 a0) r@@ -459,12 +441,9 @@ | r >= 256 = rotateL256 w (r `mod` 256) | r >= 64 = rotateL256 (Word256 a2 a1 a0 a3) (r - 64) | otherwise =- Word256 s3 s2 s1 s0- where- s0 = a0 `shiftL` r + a3 `shiftR` (64 - r)- s1 = a1 `shiftL` r + a0 `shiftR` (64 - r)- s2 = a2 `shiftL` r + a1 `shiftR` (64 - r)- s3 = a3 `shiftL` r + a2 `shiftR` (64 - r)+ Word256+ (a3 `shiftL` r + a2 `shiftR` (64 - r)) (a2 `shiftL` r + a1 `shiftR` (64 - r))+ (a1 `shiftL` r + a0 `shiftR` (64 - r)) (a0 `shiftL` r + a3 `shiftR` (64 - r)) rotateR256 :: Word256 -> Int -> Word256 rotateR256 w@(Word256 a3 a2 a1 a0) r@@ -473,12 +452,9 @@ | r >= 256 = rotateR256 w (r `mod` 256) | r >= 64 = rotateR256 (Word256 a0 a3 a2 a1) (r - 64) | otherwise =- Word256 s3 s2 s1 s0- where- s0 = a0 `shiftR` r + a1 `shiftL` (64 - r)- s1 = a1 `shiftR` r + a2 `shiftL` (64 - r)- s2 = a2 `shiftR` r + a3 `shiftL` (64 - r)- s3 = a3 `shiftR` r + a0 `shiftL` (64 - r)+ Word256+ (a3 `shiftR` r + a0 `shiftL` (64 - r)) (a2 `shiftR` r + a3 `shiftL` (64 - r))+ (a1 `shiftR` r + a2 `shiftL` (64 - r)) (a0 `shiftR` r + a1 `shiftL` (64 - r)) testBit256 :: Word256 -> Int -> Bool testBit256 (Word256 a3 a2 a1 a0) i@@ -534,28 +510,27 @@ toInteger256 :: Word256 -> Integer toInteger256 (Word256 a3 a2 a1 a0) =- (toInteger a3 `shiftL` 192)- + (toInteger a2 `shiftL` 128)- + (toInteger a1 `shiftL` 64)- + toInteger a0+ (toInteger a3 `shiftL` 192)+ + (toInteger a2 `shiftL` 128)+ + (toInteger a1 `shiftL` 64)+ + toInteger a0 -- ----------------------------------------------------------------------------- -- Functions for `Storable` instance. peek256 :: Ptr Word256 -> IO Word256-peek256 ptr = Word256- <$> peekElemOff (castPtr ptr) index3- <*> peekElemOff (castPtr ptr) index2- <*> peekElemOff (castPtr ptr) index1- <*> peekElemOff (castPtr ptr) index0+peek256 ptr =+ Word256 <$> peekElemOff (castPtr ptr) index3 <*> peekElemOff (castPtr ptr) index2+ <*> peekElemOff (castPtr ptr) index1 <*> peekElemOff (castPtr ptr) index0 peekElemOff256 :: Ptr Word256 -> Int -> IO Word256-peekElemOff256 ptr idx = Word256- <$> peekElemOff (castPtr ptr) (idx2 + index3)- <*> peekElemOff (castPtr ptr) (idx2 + index2)- <*> peekElemOff (castPtr ptr) (idx2 + index1)- <*> peekElemOff (castPtr ptr) (idx2 + index0)- where idx2 = 4 * idx+peekElemOff256 ptr idx =+ Word256 <$> peekElemOff (castPtr ptr) (idx2 + index3)+ <*> peekElemOff (castPtr ptr) (idx2 + index2)+ <*> peekElemOff (castPtr ptr) (idx2 + index1)+ <*> peekElemOff (castPtr ptr) (idx2 + index0)+ where+ idx2 = 4 * idx poke256 :: Ptr Word256 -> Word256 -> IO () poke256 ptr (Word256 a3 a2 a1 a0) = do@@ -566,11 +541,12 @@ pokeElemOff256 :: Ptr Word256 -> Int -> Word256 -> IO () pokeElemOff256 ptr idx (Word256 a3 a2 a1 a0) = do- pokeElemOff (castPtr ptr) (idx2 + index0) a0- pokeElemOff (castPtr ptr) (idx2 + index1) a1- pokeElemOff (castPtr ptr) (idx2 + index2) a2- pokeElemOff (castPtr ptr) (idx2 + index3) a3- where idx2 = 4 * idx+ pokeElemOff (castPtr ptr) (idx2 + index0) a0+ pokeElemOff (castPtr ptr) (idx2 + index1) a1+ pokeElemOff (castPtr ptr) (idx2 + index2) a2+ pokeElemOff (castPtr ptr) (idx2 + index3) a3+ where+ idx2 = 4 * idx -- ----------------------------------------------------------------------------- -- Functions for `Prim` instance.
+ src/Data/WideWord/Word64.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.WideWord.Word64+--+-- Maintainer : erikd@mega-nerd.com+-- Stability : experimental+-- Portability : non-portable (GHC extensions and primops)+--+-- This module provides an opaque unsigned 64 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^64" result as one would expect from a fixed width unsigned word.+--+-- This just re-exports the Word64 type defined in Data.Word plus some functions+-- like plusCarrySum and timesCarryProd that do the normal addition and multiplication+-- but provide a carry in addition to the regular operation.+-------------------------------------------------------------------------------++#include <MachDeps.h>++module Data.WideWord.Word64+ ( mkWord64+ , plusCarrySum+ , quotRem2Word64+ , showHexWord64+ , subCarryDiff+ , timesCarryProd+ , word64Hi32+ , word64Lo32+ , zeroWord64+ ) where++import Data.Bits (shiftL, shiftR)++import Data.WideWord.Compat++#if WORD_SIZE_IN_BITS == 32+import GHC.Prim (Word#, Word64#, uncheckedShiftRL64#, word64ToWord#, wordToWord32#)+#endif++import GHC.Word (Word32 (..), Word64 (..))++import Numeric (showHex)++{-# INLINE mkWord64 #-}+mkWord64 :: Word32 -> Word32 -> Word64+mkWord64 hi lo = fromIntegral hi `shiftL` 32 + fromIntegral lo++{-# INLINE showHexWord64 #-}+showHexWord64 :: Word64 -> String+showHexWord64 w = showHex w ""++{-# INLINE word64Hi32 #-}+word64Hi32 :: Word64 -> Word32+word64Hi32 w = fromIntegral (w `shiftR` 32)++{-# INLINE word64Lo32 #-}+word64Lo32 :: Word64 -> Word32+word64Lo32 = fromIntegral++{-# INLINE zeroWord64 #-}+zeroWord64 :: Word64+zeroWord64 = 0++#if WORD_SIZE_IN_BITS == 64++{-# INLINE plusCarrySum #-}+plusCarrySum :: Word64 -> Word64 -> (Word64, Word64)+plusCarrySum (W64# a) (W64# b) =+ let !(# c, s #) = plusWord2# a b+ in (W64# c, W64# s)++quotRem2Word64 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)+quotRem2Word64 (W64# n1) (W64# n0) (W64# d) =+ case quotRemWord2# n1 n0 d of+ (# q, r #) -> (W64# q, W64# r)++{-# INLINE subCarryDiff #-}+subCarryDiff :: Word64 -> Word64 -> (Word64, Word64)+subCarryDiff (W64# a) (W64# b) =+ let !(# s, c #) = subWordC# a b+ in (W64# (int2Word# c), W64# s)++{-# INLINE timesCarryProd #-}+timesCarryProd :: Word64 -> Word64 -> (Word64, Word64)+timesCarryProd (W64# a) (W64# b) =+ let !(# c, s #) = timesWord2# a b+ in (W64# c, W64# s)++#elif WORD_SIZE_IN_BITS == 32++{-# INLINE plusCarrySum #-}+plusCarrySum :: Word64 -> Word64 -> (Word64, Word64)+plusCarrySum (W64# a) (W64# b) =+ (mkWord64 0 (W32# (wordToWord32# c2)), mkWord64 (W32# (wordToWord32# s1)) (W32# (wordToWord32# s0)))+ where+ !(# a1, a0 #) = (# word64ToHiWord# a, word64ToWord# a #)+ !(# b1, b0 #) = (# word64ToHiWord# b, word64ToWord# b #)+ !(# c1, s0 #) = plusWord2# a0 b0+ !(# c2a, s1a #) = plusWord2# b1 c1+ !(# c2b, s1 #) = plusWord2# a1 s1a+ !c2 = plusWord# c2a c2b++quotRem2Word64 :: Word64 -> Word64 -> Word64 -> (Word64, Word64)+quotRem2Word64 n1 n0 d =+ -- This is correct, but sub-optimal and I could not be bothered writing an+ -- optimal version that is only needed for 32 bit systems.+ case quotRem (toInteger n1 `shiftL` 64 + toInteger n0) (toInteger d) of+ (q, r) -> (fromInteger q, fromInteger r)++{-# INLINE subCarryDiff #-}+subCarryDiff :: Word64 -> Word64 -> (Word64, Word64)+subCarryDiff (W64# a) (W64# b) =+ (mkWord64 0 (W32# (wordToWord32# c2)), mkWord64 (W32# (wordToWord32# d1)) (W32# (wordToWord32# d0)))+ where+ !(# a1, a0 #) = (# word64ToHiWord# a, word64ToWord# a #)+ !(# b1, b0 #) = (# word64ToHiWord# b, word64ToWord# b #)+ !(# d0, c1 #) = subWordC# a0 b0+ !(# d1a, c2a #) = subWordC# a1 (int2Word# c1)+ !(# d1, c2b #) = subWordC# d1a b1+ !c2 = plusWord# (int2Word# c2a) (int2Word# c2b)++{-# INLINE timesCarryProd #-}+timesCarryProd :: Word64 -> Word64 -> (Word64, Word64)+timesCarryProd (W64# a) (W64# b) =+ (mkWord64 (W32# (wordToWord32# p3)) (W32# (wordToWord32# p2)), mkWord64 (W32# (wordToWord32# p1)) (W32# (wordToWord32# p0)))+ where+ !(# a1, a0 #) = (# word64ToHiWord# a, word64ToWord# a #)+ !(# b1, b0 #) = (# word64ToHiWord# b, word64ToWord# b #)++ !(# c1a, p0 #) = timesWord2# a0 b0++ !(# c2a, p1a #) = timesWord2# a1 b0+ !(# c2b, p1b #) = timesWord2# a0 b1+ !(# c2c, p1c #) = plusWord2# p1a p1b+ !(# c2d, p1 #) = plusWord2# p1c c1a++ !(# c3a, p2a #) = timesWord2# a1 b1+ !(# c3b, p2b #) = plusWord2# p2a c2a+ !(# c3c, p2c #) = plusWord2# p2b c2b+ !(# c3d, p2d #) = plusWord2# p2c c2c+ !(# c3e, p2 #) = plusWord2# p2d c2d++ !p3 = c3a `plusWord#` c3b `plusWord#` c3c `plusWord#` c3d `plusWord#` c3e++word64ToHiWord# :: Word64# -> Word#+word64ToHiWord# w = word64ToWord# (w `uncheckedShiftRL64#` 32#)++#else++error "Sorry, this package only supports 32 and 64 bit word sizes."++#endif
test/Test/Data/WideWord/Gen.hs view
@@ -1,6 +1,5 @@ module Test.Data.WideWord.Gen where -import Data.Bits (shiftL) import Data.WideWord import Data.Word (Word32, Word64) @@ -19,7 +18,7 @@ genWord64 :: Gen Word64 genWord64 =- Gen.word64 Range.constantBounded+ fromIntegral <$> Gen.integral (Range.linear 0 maxBoundWord64) -- | Generate 'Word64' in one of five categories; -- * the full range@@ -29,20 +28,25 @@ -- * values near maxBound :: Word32 genBiasedWord64 :: Gen Word64 genBiasedWord64 =+ fromIntegral <$> Gen.choice- [ Gen.word64 (Range.linear 0 maxBound)- , Gen.word64 (Range.linear 0 100)- , (-) maxBound <$> Gen.word64 (Range.linear 0 100)- , Gen.word64 (Range.linear (halfMax - 100) (halfMax + 100))- , Gen.word64 (Range.linear (bits32 - 100) (bits32 + 100))+ [ Gen.integral (Range.linear 0 maxBoundWord64)+ , Gen.integral (Range.linear 0 100)+ , (-) maxBoundWord64 <$> Gen.integral (Range.linear 0 100)+ , Gen.integral (Range.linear (halfMax - 100) (halfMax + 100))+ , Gen.integral (Range.linear (bits32 - 100) (bits32 + 100)) ] where- bits32 :: Word64- bits32 = 1 `shiftL` 32+ bits32 :: Integer+ bits32 = fromIntegral (maxBound :: Word32) - halfMax :: Word64- halfMax = maxBound `div` 2+ halfMax :: Integer+ halfMax = fromIntegral (maxBound `div` 2 :: Word64) genWord128 :: Gen Word128 genWord128 = Word128 <$> genBiasedWord64 <*> genBiasedWord64++maxBoundWord64 :: Integer+maxBoundWord64 = fromIntegral (maxBound :: Word64)+
test/Test/Data/WideWord/Int128.hs view
@@ -10,6 +10,7 @@ import Data.Bifunctor (first) import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)+import Data.Int (Int32) import Data.Primitive.PrimArray import Data.Primitive.Ptr import Data.Word (Word8, Word64, byteSwap64)@@ -101,7 +102,7 @@ prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do- a0 <- H.forAll genWord32+ a0 <- H.forAll $ Gen.integral (Range.linear 0 (maxBound :: Int32)) let i128 = Int128 0 (fromIntegral a0) e128 = fromEnum i128 toInteger e128 === toInteger a0
test/Test/Data/WideWord/Word128.hs view
@@ -10,8 +10,10 @@ import Data.Bifunctor (first) import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)-import Data.Primitive.PrimArray-import Data.Primitive.Ptr+import Data.Int (Int32)+import Data.Primitive.PrimArray (primArrayFromList, primArrayToList, readPrimArray,+ setPrimArray, unsafeFreezePrimArray, unsafeThawPrimArray, writePrimArray)+import Data.Primitive.Ptr (readOffPtr, writeOffPtr) import Data.Word (Word8, Word64, byteSwap64) import Data.WideWord @@ -23,7 +25,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Test.Data.WideWord.Gen+import Test.Data.WideWord.Gen -- Set the number of times to run each property test here.@@ -107,7 +109,7 @@ prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do- a0 <- H.forAll genWord32+ a0 <- H.forAll $ Gen.integral (Range.linear 0 (maxBound :: Int32)) let w128 = Word128 0 (fromIntegral a0) e128 = fromEnum w128 toInteger e128 === toInteger a0@@ -353,7 +355,6 @@ writeOffPtr ptr 1 b128 (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1 (ar, br) === (a128, b128)- -- -----------------------------------------------------------------------------
+ test/Test/Data/WideWord/Word64.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Data.WideWord.Word64+ ( tests+ ) where++import Control.Exception (ArithException, SomeException, evaluate, try)+import Control.Monad.IO.Class (liftIO)+import Control.Monad (unless)++import Data.Bifunctor (first)+import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros+ , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor)+import Data.Primitive.PrimArray+import Data.Primitive.Ptr+import Data.Word (Word8, Word64, byteSwap64)+import Data.WideWord++import Foreign (allocaBytes)+import Foreign.Storable (Storable (..))++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++-- The other WideWord types are implemented in terms of Word64, so we test Word64 here+-- to make sure that we get the same results across platorms and with 32 bit architectures.++-- Set the number of times to run each property test here.+propertyCount :: H.PropertyT IO () -> Property+propertyCount =+ H.withTests 10000 . H.property++prop_byte_swap :: Property+prop_byte_swap =+ propertyCount $ do+ w <- H.forAll genWord64+ byteSwap64 (byteSwap64 w) === w++prop_derivied_eq_instance :: Property+prop_derivied_eq_instance =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ (a == b) === (word64Hi32 a == word64Hi32 b && word64Lo32 a == word64Lo32 b)++prop_ord_instance :: Property+prop_ord_instance =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ compare a b === compare (toInteger64 a) (toInteger64 b)++prop_show_instance :: Property+prop_show_instance =+ propertyCount $ do+ w64 <- H.forAll genWord64+ show w64 === show (toInteger64 w64)++prop_read_instance :: Property+prop_read_instance =+ propertyCount $ do+ w64 <- H.forAll genWord64+ read (show w64) === w64++prop_read_show :: Property+prop_read_show =+ propertyCount $ do+ w64 <- H.forAll genWord64+ H.tripping w64 show (Just . read)++prop_succ :: Property+prop_succ =+ propertyCount $ do+ w64 <- H.forAll genWord64+ res <- liftIO (fmap toInteger64 <$> tryEvaluate (succ w64))+ res === if w64 == maxBound+ then Left "Enum.succ{Word64}: tried to take `succ' of maxBound"+ else Right (succ $ toInteger64 w64)++prop_pred :: Property+prop_pred =+ propertyCount $ do+ w64 <- H.forAll genWord64+ res <- liftIO (fmap toInteger64 <$> tryEvaluate (pred w64))+ res === if w64 == 0+ then Left "Enum.pred{Word64}: tried to take `pred' of minBound"+ else Right $ pred (toInteger64 w64)++prop_toEnum_fromEnum :: Property+prop_toEnum_fromEnum =+ propertyCount $ do+ -- Need to rande limit the Word64, because `fromEnum` is limited to the positive part+ -- of the range of Int and we need to support 32 bit systems.+ w64 <- mkWord64 0 <$> H.forAll (Gen.filter (<= 0x7fffffff) genWord32)+ let e64 = fromEnum w64+ toInteger e64 === toInteger w64+ toInteger64 (toEnum e64 :: Word64) === toInteger w64++prop_addition :: Property+prop_addition =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ toInteger64 (a + b) === correctWord64 (toInteger64 a + toInteger64 b)++prop_subtraction :: Property+prop_subtraction =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ let ai = toInteger64 a+ bi = toInteger64 b+ expected = ai + (1 `shiftL` 64) - bi+ toInteger64 (a - b) === correctWord64 expected++prop_multiplication :: Property+prop_multiplication =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ toInteger64 (a * b) === correctWord64 (toInteger64 a * toInteger64 b)++prop_negate :: Property+prop_negate =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ toInteger64 (negate w64) === correctWord64 (negate $ toInteger64 w64)++prop_abs :: Property+prop_abs =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ toInteger64 (abs w64) === correctWord64 (abs $ toInteger64 w64)++prop_signum :: Property+prop_signum =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ toInteger64 (signum w64) === signum (toInteger64 w64)++prop_fromInteger :: Property+prop_fromInteger =+ propertyCount $ do+ i64 <- H.forAll $ Gen.integral (Range.linear 0 (fromIntegral (maxBound :: Word64) :: Integer))+ H.tripping i64 fromInteger (Just . toInteger64)++prop_bitwise_and :: Property+prop_bitwise_and =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ toInteger64 (a .&. b) === (toInteger64 a .&. toInteger64 b)++prop_bitwise_or :: Property+prop_bitwise_or =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ toInteger64 (a .|. b) === (toInteger64 a .|. toInteger64 b)++prop_bitwise_xor :: Property+prop_bitwise_xor =+ propertyCount $ do+ (a, b) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64+ toInteger64 (xor a b) === xor (toInteger64 a) (toInteger64 b)++prop_complement :: Property+prop_complement =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ complement (complement w64) === w64++prop_logical_shift_left :: Property+prop_logical_shift_left =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ shift <- H.forAll $ Gen.int (Range.linear 0 130)+ toInteger64 (shiftL w64 shift) === correctWord64 (shiftL (toInteger64 w64) shift)++prop_logical_shift_right :: Property+prop_logical_shift_right =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ shift <- H.forAll $ Gen.int (Range.linear 0 130)+ toInteger64 (shiftR w64 shift) === shiftR (toInteger64 w64) shift++prop_logical_rotate_left :: Property+prop_logical_rotate_left =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ -- Actually testing the default compiler implementation so range must be valid.+ rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-63) 500)+ let i64 = toInteger64 w64+ expected =+ correctWord64 (i64 `shiftL` erot + i64 `shiftR` (64 - (erot `mod` 64)))+ where+ erot+ | rot == 0 = 0+ | rot < 0 = 64 - abs rot `mod` 64+ | otherwise = rot `mod` 64+ toInteger64 (rotateL w64 rot) === expected++prop_logical_rotate_right :: Property+prop_logical_rotate_right =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ rot <- H.forAll $ Gen.int (Range.linearFrom 0 (-20000) 20000)+ let i64 = toInteger64 w64+ expected =+ correctWord64 (i64 `shiftR` erot + i64 `shiftL` (64 - erot))+ where+ erot+ | rot < 0 = 64 - abs rot `mod` 64+ | otherwise = rot `mod` 64+ toInteger64 (rotateR w64 rot) === expected++prop_testBit :: Property+prop_testBit =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ -- Actually testing the default compiler/machine implementation so range must be valid.+ idx <- H.forAll $ Gen.int (Range.linear 0 63)+ testBit w64 idx === testBit (toInteger64 w64) idx++prop_bit :: Property+prop_bit =+ propertyCount $ do+ -- Actually testing the default compiler/machine implementation so range must be valid.+ idx <- H.forAll $ Gen.int (Range.linear 0 63)+ toInteger64 (bit idx :: Word64) === (bit idx :: Integer)++prop_popCount :: Property+prop_popCount =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ popCount w64 === popCount (toInteger64 w64)++prop_countLeadingZeros :: Property+prop_countLeadingZeros =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ let a0 = word64Lo32 w64+ a1 = word64Hi32 w64+ let expected = if a1 == 0+ then 32 + countLeadingZeros a0+ else countLeadingZeros a1+ countLeadingZeros w64 === expected++prop_countTrailingZeros :: Property+prop_countTrailingZeros =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ let a0 = word64Lo32 w64+ a1 = word64Hi32 w64+ let expected = if a0 == 0+ then 32 + countTrailingZeros a1+ else countTrailingZeros a0+ countTrailingZeros w64 === 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 :: Property+prop_quotRem =+ propertyCount $ do+ num <- H.forAll genBiasedWord64+ den <- H.forAll $ Gen.filter (/= 0) genBiasedWord64+ let (q, r) = quotRem num den+ (toInteger64 q, toInteger64 r) === quotRem (toInteger64 num) (toInteger64 den)++prop_divMod :: Property+prop_divMod =+ propertyCount $ do+ num <- H.forAll genBiasedWord64+ den <- H.forAll $ Gen.filter (/= 0) genWord64+ let (d, m) = divMod num den+ (toInteger64 d, toInteger64 m) === divMod (toInteger64 num) (toInteger64 den)++prop_peek_and_poke :: Property+prop_peek_and_poke =+ propertyCount $ do+ w64 <- H.forAll genBiasedWord64+ ar <- liftIO $+ allocaBytes (sizeOf zeroWord64) $ \ ptr -> do+ poke ptr w64+ peek ptr+ toInteger64 ar === toInteger64 w64++prop_peekElemOff_pokeElemOff :: Property+prop_peekElemOff_pokeElemOff =+ propertyCount $ do+ a64 <- H.forAll genWord64+ b64 <- H.forAll genWord64+ (ar, br) <- liftIO $+ allocaBytes (2 * sizeOf zeroWord64) $ \ ptr -> do+ pokeElemOff ptr 0 a64+ pokeElemOff ptr 1 b64+ (,) <$> peekElemOff ptr 0 <*> peekElemOff ptr 1+ (toInteger64 ar, toInteger64 br) === (toInteger64 a64, toInteger64 b64)++prop_ToFromPrimArray :: Property+prop_ToFromPrimArray =+ H.withTests 2000 . H.property $ do+ as <- H.forAll $+ Gen.list (fromIntegral <$> (Range.linearBounded :: Range.Range Word8)) genWord64+ as === primArrayToList (primArrayFromList as)++prop_WriteReadPrimArray :: Property+prop_WriteReadPrimArray =+ H.withTests 2000 . H.property $ do+ as <- H.forAll $ Gen.list (Range.linear 1 256) genWord64+ unless (null as) $ do+ let len = length as+ arr = primArrayFromList as+ i <- (`mod` len) <$> H.forAll (Gen.int (Range.linear 0 (len - 1)))+ new <- H.forAll genWord64+ props <- liftIO $ do+ marr <- unsafeThawPrimArray arr+ prev <- readPrimArray marr i+ let prevProp = prev === (as !! i)+ writePrimArray marr i new+ cur <- readPrimArray marr i+ setPrimArray marr i 1 prev+ arr' <- unsafeFreezePrimArray marr+ return [prevProp, cur === new, arr === arr']+ sequence_ props++prop_readOffPtr_writeOffPtr :: Property+prop_readOffPtr_writeOffPtr =+ propertyCount $ do+ a64 <- H.forAll genWord64+ b64 <- H.forAll genWord64+ (ar, br) <- liftIO $+ allocaBytes (2 * sizeOf zeroWord64) $ \ ptr -> do+ writeOffPtr ptr 0 a64+ writeOffPtr ptr 1 b64+ (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1+ (ar, br) === (a64, b64)++prop_plusCarrySum :: Property+prop_plusCarrySum =+ propertyCount $ do+ a <- H.forAll genBiasedWord64+ b <- H.forAll genBiasedWord64+ let (carry, s) = plusCarrySum a b+ toInteger64 carry `shiftL` 64 + toInteger64 s === toInteger64 a + toInteger64 b++prop_quotRem2Word64 :: Property+prop_quotRem2Word64 =+ propertyCount $ do+ (num1, num0) <- H.forAll $ (,) <$> genWord64 <*> genWord64+ -- Denominator must be greater than the most significant part of the numerator.+ -- If its not, the quotient is not big enough to hold the result.+ den <- H.forAll $ Gen.filter (\ w -> w /= 0 && w > num1) genWord64+ H.assert (den > num1)+ let (q, r) = quotRem2Word64 num1 num0 den+ (toInteger64 q, toInteger64 r) === quotRem (toInteger $ Word128 num1 num0) (toInteger64 den)++prop_timesCarryProd :: Property+prop_timesCarryProd =+ propertyCount $ do+ a <- H.forAll genBiasedWord64+ b <- H.forAll genBiasedWord64+ let (carry, p) = timesCarryProd a b+ toInteger64 carry `shiftL` 64 + toInteger64 p === toInteger64 a * toInteger64 b++prop_subCarryDiff :: Property+prop_subCarryDiff =+ propertyCount $ do+ a <- H.forAll genBiasedWord64+ b <- H.forAll genBiasedWord64+ let (carry, d) = subCarryDiff a b+ if a >= b+ then (carry, toInteger64 d) === (0, toInteger64 a - toInteger64 b)+ else (carry, toInteger64 d) === (1, 1 + fromIntegral (maxBound :: Word64) - toInteger64 b + toInteger64 a)++-- -----------------------------------------------------------------------------++correctWord64 :: Integer -> Integer+correctWord64 i+ | i >= 0 && i <= maxWord64 = i+ | otherwise = i .&. maxWord64+ where+ maxWord64 = (1 `shiftL` 64) - 1++showArithException :: ArithException -> String+showArithException = show++toInteger64 :: Word64 -> Integer+toInteger64 = toInteger++tryEvaluate :: a -> IO (Either String a)+tryEvaluate x = do+ first renderException <$> try (evaluate x)+ where+ renderException :: SomeException -> String+ renderException = show++-- -----------------------------------------------------------------------------++tests :: IO Bool+tests =+ H.checkSequential $$discover
test/laws.hs view
@@ -5,11 +5,12 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Classes import Data.Semiring hiding ((+),(*))-import Data.Proxy (Proxy(Proxy))+import Data.Proxy (Proxy (Proxy)) import Data.Bits import Foreign.Storable import Data.Primitive.Types (Prim) import Data.Maybe (catMaybes)+import Data.Word (Word64) #if ! MIN_VERSION_base (4,11,0) import Data.Semigroup@@ -21,38 +22,41 @@ allPropsApplied :: [(String, [Laws])] allPropsApplied = [ ("Int128", allLaws (Proxy :: Proxy Int128))+ , ("Word64", allLaws (Proxy :: Proxy Word64)) , ("Word128", allLaws (Proxy :: Proxy Word128)) , ("Word256", allLaws (Proxy :: Proxy Word256)) ] -allLaws ::- ( Arbitrary a- , Bits a- , Bounded a- , Enum a- , Eq a- , FiniteBits a- , Integral a- , Ord a- , Prim a- , Read a- , Semiring a- , Semigroup a- , Show a- , Storable a- ) => Proxy a -> [Laws]-allLaws p = map ($ p)- [ bitsLaws- , boundedEnumLaws- , eqLaws- , integralLaws- , ordLaws- , semiringLaws- , semigroupLaws- , storableLaws- , primLaws- , numLaws- ]+allLaws+ :: ( Arbitrary a+ , Bits a+ , Bounded a+ , Enum a+ , Eq a+ , FiniteBits a+ , Integral a+ , Ord a+ , Prim a+ , Read a+ , Semiring a+ , Semigroup a+ , Show a+ , Storable a+ )+ => Proxy a -> [Laws]+allLaws p =+ map ($ p)+ [ bitsLaws+ , boundedEnumLaws+ , eqLaws+ , integralLaws+ , ordLaws+ , semiringLaws+ , semigroupLaws+ , storableLaws+ , primLaws+ , numLaws+ ] instance Arbitrary Word128 where arbitrary =@@ -106,8 +110,12 @@ instance Semigroup Word128 where (<>) = (+) +instance Semigroup Word64 where+ (<>) = (+)+ instance Semigroup Word256 where (<>) = (+) instance Semigroup Int128 where (<>) = (+)+
test/test.hs view
@@ -3,11 +3,13 @@ import System.Exit (exitFailure) import qualified Test.Data.WideWord.Int128+import qualified Test.Data.WideWord.Word64 import qualified Test.Data.WideWord.Word128 main :: IO () main = runTests [ Test.Data.WideWord.Int128.tests+ , Test.Data.WideWord.Word64.tests , Test.Data.WideWord.Word128.tests ]
wide-word.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wide-word-version: 0.1.3.0+version: 0.1.4.0 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@@ -24,8 +24,7 @@ extra-source-files: ChangeLog.md stability: provisional cabal-version: >= 1.10-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4,- GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7,+tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.1 library@@ -35,9 +34,10 @@ other-extensions: StrictData exposed-modules: Data.WideWord+ Data.WideWord.Int128+ Data.WideWord.Word64 Data.WideWord.Word128 Data.WideWord.Word256- Data.WideWord.Int128 other-modules: Data.WideWord.Compat @@ -58,12 +58,13 @@ other-modules: Test.Data.WideWord.Gen Test.Data.WideWord.Int128+ Test.Data.WideWord.Word64 Test.Data.WideWord.Word128 build-depends: base , bytestring >= 0.10 , ghc-prim- , hedgehog >= 1.0 && < 1.2+ , hedgehog >= 1.0 && < 1.3 , primitive , wide-word