wide-word-0.1.5.0/0000755000000000000000000000000007346545000011745 5ustar0000000000000000wide-word-0.1.5.0/ChangeLog.md0000644000000000000000000000234007346545000014115 0ustar0000000000000000# Revision history for wide-word ## 0.1.5.0 -- 2023-01-14 * Add Binary instances for Int128, Word128 and Word256. ## 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. ## 0.1.1.2 -- 2020-12-26 * Derive Generic for Int128, Word128 and Word256. * Fix Bits.isSigned instance for Int128. ## 0.1.1.1 -- 2020-03-22 * Make `sizeOf` and `alignment` methods of `Word256` `Prim` and `Storable` instances agree. ## 0.1.1.0 -- 2019-11-22 * Add `Word256`. ## 0.1.0.9 -- 2019-02-06 * Fix `Prim` instance for `Int128` ## 0.1.0.8 -- 2019-01-31 * Improve implementation of succ/pred. * Add tests for typeclass laws. * Add Prim instances for Int128 and Word128. * Fix/re-instate rewite rules. ## 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. ## 0.1.0.2 -- 2017-02-08 * Add NFData instances for Word128 and Int128. ## 0.1.0.1 -- 2017-01-29 * Int128: Fix flakey rewrite rules. ## 0.1.0.0 -- 2017-01-06 * First version. Released on an unsuspecting world. wide-word-0.1.5.0/LICENSE0000644000000000000000000000243507346545000012756 0ustar0000000000000000Copyright (c) 2017, Erik de Castro Lopo All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. wide-word-0.1.5.0/Setup.hs0000644000000000000000000000005607346545000013402 0ustar0000000000000000import Distribution.Simple main = defaultMain wide-word-0.1.5.0/src/Data/0000755000000000000000000000000007346545000013405 5ustar0000000000000000wide-word-0.1.5.0/src/Data/WideWord.hs0000644000000000000000000000026307346545000015466 0ustar0000000000000000module Data.WideWord ( module X ) 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 wide-word-0.1.5.0/src/Data/WideWord/0000755000000000000000000000000007346545000015131 5ustar0000000000000000wide-word-0.1.5.0/src/Data/WideWord/Compat.hs0000644000000000000000000000610207346545000016707 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StrictData #-} #if MIN_VERSION_base(4,17,0) {-# LANGUAGE UnboxedTuples #-} #endif -- | This module exists to centralize compatibility shims for GHC 9.4. module Data.WideWord.Compat ( plusWord2# , timesWord2# , int2Word# , minusWord# , subWordC# , not# , or# , and# , xor# , timesWord# , plusWord# , word2Int# , quotRemWord2# , compatWordLiteral# , compatIntLiteral# , compatCaseOnWordLiteral# , compatCaseOnIntLiteral# ) where #if MIN_VERSION_base(4,17,0) import qualified GHC.Base import GHC.Prim (Word64#, wordToWord64#, word64ToWord#, Int64#) #else import GHC.Base (Int#, Word#, quotRemWord2#, int2Word#, subWordC#, plusWord2#, or#, minusWord#, timesWord2#, word2Int#, xor#, and#, not#, plusWord#, timesWord#) #endif #if MIN_VERSION_base(4,17,0) plusWord2# :: Word64# -> Word64# -> (# Word64#, Word64# #) plusWord2# a b = case GHC.Base.plusWord2# (word64ToWord# a) (word64ToWord# b) of (# a', b' #) -> (# wordToWord64# a', wordToWord64# b' #) timesWord2# :: Word64# -> Word64# -> (# Word64#, Word64# #) timesWord2# a b = case GHC.Base.timesWord2# (word64ToWord# a) (word64ToWord# b) of (# a', b' #) -> (# wordToWord64# a', wordToWord64# b' #) int2Word# :: Int64# -> Word64# int2Word# = GHC.Base.int64ToWord64# minusWord# :: Word64# -> Word64# -> Word64# minusWord# a b = wordToWord64# (GHC.Base.minusWord# (word64ToWord# a) (word64ToWord# b)) subWordC# :: Word64# -> Word64# -> (# Word64#, Int64# #) subWordC# a b = case GHC.Base.subWordC# (word64ToWord# a) (word64ToWord# b) of (# a', b' #) -> (# wordToWord64# a', GHC.Base.intToInt64# b' #) not# :: Word64# -> Word64# not# = GHC.Base.not64# or# :: Word64# -> Word64# -> Word64# or# = GHC.Base.or64# xor# :: Word64# -> Word64# -> Word64# xor# = GHC.Base.xor64# and# :: Word64# -> Word64# -> Word64# and# = GHC.Base.and64# timesWord# :: Word64# -> Word64# -> Word64# timesWord# = GHC.Base.timesWord64# plusWord# :: Word64# -> Word64# -> Word64# plusWord# = GHC.Base.plusWord64# word2Int# :: Word64# -> Int64# word2Int# = GHC.Base.word64ToInt64# quotRemWord2# :: Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #) quotRemWord2# a b c = case GHC.Base.quotRemWord2# (word64ToWord# a) (word64ToWord# b) (word64ToWord# c) of (# x, y #) -> (# wordToWord64# x, wordToWord64# y #) #endif compatWordLiteral# #if MIN_VERSION_base(4,17,0) :: GHC.Base.Word# -> Word64# compatWordLiteral# = wordToWord64# #else :: Word# -> Word# compatWordLiteral# a = a #endif compatIntLiteral# #if MIN_VERSION_base(4,17,0) :: GHC.Base.Int# -> Int64# compatIntLiteral# = GHC.Base.intToInt64# #else :: Int# -> Int# compatIntLiteral# a = a #endif compatCaseOnWordLiteral# #if MIN_VERSION_base(4,17,0) :: Word64# -> GHC.Base.Word# compatCaseOnWordLiteral# = word64ToWord# #else :: Word# -> Word# compatCaseOnWordLiteral# a = a #endif compatCaseOnIntLiteral# #if MIN_VERSION_base(4,17,0) :: Int64# -> GHC.Base.Int# compatCaseOnIntLiteral# = GHC.Base.int64ToInt# #else :: Int# -> Int# compatCaseOnIntLiteral# a = a #endif wide-word-0.1.5.0/src/Data/WideWord/Int128.hs0000644000000000000000000004135107346545000016456 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# 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. ------------------------------------------------------------------------------- module Data.WideWord.Int128 ( Int128 (..) , byteSwapInt128 , showHexInt128 , zeroInt128 ) where import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..), FiniteBits (..), shiftL) import Data.Data (Data, Typeable) import Data.Ix (Ix) #if ! MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>)) #endif import Data.WideWord.Word128 import Numeric import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable (..)) import GHC.Base (Int (..)) import GHC.Enum (predError, succError) import GHC.Exts ((+#), (*#), State#, Int#, Addr#, ByteArray#, MutableByteArray#) import GHC.Generics import GHC.Real ((%)) import GHC.Word (Word32, Word64, byteSwap64) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) import Data.Hashable (Hashable, hashWithSalt) import Data.Binary (Binary (get, put)) import Data.WideWord.Word64 #if MIN_VERSION_base(4,17,0) #define ONE (wordToWord64# 1##) #else #define ONE (1##) #endif data Int128 = Int128 { int128Hi64 :: !Word64 , int128Lo64 :: !Word64 } deriving (Eq, Data, Generic, Ix, Typeable) instance Hashable Int128 where hashWithSalt s (Int128 a1 a2) = s `hashWithSalt` a1 `hashWithSalt` a2 -- | @since 0.1.5.0 instance Binary Int128 where put (Int128 a1 a2) = put a1 >> put a2 get = Int128 <$> get <*> get 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 _ = True 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 i = I# (sizeOf128# i) alignment i = I# (alignment128# i) peek = peek128 peekElemOff = peekElemOff128 poke = poke128 pokeElemOff = pokeElemOff128 instance NFData Int128 where -- The fields are already strict and unpacked, so do nothing. rnf !_ = () instance Prim Int128 where sizeOf# = sizeOf128# alignment# = alignment128# indexByteArray# = indexByteArray128# readByteArray# = readByteArray128# writeByteArray# = writeByteArray128# setByteArray# = setByteArray128# indexOffAddr# = indexOffAddr128# readOffAddr# = readOffAddr128# writeOffAddr# = writeOffAddr128# setOffAddr# = setOffAddr128# {-# INLINE sizeOf# #-} {-# INLINE alignment# #-} {-# INLINE indexByteArray# #-} {-# INLINE readByteArray# #-} {-# INLINE writeByteArray# #-} {-# INLINE setByteArray# #-} {-# INLINE indexOffAddr# #-} {-# INLINE readOffAddr# #-} {-# INLINE writeOffAddr# #-} {-# INLINE setOffAddr# #-} -- ----------------------------------------------------------------------------- -- Rewrite rules. {-# RULES "fromIntegral :: Int -> Int128" fromIntegral = fromInt "fromIntegral :: Word -> Int128" fromIntegral = fromWord "fromIntegral :: Word32 -> Int128" fromIntegral = fromWord32 "fromIntegral :: Word64 -> Int128" fromIntegral = Int128 0 "fromIntegral :: Int128 -> Int" fromIntegral = toInt "fromIntegral :: Int128 -> Word" fromIntegral = toWord "fromIntegral :: Int128 -> Word32" fromIntegral = toWord32 "fromIntegral :: Int128 -> Word64" fromIntegral = \(Int128 _ w) -> w #-} {-# INLINE fromInt #-} fromInt :: Int -> Int128 fromInt = Int128 0 . fromIntegral {-# INLINE fromWord #-} fromWord :: Word -> Int128 fromWord = Int128 0 . fromIntegral {-# INLINE fromWord32 #-} fromWord32 :: Word32 -> Int128 fromWord32 = Int128 0 . fromIntegral {-# INLINE toInt #-} toInt :: Int128 -> Int toInt (Int128 _ w) = fromIntegral w {-# INLINE toWord #-} toWord :: Int128 -> Word toWord (Int128 _ w) = fromIntegral w {-# INLINE toWord32 #-} toWord32 :: Int128 -> Word32 toWord32 (Int128 _ w) = fromIntegral w -- ----------------------------------------------------------------------------- -- Functions for `Ord` instance. compare128 :: Int128 -> Int128 -> Ordering 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 | 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 | otherwise = 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 a1 a0) (Int128 b1 b0) = Int128 s1 s0 where !(c1, s0) = plusCarrySum a0 b0 s1a = a1 + b1 s1 = c1 + s1a {-# INLINABLE minus128 #-} minus128 :: Int128 -> Int128 -> Int128 minus128 (Int128 a1 a0) (Int128 b1 b0) = Int128 d1 d0 where !(c1, d0) = subCarryDiff a0 b0 a1c = a1 - c1 d1 = a1c - b1 times128 :: Int128 -> Int128 -> Int128 times128 (Int128 a1 a0) (Int128 b1 b0) = Int128 p1 p0 where !(c1, p0) = timesCarryProd a0 b0 p1a = a1 * b0 p1b = a0 * b1 p1c = p1a + p1b p1 = p1c + c1 {-# INLINABLE negate128 #-} negate128 :: Int128 -> Int128 negate128 (Int128 a1 a0) = case plusCarrySum (complement a0) 1 of (c, s) -> Int128 (complement a1 + c) 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 a1 a0) (Int128 b1 b0) = Int128 (a1 .&. b1) (a0 .&. b0) {-# INLINABLE or128 #-} or128 :: Int128 -> Int128 -> Int128 or128 (Int128 a1 a0) (Int128 b1 b0) = Int128 (a1 .|. b1) (a0 .|. b0) {-# INLINABLE xor128 #-} xor128 :: Int128 -> Int128 -> Int128 xor128 (Int128 a1 a0) (Int128 b1 b0) = Int128 (xor a1 b1) (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 (a1 `shiftL` s + a0 `shiftR` (64 - s)) (a0 `shiftL` 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 (a1 `shiftR` s) (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 (a1 `shiftL` r + a0 `shiftR` (64 - r)) (a0 `shiftL` r + a1 `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 (a1 `shiftR` r + a0 `shiftL` (64 - r)) (a0 `shiftR` r + a1 `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 | isNeg numer && isNeg denom = (word128ToInt128 wq, word128ToInt128 (negate wr)) | isNeg numer = (word128ToInt128 (negate wq), word128ToInt128 (negate wr)) | isNeg denom = (word128ToInt128 (negate wq), word128ToInt128 wr) | otherwise = (word128ToInt128 wq, word128ToInt128 wr) where (wq, wr) = quotRem absNumerW absDenomW absNumerW = int128ToWord128 $ abs128 numer absDenomW = int128ToWord128 $ abs128 denom isNeg = topBitSetWord64 . int128Hi64 divMod128 :: Int128 -> Int128 -> (Int128, Int128) divMod128 numer denom | isNeg numer && isNeg denom = (word128ToInt128 wq, word128ToInt128 (negate wr)) | isNeg numer && wr == 0 = (word128ToInt128 (negate wq), 0) | isNeg numer = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (absDenomW - wr)) | isNeg denom && wr == 0 = (word128ToInt128 (negate wq), 0) | isNeg denom = (word128ToInt128 (negate $ wq + 1), word128ToInt128 (negate $ absDenomW - wr)) | otherwise = (word128ToInt128 wq, word128ToInt128 wr) where (wq, wr) = quotRem absNumerW absDenomW isNeg = topBitSetWord64 . int128Hi64 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 `Storable` 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) (idx2 + index1) <*> peekElemOff (castPtr ptr) (idx2 + index0) where idx2 = 2 * idx 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 let idx2 = 2 * idx pokeElemOff (castPtr ptr) (idx2 + index0) a0 pokeElemOff (castPtr ptr) (idx2 + 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 -- ----------------------------------------------------------------------------- -- Functions for `Prim` instance. {-# INLINE sizeOf128# #-} sizeOf128# :: Int128 -> Int# sizeOf128# _ = 2# *# sizeOf# (undefined :: Word64) {-# INLINE alignment128# #-} alignment128# :: Int128 -> Int# alignment128# _ = 2# *# alignment# (undefined :: Word64) {-# INLINE indexByteArray128# #-} indexByteArray128# :: ByteArray# -> Int# -> Int128 indexByteArray128# arr# i# = let i2# = 2# *# i# x = indexByteArray# arr# (i2# +# unInt index1) y = indexByteArray# arr# (i2# +# unInt index0) in Int128 x y {-# INLINE readByteArray128# #-} readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Int128 #) readByteArray128# arr# i# = \s0 -> case readByteArray# arr# (i2# +# unInt index1) s0 of (# s1, x #) -> case readByteArray# arr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Int128 x y #) where i2# = 2# *# i# {-# INLINE writeByteArray128# #-} writeByteArray128# :: MutableByteArray# s -> Int# -> Int128 -> State# s -> State# s writeByteArray128# arr# i# (Int128 a b) = \s0 -> case writeByteArray# arr# (i2# +# unInt index1) a s0 of s1 -> case writeByteArray# arr# (i2# +# unInt index0) b s1 of s2 -> s2 where i2# = 2# *# i# {-# INLINE setByteArray128# #-} setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Int128 -> State# s -> State# s setByteArray128# = defaultSetByteArray# {-# INLINE indexOffAddr128# #-} indexOffAddr128# :: Addr# -> Int# -> Int128 indexOffAddr128# addr# i# = let i2# = 2# *# i# x = indexOffAddr# addr# (i2# +# unInt index1) y = indexOffAddr# addr# (i2# +# unInt index0) in Int128 x y {-# INLINE readOffAddr128# #-} readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Int128 #) readOffAddr128# addr# i# = \s0 -> case readOffAddr# addr# (i2# +# unInt index1) s0 of (# s1, x #) -> case readOffAddr# addr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Int128 x y #) where i2# = 2# *# i# {-# INLINE writeOffAddr128# #-} writeOffAddr128# :: Addr# -> Int# -> Int128 -> State# s -> State# s writeOffAddr128# addr# i# (Int128 a b) = \s0 -> case writeOffAddr# addr# (i2# +# unInt index1) a s0 of s1 -> case writeOffAddr# addr# (i2# +# unInt index0) b s1 of s2 -> s2 where i2# = 2# *# i# {-# INLINE setOffAddr128# #-} setOffAddr128# :: Addr# -> Int# -> Int# -> Int128 -> State# s -> State# s setOffAddr128# = defaultSetOffAddr# -- ----------------------------------------------------------------------------- -- Constants. zeroInt128 :: Int128 zeroInt128 = Int128 0 0 oneInt128 :: Int128 oneInt128 = Int128 0 1 minusOneInt128 :: Int128 minusOneInt128 = Int128 maxBound maxBound unInt :: Int -> Int# unInt (I# i#) = i# index0, index1 :: Int #if WORDS_BIGENDIAN index0 = 1 index1 = 0 #else index0 = 0 index1 = 1 #endif wide-word-0.1.5.0/src/Data/WideWord/Word128.hs0000644000000000000000000004156007346545000016641 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# 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 Data.Data (Data, Typeable) import Data.Ix (Ix) #if ! MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>)) #endif import Data.WideWord.Word64 import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable (..)) import GHC.Base (Int (..)) import GHC.Enum (predError, succError) import GHC.Exts ((*#), (+#), Int#, State#, ByteArray#, MutableByteArray#, Addr#) import GHC.Generics (Generic) import GHC.Real ((%), divZeroError) import GHC.Word (Word32, Word64, byteSwap64) import Numeric (showHex) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) import Data.Hashable (Hashable, hashWithSalt) import Data.Binary (Binary (get, put)) data Word128 = Word128 { word128Hi64 :: !Word64 , word128Lo64 :: !Word64 } deriving (Eq, Data, Generic, Ix, Typeable) instance Hashable Word128 where hashWithSalt s (Word128 a1 a2) = s `hashWithSalt` a1 `hashWithSalt` a2 -- | @since 0.1.5.0 instance Binary Word128 where put (Word128 a1 a2) = put a1 >> put a2 get = Word128 <$> get <*> get 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 -- 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) 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 w = I# (sizeOf128# w) alignment w = I# (alignment128# w) peek = peek128 peekElemOff = peekElemOff128 poke = poke128 pokeElemOff = pokeElemOff128 instance NFData Word128 where -- The fields are already strict and unpacked, so do nothing. rnf !_ = () instance Prim Word128 where sizeOf# = sizeOf128# alignment# = alignment128# indexByteArray# = indexByteArray128# readByteArray# = readByteArray128# writeByteArray# = writeByteArray128# setByteArray# = setByteArray128# indexOffAddr# = indexOffAddr128# readOffAddr# = readOffAddr128# writeOffAddr# = writeOffAddr128# setOffAddr# = setOffAddr128# {-# INLINE sizeOf# #-} {-# INLINE alignment# #-} {-# INLINE indexByteArray# #-} {-# INLINE readByteArray# #-} {-# INLINE writeByteArray# #-} {-# INLINE setByteArray# #-} {-# INLINE indexOffAddr# #-} {-# INLINE readOffAddr# #-} {-# INLINE writeOffAddr# #-} {-# INLINE setOffAddr# #-} -- ----------------------------------------------------------------------------- -- Rewrite rules. {-# RULES "fromIntegral :: Word128 -> Word128" fromIntegral = id :: Word128 -> Word128 "fromIntegral :: Int -> Word128" fromIntegral = fromInt "fromIntegral :: Word -> Word128" fromIntegral = fromWord "fromIntegral :: Word32 -> Word128" fromIntegral = fromWord32 "fromIntegral :: Word64 -> Word128" fromIntegral = Word128 0 "fromIntegral :: Word128 -> Int" fromIntegral = toInt "fromIntegral :: Word128 -> Word" fromIntegral = toWord "fromIntegral :: Word128 -> Word32" fromIntegral = toWord32 "fromIntegral :: Word128 -> Word64" fromIntegral = \(Word128 _ w) -> w #-} {-# INLINE fromInt #-} fromInt :: Int -> Word128 fromInt = Word128 0 . fromIntegral {-# INLINE fromWord #-} fromWord :: Word -> Word128 fromWord = Word128 0 . fromIntegral {-# INLINE fromWord32 #-} fromWord32 :: Word32 -> Word128 fromWord32 = Word128 0 . fromIntegral {-# INLINE toInt #-} toInt :: Word128 -> Int toInt (Word128 _ w) = fromIntegral w {-# INLINE toWord #-} toWord :: Word128 -> Word toWord (Word128 _ w) = fromIntegral w {-# INLINE toWord32 #-} toWord32 :: Word128 -> Word32 toWord32 (Word128 _ w) = fromIntegral w -- ----------------------------------------------------------------------------- -- Functions for `Ord` instance. compare128 :: Word128 -> Word128 -> Ordering compare128 (Word128 a1 a0) (Word128 b1 b0) = compare a1 b1 <> compare a0 b0 -- ----------------------------------------------------------------------------- -- Functions for `Enum` instance. succ128 :: Word128 -> Word128 succ128 (Word128 a1 a0) | a0 == maxBound = if a1 == maxBound then succError "Word128" else Word128 (a1 + 1) 0 | otherwise = Word128 a1 (a0 + 1) pred128 :: Word128 -> Word128 pred128 (Word128 a1 a0) | a0 == 0 = if a1 == 0 then predError "Word128" else Word128 (a1 - 1) maxBound | otherwise = 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 a1 a0) (Word128 b1 b0) = Word128 s1 s0 where !(c1, s0) = plusCarrySum a0 b0 !s1 = a1 + b1 + c1 {-# INLINABLE minus128 #-} minus128 :: Word128 -> Word128 -> Word128 minus128 (Word128 a1 a0) (Word128 b1 b0) = Word128 d1 d0 where !(c1, d0) = subCarryDiff a0 b0 !d1 = a1 - c1 - b1 times128 :: Word128 -> Word128 -> Word128 times128 (Word128 a1 a0) (Word128 b1 b0) = Word128 p1 p0 where !(c1, p0) = timesCarryProd a0 b0 !p1a = a1 * b0 !p1b = a0 * b1 !p1c = p1a + p1b !p1 = p1c + c1 {-# INLINABLE negate128 #-} negate128 :: Word128 -> Word128 negate128 (Word128 a1 a0) = case plusCarrySum (complement a0) 1 of (c, s) -> Word128 (complement a1 + c) s {-# INLINABLE signum128 #-} signum128 :: Word128 -> Word128 signum128 (Word128 a b) = if a == 0 && b == 0 then zeroWord128 else 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 a1 a0) (Word128 b1 b0) = Word128 (a1 .&. b1) (a0 .&. b0) {-# INLINABLE or128 #-} or128 :: Word128 -> Word128 -> Word128 or128 (Word128 a1 a0) (Word128 b1 b0) = Word128 (a1 .|. b1) (a0 .|. b0) {-# INLINABLE xor128 #-} xor128 :: Word128 -> Word128 -> Word128 xor128 (Word128 a1 a0) (Word128 b1 b0) = Word128 (xor a1 b1) (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 = 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) | 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 = 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) | 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 | n1 == d1 = case compare n0 d0 of LT -> (zeroWord128, num) EQ -> (oneWord128, zeroWord128) GT -> (Word128 0 1, Word128 0 (n0 - d0)) | otherwise = quotRemFour num den {-# INLINE quotRemFour #-} quotRemFour :: Word128 -> Word128 -> (Word128, Word128) quotRemFour num@(Word128 n1 _) den@(Word128 d1 _) | remain < den = (Word128 0 qest, remain) -- The above is correct in most cases, but for the case where is not -- we have the following. While the following is correct, it is rather -- suboptimal. Would be nice to find something better. | otherwise = mapPair fromInteger128 $ quotRem (toInteger num) (toInteger den) where qest = quot n1 d1 prod = halfTimes128 den qest remain = minus128 num prod {-# INLINE halfTimes128 #-} halfTimes128 :: Word128 -> Word64 -> Word128 halfTimes128 (Word128 a1 a0) b0 = Word128 p1 p0 where !(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 quotRem2Word64 n1 n0 den of (q, r) -> (Word128 0 q, Word128 0 r) | otherwise = case quotRem n1 den of (q1, r1) -> case quotRem2Word64 r1 n0 den of (q0, r0) -> (Word128 q1 q0, Word128 0 r0) {-# INLINE quotRemTwo #-} quotRemTwo :: Word64 -> Word64 -> (Word128, Word128) quotRemTwo n0 d0 = case quotRem n0 d0 of (q, r) -> (Word128 0 q, Word128 0 r) {-# INLINE toInteger128 #-} toInteger128 :: Word128 -> Integer toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 -- ----------------------------------------------------------------------------- -- Functions for `Storable` 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) (idx2 + index1) <*> peekElemOff (castPtr ptr) (idx2 + index0) where idx2 = 2 * idx 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 let idx2 = 2 * idx pokeElemOff (castPtr ptr) (idx2 + index0) a0 pokeElemOff (castPtr ptr) (idx2 + index1) a1 -- ----------------------------------------------------------------------------- -- Functions for `Prim` instance. {-# INLINE sizeOf128# #-} sizeOf128# :: Word128 -> Int# sizeOf128# _ = 2# *# sizeOf# (0 :: Word64) {-# INLINE alignment128# #-} alignment128# :: Word128 -> Int# alignment128# _ = 2# *# alignment# (0 :: Word64) {-# INLINE indexByteArray128# #-} indexByteArray128# :: ByteArray# -> Int# -> Word128 indexByteArray128# arr# i# = let i2# = 2# *# i# x = indexByteArray# arr# (i2# +# unInt index1) y = indexByteArray# arr# (i2# +# unInt index0) in Word128 x y {-# INLINE readByteArray128# #-} readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Word128 #) readByteArray128# arr# i# = \s0 -> case readByteArray# arr# (i2# +# unInt index1) s0 of (# s1, x #) -> case readByteArray# arr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Word128 x y #) where i2# = 2# *# i# {-# INLINE writeByteArray128# #-} writeByteArray128# :: MutableByteArray# s -> Int# -> Word128 -> State# s -> State# s writeByteArray128# arr# i# (Word128 a b) = \s0 -> case writeByteArray# arr# (i2# +# unInt index1) a s0 of s1 -> case writeByteArray# arr# (i2# +# unInt index0) b s1 of s2 -> s2 where i2# = 2# *# i# {-# INLINE setByteArray128# #-} setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Word128 -> State# s -> State# s setByteArray128# = defaultSetByteArray# {-# INLINE indexOffAddr128# #-} indexOffAddr128# :: Addr# -> Int# -> Word128 indexOffAddr128# addr# i# = let i2# = 2# *# i# x = indexOffAddr# addr# (i2# +# unInt index1) y = indexOffAddr# addr# (i2# +# unInt index0) in Word128 x y {-# INLINE readOffAddr128# #-} readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Word128 #) readOffAddr128# addr# i# = \s0 -> case readOffAddr# addr# (i2# +# unInt index1) s0 of (# s1, x #) -> case readOffAddr# addr# (i2# +# unInt index0) s1 of (# s2, y #) -> (# s2, Word128 x y #) where i2# = 2# *# i# {-# INLINE writeOffAddr128# #-} writeOffAddr128# :: Addr# -> Int# -> Word128 -> State# s -> State# s writeOffAddr128# addr# i# (Word128 a b) = \s0 -> case writeOffAddr# addr# (i2# +# unInt index1) a s0 of s1 -> case writeOffAddr# addr# (i2# +# unInt index0) b s1 of s2 -> s2 where i2# = 2# *# i# {-# INLINE setOffAddr128# #-} setOffAddr128# :: Addr# -> Int# -> Int# -> Word128 -> State# s -> State# s setOffAddr128# = defaultSetOffAddr# mapPair :: (a -> b) -> (a, a) -> (b, b) mapPair f (a, b) = (f a, f b) -- ----------------------------------------------------------------------------- -- Constants. zeroWord128 :: Word128 zeroWord128 = Word128 0 0 oneWord128 :: Word128 oneWord128 = Word128 0 1 unInt :: Int -> Int# unInt (I# i#) = i# -- 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 wide-word-0.1.5.0/src/Data/WideWord/Word256.hs0000644000000000000000000005032507346545000016642 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- ---- | ---- Module : Data.WideWord.Word256 ---- ---- Maintainer : erikd@mega-nerd.com ---- Stability : experimental ---- Portability : non-portable (GHC extensions and primops) ---- ---- This module provides an opaque unsigned 256 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^256" result as one would expect from a fixed width unsigned word. ------------------------------------------------------------------------------- module Data.WideWord.Word256 ( Word256 (..) , showHexWord256 , zeroWord256 ) where import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..), FiniteBits (..), shiftL) import Data.Data (Data, Typeable) import Data.Ix (Ix) #if ! MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>)) #endif import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable (..)) import GHC.Base (Int (..)) import GHC.Enum (predError, succError) import GHC.Exts ((*#), (+#), Int#, State#, ByteArray#, MutableByteArray#, Addr#) import GHC.Generics (Generic) import GHC.Real ((%)) import GHC.Word (Word32, Word64) import Data.WideWord.Word64 import Numeric (showHex) import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) import Data.Hashable (Hashable, hashWithSalt) import Data.Binary (Binary (get, put)) {- HLINT ignore "Use guards" -} data Word256 = Word256 { word256hi :: !Word64 , word256m1 :: !Word64 , word256m0 :: !Word64 , word256lo :: !Word64 } deriving (Eq, Data, Generic, Ix, Typeable) instance Hashable Word256 where hashWithSalt s (Word256 a1 a2 a3 a4) = s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3 `hashWithSalt` a4 -- | @since 0.1.5.0 instance Binary Word256 where put (Word256 a1 a2 a3 a4) = put a1 >> put a2 >> put a3 >> put a4 get = Word256 <$> get <*> get <*> get <*> get 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 "" | otherwise = showHex a3 zeros2 ++ showHex a2 zeros1 ++ showHex a1 zeros0 ++ showHex a0 "" where h0 = showHex a0 "" h1 = showHex a1 "" h2 = showHex a2 "" zeros0 = replicate (16 - length h0) '0' zeros1 = replicate (16 - length h1) '0' zeros2 = replicate (16 - length h2) '0' instance Show Word256 where show = show . toInteger256 instance Read Word256 where readsPrec p s = [(fromInteger256 (x :: Integer), r) | (x, r) <- readsPrec p s] instance Ord Word256 where compare = compare256 instance Bounded Word256 where minBound = zeroWord256 maxBound = Word256 maxBound maxBound maxBound maxBound instance Enum Word256 where succ = succ256 pred = pred256 toEnum = toEnum256 fromEnum = fromEnum256 instance Num Word256 where (+) = plus256 (-) = minus256 (*) = times256 negate = negate256 abs = id signum = signum256 fromInteger = fromInteger256 instance Bits Word256 where (.&.) = and256 (.|.) = or256 xor = xor256 complement = complement256 shiftL = shiftL256 unsafeShiftL = shiftL256 shiftR = shiftR256 unsafeShiftR = shiftR256 rotateL = rotateL256 rotateR = rotateR256 bitSize _ = 256 bitSizeMaybe _ = Just 256 isSigned _ = False testBit = testBit256 bit = bit256 popCount = popCount256 instance FiniteBits Word256 where finiteBitSize _ = 256 countLeadingZeros = countLeadingZeros256 countTrailingZeros = countTrailingZeros256 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) div n d = fst (quotRem256 n d) mod n d = snd (quotRem256 n d) quotRem = quotRem256 divMod = quotRem256 toInteger = toInteger256 instance Storable Word256 where sizeOf w = I# (sizeOf256# w) alignment w = I# (alignment256# w) peek = peek256 peekElemOff = peekElemOff256 poke = poke256 pokeElemOff = pokeElemOff256 instance NFData Word256 where -- The fields are already strict and unpacked, so do nothing. rnf !_ = () instance Prim Word256 where sizeOf# = sizeOf256# alignment# = alignment256# indexByteArray# = indexByteArray256# readByteArray# = readByteArray256# writeByteArray# = writeByteArray256# setByteArray# = setByteArray256# indexOffAddr# = indexOffAddr256# readOffAddr# = readOffAddr256# writeOffAddr# = writeOffAddr256# setOffAddr# = setOffAddr256# {-# INLINE sizeOf# #-} {-# INLINE alignment# #-} {-# INLINE indexByteArray# #-} {-# INLINE readByteArray# #-} {-# INLINE writeByteArray# #-} {-# INLINE setByteArray# #-} {-# INLINE indexOffAddr# #-} {-# INLINE readOffAddr# #-} {-# INLINE writeOffAddr# #-} {-# INLINE setOffAddr# #-} -- ----------------------------------------------------------------------------- -- Rewrite rules. {-# RULES "fromIntegral :: Word256 -> Word256" fromIntegral = id :: Word256 -> Word256 "fromIntegral :: Int -> Word256" fromIntegral = fromInt "fromIntegral :: Word -> Word256" fromIntegral = fromWord "fromIntegral :: Word32 -> Word256" fromIntegral = fromWord32 "fromIntegral :: Word64 -> Word256" fromIntegral = Word256 0 0 0 "fromIntegral :: Word256 -> Int" fromIntegral = toInt "fromIntegral :: Word256 -> Word" fromIntegral = toWord "fromIntegral :: Word256 -> Word32" fromIntegral = toWord32 "fromIntegral :: Word256 -> Word64" fromIntegral = \(Word256 _ _ _ w) -> w #-} {-# INLINE fromInt #-} fromInt :: Int -> Word256 fromInt = Word256 0 0 0 . fromIntegral {-# INLINE fromWord #-} fromWord :: Word -> Word256 fromWord = Word256 0 0 0 . fromIntegral {-# INLINE fromWord32 #-} fromWord32 :: Word32 -> Word256 fromWord32 = Word256 0 0 0 . fromIntegral {-# INLINE toInt #-} toInt :: Word256 -> Int toInt (Word256 _ _ _ w) = fromIntegral w {-# INLINE toWord #-} toWord :: Word256 -> Word toWord (Word256 _ _ _ w) = fromIntegral w {-# INLINE toWord32 #-} toWord32 :: Word256 -> Word32 toWord32 (Word256 _ _ _ w) = fromIntegral w -- ----------------------------------------------------------------------------- -- Functions for `Ord` instance. compare256 :: Word256 -> Word256 -> Ordering compare256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = compare a3 b3 <> compare a2 b2 <> compare a1 b1 <> compare a0 b0 -- ----------------------------------------------------------------------------- -- Functions for `Enum` instance. 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 | 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 | otherwise = Word256 a3 a2 a1 (a0 - 1) {-# INLINABLE toEnum256 #-} toEnum256 :: Int -> Word256 toEnum256 i = Word256 0 0 0 (toEnum i) {-# INLINABLE fromEnum256 #-} fromEnum256 :: Word256 -> Int fromEnum256 (Word256 _ _ _ a0) = fromEnum a0 -- ----------------------------------------------------------------------------- -- Functions for `Num` instance. {-# INLINABLE plus256 #-} plus256 :: Word256 -> Word256 -> Word256 plus256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 s3 s2 s1 s0 where !(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 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 s3 s2 s1 s0 where !(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 = if v3 == 0 then a3 - b3 else (a3 - 1) - b3 times256 :: Word256 -> Word256 -> Word256 times256 (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = Word256 r3 r2 r1 r0 where !(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) = plusCarrySum p01 p10 !(c2y, r1b) = plusCarrySum r1a c1 !(c3w, c2) = plusCarrySum c2x c2y !r1 = r1b !(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 + p21 + p12 + p03 + c3w + c3x + c3y + c3z + c3s + c3t + c02 + c11 + c20 {-# INLINABLE negate256 #-} negate256 :: Word256 -> Word256 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 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) -- ----------------------------------------------------------------------------- -- Functions for `Bits` instance. {-# INLINABLE and256 #-} and256 :: Word256 -> Word256 -> Word256 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 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 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) -- Probably not worth inlining this. shiftL256 :: Word256 -> Int -> Word256 shiftL256 w@(Word256 a3 a2 a1 a0) s | s < 0 || s >= 256 = zeroWord256 | 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 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 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) shiftR256 :: Word256 -> Int -> Word256 shiftR256 w@(Word256 a3 a2 a1 a0) s | s < 0 = zeroWord256 | s == 0 = w | 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 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 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)) rotateL256 :: Word256 -> Int -> Word256 rotateL256 w@(Word256 a3 a2 a1 a0) r | r < 0 = zeroWord256 | r == 0 = w | r >= 256 = rotateL256 w (r `mod` 256) | r >= 64 = rotateL256 (Word256 a2 a1 a0 a3) (r - 64) | otherwise = 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 | r < 0 = rotateR256 w (256 - (abs r `mod` 256)) | r == 0 = w | r >= 256 = rotateR256 w (r `mod` 256) | r >= 64 = rotateR256 (Word256 a0 a3 a2 a1) (r - 64) | otherwise = 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 | i < 0 = False | i >= 256 = False | i >= 192 = testBit a3 (i - 192) | i >= 128 = testBit a2 (i - 128) | i >= 64 = testBit a1 (i - 64) | otherwise = testBit a0 i bit256 :: Int -> Word256 bit256 indx | indx < 0 = zeroWord256 | indx >= 256 = zeroWord256 | otherwise = shiftL256 oneWord256 indx popCount256 :: Word256 -> Int popCount256 (Word256 a3 a2 a1 a0) = popCount a3 + popCount a2 + popCount a1 + popCount a0 -- ----------------------------------------------------------------------------- -- Functions for `FiniteBits` instance. countLeadingZeros256 :: Word256 -> Int countLeadingZeros256 (Word256 a3 a2 a1 a0) = case countLeadingZeros a3 of 64 -> case countLeadingZeros a2 of 64 -> case countLeadingZeros a1 of 64 -> 192 + countLeadingZeros a0 res -> 128 + res res -> 64 + res res -> res countTrailingZeros256 :: Word256 -> Int countTrailingZeros256 (Word256 a3 a2 a1 a0) = case countTrailingZeros a0 of 64 -> case countTrailingZeros a1 of 64 -> case countTrailingZeros a2 of 64 -> 192 + countTrailingZeros a3 res -> 128 + res res -> 64 + res res -> res -- ----------------------------------------------------------------------------- -- Functions for `Integral` instance. -- TODO: This is inefficient, but the better version is rather -- tedious to write out. quotRem256 :: Word256 -> Word256 -> (Word256, Word256) quotRem256 a b = let (x,y) = quotRem (toInteger256 a) (toInteger256 b) in (fromInteger256 x, fromInteger256 y) toInteger256 :: Word256 -> Integer toInteger256 (Word256 a3 a2 a1 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 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 poke256 :: Ptr Word256 -> Word256 -> IO () poke256 ptr (Word256 a3 a2 a1 a0) = do pokeElemOff (castPtr ptr) index3 a3 pokeElemOff (castPtr ptr) index2 a2 pokeElemOff (castPtr ptr) index1 a1 pokeElemOff (castPtr ptr) index0 a0 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 -- ----------------------------------------------------------------------------- -- Functions for `Prim` instance. {-# INLINE sizeOf256# #-} sizeOf256# :: Word256 -> Int# sizeOf256# _ = 4# *# sizeOf# (0 :: Word64) {-# INLINE alignment256# #-} alignment256# :: Word256 -> Int# alignment256# _ = 4# *# alignment# (0 :: Word64) {-# INLINE indexByteArray256# #-} indexByteArray256# :: ByteArray# -> Int# -> Word256 indexByteArray256# arr# i# = let i2# = 4# *# i# w = indexByteArray# arr# (i2# +# unInt index3) x = indexByteArray# arr# (i2# +# unInt index2) y = indexByteArray# arr# (i2# +# unInt index1) z = indexByteArray# arr# (i2# +# unInt index0) in Word256 w x y z {-# INLINE readByteArray256# #-} readByteArray256# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Word256 #) readByteArray256# arr# i# = \s0 -> case readByteArray# arr# (i2# +# unInt index3) s0 of (# s1, w #) -> case readByteArray# arr# (i2# +# unInt index2) s1 of (# s2, x #) -> case readByteArray# arr# (i2# +# unInt index1) s2 of (# s3, y #) -> case readByteArray# arr# (i2# +# unInt index0) s3 of (# s4, z #) -> (# s4, Word256 w x y z #) where i2# = 4# *# i# {-# INLINE writeByteArray256# #-} writeByteArray256# :: MutableByteArray# s -> Int# -> Word256 -> State# s -> State# s writeByteArray256# arr# i# (Word256 a b c d) = \s0 -> case writeByteArray# arr# (i2# +# unInt index3) a s0 of s1 -> case writeByteArray# arr# (i2# +# unInt index2) b s1 of s2 -> case writeByteArray# arr# (i2# +# unInt index1) c s2 of s3 -> case writeByteArray# arr# (i2# +# unInt index0) d s3 of s4 -> s4 where i2# = 4# *# i# {-# INLINE setByteArray256# #-} setByteArray256# :: MutableByteArray# s -> Int# -> Int# -> Word256 -> State# s -> State# s setByteArray256# = defaultSetByteArray# {-# INLINE indexOffAddr256# #-} indexOffAddr256# :: Addr# -> Int# -> Word256 indexOffAddr256# arr# i# = let i2# = 4# *# i# w = indexOffAddr# arr# (i2# +# unInt index3) x = indexOffAddr# arr# (i2# +# unInt index2) y = indexOffAddr# arr# (i2# +# unInt index1) z = indexOffAddr# arr# (i2# +# unInt index0) in Word256 w x y z {-# INLINE readOffAddr256# #-} readOffAddr256# :: Addr# -> Int# -> State# s -> (# State# s, Word256 #) readOffAddr256# arr# i# = \s0 -> case readOffAddr# arr# (i2# +# unInt index3) s0 of (# s1, w #) -> case readOffAddr# arr# (i2# +# unInt index2) s1 of (# s2, x #) -> case readOffAddr# arr# (i2# +# unInt index1) s2 of (# s3, y #) -> case readOffAddr# arr# (i2# +# unInt index0) s3 of (# s4, z #) -> (# s4, Word256 w x y z #) where i2# = 4# *# i# {-# INLINE writeOffAddr256# #-} writeOffAddr256# :: Addr# -> Int# -> Word256 -> State# s -> State# s writeOffAddr256# arr# i# (Word256 a b c d) = \s0 -> case writeOffAddr# arr# (i2# +# unInt index3) a s0 of s1 -> case writeOffAddr# arr# (i2# +# unInt index2) b s1 of s2 -> case writeOffAddr# arr# (i2# +# unInt index1) c s2 of s3 -> case writeOffAddr# arr# (i2# +# unInt index0) d s3 of s4 -> s4 where i2# = 4# *# i# {-# INLINE setOffAddr256# #-} setOffAddr256# :: Addr# -> Int# -> Int# -> Word256 -> State# s -> State# s setOffAddr256# = defaultSetOffAddr# -- ----------------------------------------------------------------------------- -- Constants. zeroWord256 :: Word256 zeroWord256 = Word256 0 0 0 0 oneWord256 :: Word256 oneWord256 = Word256 0 0 0 1 unInt :: Int -> Int# unInt (I# i#) = i# -- Use these indices to get the peek/poke ordering endian correct. index0, index1, index2, index3 :: Int #if WORDS_BIGENDIAN index0 = 3 index1 = 2 index2 = 1 index3 = 0 #else index0 = 0 index1 = 1 index2 = 2 index3 = 3 #endif wide-word-0.1.5.0/src/Data/WideWord/Word64.hs0000644000000000000000000001211007346545000016545 0ustar0000000000000000{-# 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 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 wide-word-0.1.5.0/test/Test/Data/WideWord/0000755000000000000000000000000007346545000016240 5ustar0000000000000000wide-word-0.1.5.0/test/Test/Data/WideWord/Gen.hs0000644000000000000000000000260307346545000017306 0ustar0000000000000000module Test.Data.WideWord.Gen where import Data.WideWord import Data.Word (Word32, Word64) import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range genInt128 :: Gen Int128 genInt128 = Int128 <$> genBiasedWord64 <*> genBiasedWord64 genWord32 :: Gen Word32 genWord32 = Gen.word32 Range.constantBounded genWord64 :: Gen Word64 genWord64 = fromIntegral <$> Gen.integral (Range.linear 0 maxBoundWord64) -- | Generate 'Word64' in one of five categories; -- * the full range -- * small values near zero -- * large values near maxBound :: Word64 -- * values near maxBound / 2 :: Word64 -- * values near maxBound :: Word32 genBiasedWord64 :: Gen Word64 genBiasedWord64 = fromIntegral <$> Gen.choice [ 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 :: Integer bits32 = fromIntegral (maxBound :: Word32) halfMax :: Integer halfMax = fromIntegral (maxBound `div` 2 :: Word64) genWord128 :: Gen Word128 genWord128 = Word128 <$> genBiasedWord64 <*> genBiasedWord64 maxBoundWord64 :: Integer maxBoundWord64 = fromIntegral (maxBound :: Word64) wide-word-0.1.5.0/test/Test/Data/WideWord/Int128.hs0000644000000000000000000003003007346545000017555 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Int128 ( tests ) where import Control.Exception (SomeException, evaluate, try) import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (first) import qualified Data.Binary as Binary 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) 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 -- Set the number of times to run each property test here. propertyCount :: H.PropertyT IO () -> Property propertyCount = H.withTests 10000 . H.property prop_constructor_and_accessors :: Property prop_constructor_and_accessors = propertyCount $ do (h, l) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let i128 = Int128 h l (int128Hi64 i128, int128Lo64 i128) === (h, l) prop_byte_swap :: Property prop_byte_swap = propertyCount $ do h <- H.forAll genBiasedWord64 l <- H.forAll $ Gen.filter (/= h) genBiasedWord64 let w128 = Int128 h l swapped = byteSwapInt128 w128 (byteSwapInt128 swapped, byteSwap64 (fromIntegral h), byteSwap64 (fromIntegral l)) === (w128, int128Lo64 swapped, int128Hi64 swapped) prop_derivied_eq_instance :: Property prop_derivied_eq_instance = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 (b1, b0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 (Int128 a1 a0 == Int128 b1 b0) === (a1 == b1 && a0 == b0) prop_ord_instance :: Property prop_ord_instance = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 compare a b === compare (toInteger128 a) (toInteger128 b) prop_show_instance :: Property prop_show_instance = propertyCount $ do i128 <- H.forAll genInt128 show i128 === show (toInteger128 i128) prop_read_instance :: Property prop_read_instance = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 read (show $ Int128 a1 a0) === Int128 a1 a0 prop_succ :: Property prop_succ = propertyCount $ do i128 <- H.forAll genInt128 res <- liftIO (fmap toInteger128 <$> tryEvaluate (succ i128)) res === if i128 == maxBound then Left "Enum.succ{Int128}: tried to take `succ' of maxBound" else Right (succ $ toInteger128 i128) prop_pred :: Property prop_pred = propertyCount $ do i128 <- H.forAll genInt128 res <- liftIO (fmap toInteger128 <$> tryEvaluate (pred i128)) res === if i128 == minBound then Left "Enum.pred{Int128}: tried to take `pred' of minBound" else Right $ pred (toInteger128 i128) tryEvaluate :: a -> IO (Either String a) tryEvaluate x = do first renderException <$> try (evaluate x) where renderException :: SomeException -> String renderException = show prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do a0 <- H.forAll $ Gen.integral (Range.linear 0 (maxBound :: Int32)) let i128 = Int128 0 (fromIntegral a0) e128 = fromEnum i128 toInteger e128 === toInteger a0 toInteger128 (toEnum e128 :: Int128) === toInteger a0 prop_addition :: Property prop_addition = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 toInteger128 (a + b) === correctInt128 (toInteger128 a + toInteger128 b) 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_multiplication :: Property prop_multiplication = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genInt128 <*> genInt128 toInteger128 (a * b) === correctInt128 (toInteger128 a * toInteger128 b) prop_negate :: Property prop_negate = propertyCount $ do i128 <- H.forAll genInt128 toInteger128 (negate i128) === correctInt128 (negate $ toInteger128 i128) prop_abs :: Property prop_abs = propertyCount $ do i128 <- H.forAll genInt128 toInteger128 (abs i128) === correctInt128 (abs $ toInteger128 i128) 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 $ (,) <$> genBiasedWord64 <*> genBiasedWord64 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 $ (,) <$> genBiasedWord64 <*> genBiasedWord64 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 $ (,) <$> genBiasedWord64 <*> genBiasedWord64 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 (toInteger128 i128) idx testBit i128 idx === expected 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 toInteger128 (bit idx :: Int128) === expected prop_popCount :: Property prop_popCount = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 popCount (Int128 a1 a0) === popCount a1 + popCount a0 prop_countLeadingZeros :: Property prop_countLeadingZeros = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let expected = if a1 == 0 then 64 + countLeadingZeros a0 else countLeadingZeros a1 countLeadingZeros (Int128 a1 a0) === expected prop_countTrailingZeros :: Property prop_countTrailingZeros = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genBiasedWord64 <*> genBiasedWord64 let expected = if a0 == 0 then 64 + countTrailingZeros a1 else countTrailingZeros a0 countTrailingZeros (Int128 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 :: 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 :: 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_roundtrip_binary :: Property prop_roundtrip_binary = propertyCount $ do i128 <- H.forAll genWord128 H.tripping i128 Binary.encode (Just . Binary.decode) 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 :: 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) === (toInteger128 a128, toInteger128 b128) prop_ToFromPrimArray :: Property prop_ToFromPrimArray = H.withTests 2000 . H.property $ do as <- H.forAll $ Gen.list (fromIntegral <$> (Range.linearBounded :: Range.Range Word8)) genInt128 as === primArrayToList (primArrayFromList as) prop_WriteReadPrimArray :: Property prop_WriteReadPrimArray = H.withTests 2000 . H.property $ do as <- H.forAll $ Gen.list (Range.linear 1 256) genInt128 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 genInt128 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 a128 <- H.forAll genInt128 b128 <- H.forAll genInt128 (ar, br) <- liftIO $ allocaBytes (2 * sizeOf zeroInt128) $ \ ptr -> do writeOffPtr ptr 0 a128 writeOffPtr ptr 1 b128 (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1 (ar, br) === (a128, 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 correctInt128 x | x >= minBoundInt128 && x <= maxBoundInt128 = x | otherwise = toInteger (fromIntegral x :: Int128) where minBoundInt128 = fromIntegral (minBound :: Int128) maxBoundInt128 = fromIntegral (maxBound :: Int128) toInteger128 :: Int128 -> Integer toInteger128 = toInteger -- ----------------------------------------------------------------------------- tests :: IO Bool tests = H.checkParallel $$discover wide-word-0.1.5.0/test/Test/Data/WideWord/Word128.hs0000644000000000000000000003102207346545000017740 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Data.WideWord.Word128 ( tests ) where import Control.Exception (ArithException, SomeException, evaluate, try) import Control.Monad.IO.Class (liftIO) import Control.Monad (unless) import Data.Bifunctor (first) import qualified Data.Binary as Binary import Data.Bits ((.&.), (.|.), bit, complement, countLeadingZeros, countTrailingZeros , popCount, rotateL, rotateR, shiftL, shiftR, testBit, xor) 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 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 -- Set the number of times to run each property test here. propertyCount :: H.PropertyT IO () -> Property propertyCount = H.withTests 10000 . H.property 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_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_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_ord_instance :: Property prop_ord_instance = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 compare a b === compare (toInteger128 a) (toInteger128 b) prop_show_instance :: Property prop_show_instance = propertyCount $ do w128 <- H.forAll genWord128 show w128 === show (toInteger128 w128) prop_read_instance :: Property prop_read_instance = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 read (show $ Word128 a1 a0) === Word128 a1 a0 prop_read_show :: Property prop_read_show = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 H.tripping (Word128 a1 a0) show (Just . read) prop_succ :: Property prop_succ = propertyCount $ do w128 <- H.forAll genWord128 res <- liftIO (fmap toInteger128 <$> tryEvaluate (succ w128)) res === if w128 == maxBound then Left "Enum.succ{Word128}: tried to take `succ' of maxBound" else Right (succ $ toInteger128 w128) prop_pred :: Property prop_pred = propertyCount $ do w128 <- H.forAll genWord128 res <- liftIO (fmap toInteger128 <$> tryEvaluate (pred w128)) res === if w128 == 0 then Left "Enum.pred{Word128}: tried to take `pred' of minBound" else Right $ pred (toInteger128 w128) tryEvaluate :: a -> IO (Either String a) tryEvaluate x = do first renderException <$> try (evaluate x) where renderException :: SomeException -> String renderException = show prop_toEnum_fromEnum :: Property prop_toEnum_fromEnum = propertyCount $ do a0 <- H.forAll $ Gen.integral (Range.linear 0 (maxBound :: Int32)) let w128 = Word128 0 (fromIntegral a0) e128 = fromEnum w128 toInteger e128 === toInteger a0 toInteger128 (toEnum e128 :: Word128) === toInteger a0 prop_addition :: Property prop_addition = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 toInteger128 (a + b) === correctWord128 (toInteger128 a + toInteger128 b) 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 (a - b) === correctWord128 expected prop_multiplication :: Property prop_multiplication = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 toInteger128 (a * b) === correctWord128 (toInteger128 a * toInteger128 b) prop_negate :: Property prop_negate = propertyCount $ do w128 <- H.forAll genWord128 toInteger128 (negate w128) === correctWord128 (negate $ toInteger128 w128) prop_abs :: Property prop_abs = propertyCount $ do w128 <- H.forAll genWord128 toInteger128 (abs w128) === correctWord128 (abs $ toInteger128 w128) prop_signum :: Property prop_signum = propertyCount $ do w128 <- H.forAll genWord128 toInteger128 (signum w128) === signum (toInteger128 w128) prop_fromInteger :: Property prop_fromInteger = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 let w128 = fromInteger $ mkInteger a1 a0 (word128Hi64 w128, word128Lo64 w128) === (a1, a0) prop_bitwise_and :: Property prop_bitwise_and = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 toInteger128 (a .&. b) === (toInteger128 a .&. toInteger128 b) prop_bitwise_or :: Property prop_bitwise_or = propertyCount $ do (a, b) <- H.forAll $ (,) <$> genWord128 <*> genWord128 toInteger128 (a .|. b) === (toInteger128 a .|. toInteger128 b) 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_complement :: Property prop_complement = propertyCount $ do (a1, a0) <- H.forAll $ (,) <$> genWord64 <*> genWord64 toInteger128 (complement $ Word128 a1 a0) === mkInteger (complement a1) (complement 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 = correctWord128 (i128 `shiftL` erot + i128 `shiftR` (128 - (erot `mod` 128))) where erot | rot < 0 = 128 - (abs rot `mod` 128) | otherwise = rot `mod` 128 toInteger128 (rotateL w128 rot) === expected 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 w128 rot) === 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 (toInteger128 w128) idx testBit w128 idx === expected 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) === expected prop_popCount :: Property prop_popCount = propertyCount $ do w128 <- H.forAll genWord128 popCount w128 === popCount (toInteger128 w128) 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) === expected 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) === 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 genWord128 den <- H.forAll $ Gen.filter (/= 0) genWord128 let (q, r) = quotRem num den (toInteger128 q, toInteger128 r) === quotRem (toInteger128 num) (toInteger128 den) 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_roundtrip_binary :: Property prop_roundtrip_binary = propertyCount $ do w128 <- H.forAll genWord128 H.tripping w128 Binary.encode (Just . Binary.decode) 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 :: 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) === (toInteger128 a128, toInteger128 b128) prop_ToFromPrimArray :: Property prop_ToFromPrimArray = H.withTests 2000 . H.property $ do as <- H.forAll $ Gen.list (fromIntegral <$> (Range.linearBounded :: Range.Range Word8)) genWord128 as === primArrayToList (primArrayFromList as) prop_WriteReadPrimArray :: Property prop_WriteReadPrimArray = H.withTests 2000 . H.property $ do as <- H.forAll $ Gen.list (Range.linear 1 256) genWord128 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 genWord128 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 a128 <- H.forAll genWord128 b128 <- H.forAll genWord128 (ar, br) <- liftIO $ allocaBytes (2 * sizeOf zeroWord128) $ \ ptr -> do writeOffPtr ptr 0 a128 writeOffPtr ptr 1 b128 (,) <$> readOffPtr ptr 0 <*> readOffPtr ptr 1 (ar, br) === (a128, b128) -- ----------------------------------------------------------------------------- mkInteger :: Word64 -> Word64 -> Integer mkInteger a1 a0 = fromIntegral a1 `shiftL` 64 + fromIntegral a0 correctWord128 :: Integer -> Integer correctWord128 i | i >= 0 && i <= maxWord128 = i | otherwise = i .&. maxWord128 where maxWord128 = (1 `shiftL` 128) - 1 toInteger128 :: Word128 -> Integer toInteger128 = toInteger showArithException :: ArithException -> String showArithException = show -- ----------------------------------------------------------------------------- tests :: IO Bool tests = H.checkParallel $$discover wide-word-0.1.5.0/test/Test/Data/WideWord/Word64.hs0000644000000000000000000003244207346545000017666 0ustar0000000000000000{-# 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 qualified Data.Binary as Binary 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_roundtrip_binary :: Property prop_roundtrip_binary = propertyCount $ do w64 <- H.forAll genWord128 H.tripping w64 Binary.encode (Just . Binary.decode) 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 wide-word-0.1.5.0/test/0000755000000000000000000000000007346545000012724 5ustar0000000000000000wide-word-0.1.5.0/test/laws.hs0000644000000000000000000000502307346545000014226 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Data.WideWord import Test.QuickCheck.Arbitrary import Test.QuickCheck.Classes import Data.Semiring hiding ((+),(*)) 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 #endif main :: IO () main = lawsCheckMany allPropsApplied 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 ] instance Arbitrary Word128 where arbitrary = Word128 <$> arbitraryBoundedIntegral <*> arbitraryBoundedIntegral instance Arbitrary Word256 where arbitrary = Word256 <$> arbitraryBoundedIntegral <*> arbitraryBoundedIntegral <*> arbitraryBoundedIntegral <*> arbitraryBoundedIntegral shrink x | x == 0 = [] | x == 1 = [0] | x == 2 = [0,1] | x == 3 = [0,1,2] | otherwise = let y = x `shiftR` 1 z = y + 1 w = div (x * 9) 10 p = div (x * 7) 8 in catMaybes [ if y < x then Just y else Nothing , if z < x then Just z else Nothing , if w < x then Just w else Nothing , if p < x then Just p else Nothing ] instance Arbitrary Int128 where arbitrary = Int128 <$> arbitrary <*> arbitrary -- These are used to make sure that 'Num' behaves properly. instance Semiring Word128 where zero = 0 one = 1 plus = (+) times = (*) instance Semiring Word256 where zero = 0 one = 1 plus = (+) times = (*) instance Semiring Int128 where zero = 0 one = 1 plus = (+) times = (*) -- These are used to make sure that plus is associative instance Semigroup Word128 where (<>) = (+) instance Semigroup Word64 where (<>) = (+) instance Semigroup Word256 where (<>) = (+) instance Semigroup Int128 where (<>) = (+) wide-word-0.1.5.0/test/test.hs0000644000000000000000000000073607346545000014245 0ustar0000000000000000import Control.Monad (unless) 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 ] runTests :: [IO Bool] -> IO () runTests tests = do result <- and <$> sequence tests unless result exitFailure wide-word-0.1.5.0/wide-word.cabal0000644000000000000000000000644707346545000014645 0ustar0000000000000000-- Initial wide-word.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: wide-word version: 0.1.5.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 and unsigned integers with the usual typeclass instances to allow them to be used interchangeably with `Word64`. . The types and operations are coded to be as fast as possible using strictness annotations, `INLINEABLE` pragmas and unboxed values and operations where appropriate. homepage: https://github.com/erikd/wide-word bug-reports: https://github.com/erikd/wide-word/issues/ license: BSD2 license-file: LICENSE author: Erik de Castro Lopo maintainer: erikd@mega-nerd.com copyright: Copyright (c) 2017 Erik de Castro Lopo category: Data build-type: Simple extra-source-files: ChangeLog.md stability: provisional cabal-version: >= 1.10 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 default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs hs-source-dirs: src other-extensions: StrictData exposed-modules: Data.WideWord Data.WideWord.Int128 Data.WideWord.Word64 Data.WideWord.Word128 Data.WideWord.Word256 other-modules: Data.WideWord.Compat build-depends: base >= 4.9 && < 4.18 , binary >= 0.8.3.0 && < 0.9 , deepseq >= 1.4.2.0 && < 1.5 -- Required so that GHC.IntWord64 is available on 32 bit systems , ghc-prim , primitive >= 0.6.4.0 && < 0.8 , hashable >= 1.2 && < 1.5 test-suite test default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -threaded -O2 type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test other-modules: Test.Data.WideWord.Gen Test.Data.WideWord.Int128 Test.Data.WideWord.Word64 Test.Data.WideWord.Word128 build-depends: base , binary , bytestring >= 0.10 , ghc-prim , hedgehog >= 1.0 && < 1.3 , primitive , wide-word test-suite laws default-language: Haskell2010 ghc-options: -Wall type: exitcode-stdio-1.0 main-is: laws.hs hs-source-dirs: test build-depends: base , QuickCheck >= 2.9.2 && < 2.15 , quickcheck-classes >= 0.6.3 && < 0.7.0 , primitive , semirings >= 0.2 && < 0.8 , wide-word