diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for wide-word +## 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. diff --git a/src/Data/WideWord/Int128.hs b/src/Data/WideWord/Int128.hs --- a/src/Data/WideWord/Int128.hs +++ b/src/Data/WideWord/Int128.hs @@ -44,22 +44,22 @@ import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2# , subWordC#, timesWord#, timesWord2#, word2Int#, xor#) import GHC.Enum (predError, succError) +import GHC.Exts ((+#), (*#), State#, Int#, Addr#, ByteArray#, MutableByteArray#) import GHC.Int (Int64 (..)) import GHC.Real ((%)) -import GHC.Word (Word64 (..), byteSwap64) +import GHC.Word (Word64 (..), Word32, byteSwap64) +import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) data Int128 = Int128 { int128Hi64 :: {-# UNPACK #-} !Word64 , int128Lo64 :: {-# UNPACK #-} !Word64 } - deriving Eq - + deriving (Eq) byteSwapInt128 :: Int128 -> Int128 byteSwapInt128 (Int128 a1 a0) = Int128 (byteSwap64 a0) (byteSwap64 a1) - showHexInt128 :: Int128 -> String showHexInt128 (Int128 a1 a0) | a1 == 0 = showHex a0 "" @@ -145,6 +145,28 @@ instance NFData Int128 where rnf (Int128 a1 a0) = rnf a1 `seq` rnf a0 +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. @@ -152,6 +174,10 @@ "fromIntegral :: Int128 -> Int128" fromIntegral = id :: Int128 -> Int128 "fromIntegral :: Word128 -> Int128" fromIntegral = \(Word128 a1 a0) -> Int128 a1 a0 "fromIntegral :: Int128 -> Word128" fromIntegral = \(Int128 a1 a0) -> Word128 a1 a0 + +"fromIntegral :: Word -> Int128" fromIntegral = Int128 0 . (fromIntegral :: Word -> Word64) +"fromIntegral :: Word32 -> Int128" fromIntegral = Int128 0 . (fromIntegral :: Word32 -> Word64) +"fromIntegral :: Word64 -> Int128" fromIntegral = Int128 0 #-} -- ----------------------------------------------------------------------------- @@ -172,20 +198,20 @@ succ128 :: Int128 -> Int128 succ128 (Int128 a1 a0) - | a1 == 0x7fffffffffffffff && a0 == maxBound = succError "Int128" - | otherwise = - case a0 + 1 of - 0 -> Int128 (a1 + 1) 0 - s -> Int128 a1 s + | 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) - | a1 == 0x8000000000000000 && a0 == 0 = predError "Int128" - | otherwise = - case a0 of - 0 -> Int128 (a1 - 1) maxBound - _ -> Int128 a1 (a0 - 1) + | 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) @@ -395,7 +421,7 @@ Int128 n1 n0 -> negate (fromIntegral n1 `shiftL` 64 + fromIntegral n0) -- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. +-- Functions for `Storable` instance. peek128 :: Ptr Int128 -> IO Int128 peek128 ptr = @@ -431,6 +457,67 @@ 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 x = indexByteArray# arr# (2# *# (unInt index1)) + y = indexByteArray# arr# (2# *# i# +# (unInt index0)) + in Int128 x y + +{-# INLINE readByteArray128# #-} +readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Int128 #) +readByteArray128# arr# i# = + \s0 -> case readByteArray# arr# (2# *# (unInt index1)) s0 of + (# s1, x #) -> case readByteArray# arr# (2# *# i# +# (unInt index0)) s1 of + (# s2, y #) -> (# s2, Int128 x y #) + +{-# INLINE writeByteArray128# #-} +writeByteArray128# :: MutableByteArray# s -> Int# -> Int128 -> State# s -> State# s +writeByteArray128# arr# i# (Int128 a b) = + \s0 -> case writeByteArray# arr# (2# *# i# +# (unInt index1)) a s0 of + s1 -> case writeByteArray# arr# (2# *# i# +# (unInt index0)) b s1 of + s2 -> s2 + +{-# INLINE setByteArray128# #-} +setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Int128 -> State# s -> State# s +setByteArray128# = defaultSetByteArray# + +{-# INLINE indexOffAddr128# #-} +indexOffAddr128# :: Addr# -> Int# -> Int128 +indexOffAddr128# addr# i# = + let x = indexOffAddr# addr# (2# *# i# +# (unInt index1)) + y = indexOffAddr# addr# (2# *# i# +# (unInt index0)) + in Int128 x y + +{-# INLINE readOffAddr128# #-} +readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Int128 #) +readOffAddr128# addr# i# = + \s0 -> case readOffAddr# addr# (2# *# i# +# (unInt index1)) s0 of + (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# (unInt index0)) s1 of + (# s2, y #) -> (# s2, Int128 x y #) + +{-# INLINE writeOffAddr128# #-} +writeOffAddr128# :: Addr# -> Int# -> Int128 -> State# s -> State# s +writeOffAddr128# addr# i# (Int128 a b) = + \s0 -> case writeOffAddr# addr# (2# *# i# +# (unInt index1)) a s0 of + s1 -> case writeOffAddr# addr# (2# *# i# +# (unInt index0)) b s1 of + s2 -> s2 + +{-# INLINE setOffAddr128# #-} +setOffAddr128# :: Addr# -> Int# -> Int# -> Int128 -> State# s -> State# s +setOffAddr128# = defaultSetOffAddr# + +-- ----------------------------------------------------------------------------- -- Constants. zeroInt128 :: Int128 @@ -441,6 +528,9 @@ minusOneInt128 :: Int128 minusOneInt128 = Int128 maxBound maxBound + +unInt :: Int -> Int# +unInt (I# i#) = i# index0, index1 :: Int #if WORDS_BIGENDIAN diff --git a/src/Data/WideWord/Word128.hs b/src/Data/WideWord/Word128.hs --- a/src/Data/WideWord/Word128.hs +++ b/src/Data/WideWord/Word128.hs @@ -39,23 +39,24 @@ import GHC.Base (Int (..), and#, int2Word#, minusWord#, not#, or#, plusWord#, plusWord2# , quotRemWord2#, subWordC#, timesWord#, timesWord2#, xor#) import GHC.Enum (predError, succError) +import GHC.Exts ((*#), (+#), Int#, State#, ByteArray#, MutableByteArray#, Addr#) import GHC.Real ((%), divZeroError) -import GHC.Word (Word64 (..), byteSwap64) +import GHC.Word (Word64 (..), Word32, byteSwap64) + import Numeric (showHex) +import Data.Primitive.Types (Prim (..), defaultSetByteArray#, defaultSetOffAddr#) data Word128 = Word128 { word128Hi64 :: {-# UNPACK #-} !Word64 , word128Lo64 :: {-# UNPACK #-} !Word64 } - deriving Eq - + deriving (Eq) byteSwapWord128 :: Word128 -> Word128 byteSwapWord128 (Word128 a1 a0) = Word128 (byteSwap64 a0) (byteSwap64 a1) - showHexWord128 :: Word128 -> String showHexWord128 (Word128 a1 a0) | a1 == 0 = showHex a0 "" @@ -141,22 +142,42 @@ instance NFData Word128 where rnf (Word128 a1 a0) = rnf a1 `seq` rnf a0 +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 - #-} -{-# RULES "fromIntegral :: Int -> Word128" fromIntegral = \(I# i#) -> Word128 (W64# 0##) (W64# (int2Word# i#)) -"fromIntegral :: Word- > Word128" fromIntegral = Word128 0 . fromIntegral -"fromIntegral :: Word32 -> Word128" fromIntegral = Word128 0 . fromIntegral +"fromIntegral :: Word -> Word128" fromIntegral = Word128 0 . (fromIntegral :: Word -> Word64) +"fromIntegral :: Word32 -> Word128" fromIntegral = Word128 0 . (fromIntegral :: Word32 -> Word64) "fromIntegral :: Word64 -> Word128" fromIntegral = Word128 0 -"fromIntegral :: Word128 -> Int" fromIntegral = \(Word128 _ w) -> fromIntegral w -"fromIntegral :: Word128 -> Word" fromIntegral = \(Word128 _ w) -> fromIntegral w -"fromIntegral :: Word128 -> Word32" fromIntegral = \(Word128 _ w) -> fromIntegral w +"fromIntegral :: Word128 -> Int" fromIntegral = \(Word128 _ w) -> fromIntegral w :: Int +"fromIntegral :: Word128 -> Word" fromIntegral = \(Word128 _ w) -> fromIntegral w :: Word +"fromIntegral :: Word128 -> Word32" fromIntegral = \(Word128 _ w) -> fromIntegral w :: Word32 "fromIntegral :: Word128 -> Word64" fromIntegral = \(Word128 _ w) -> w #-} @@ -175,20 +196,20 @@ succ128 :: Word128 -> Word128 succ128 (Word128 a1 a0) - | a1 == maxBound && a0 == maxBound = succError "Word128" - | otherwise = - case a0 + 1 of - 0 -> Word128 (a1 + 1) 0 - s -> Word128 a1 s + | 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) - | a1 == 0 && a0 == 0 = predError "Word128" - | otherwise = - case a0 of - 0 -> Word128 (a1 - 1) maxBound - _ -> Word128 a1 (a0 - 1) + | 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) @@ -414,7 +435,7 @@ toInteger128 (Word128 a1 a0) = fromIntegral a1 `shiftL` 64 + fromIntegral a0 -- ----------------------------------------------------------------------------- --- Functions for `Integral` instance. +-- Functions for `Storable` instance. peek128 :: Ptr Word128 -> IO Word128 peek128 ptr = @@ -435,6 +456,67 @@ pokeElemOff (castPtr ptr) (2 * idx + index1) a1 -- ----------------------------------------------------------------------------- +-- Functions for `Prim` instance. + +{-# INLINE sizeOf128# #-} +sizeOf128# :: Word128 -> Int# +sizeOf128# _ = 2# *# sizeOf# (undefined :: Word64) + +{-# INLINE alignment128# #-} +alignment128# :: Word128 -> Int# +alignment128# _ = 2# *# alignment# (undefined :: Word64) + +{-# INLINE indexByteArray128# #-} +indexByteArray128# :: ByteArray# -> Int# -> Word128 +indexByteArray128# arr# i# = + let x = indexByteArray# arr# (2# *# i# +# (unInt index1)) + y = indexByteArray# arr# (2# *# i# +# (unInt index0)) + in Word128 x y + +{-# INLINE readByteArray128# #-} +readByteArray128# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, Word128 #) +readByteArray128# arr# i# = + \s0 -> case readByteArray# arr# (2# *# i# +# (unInt index1)) s0 of + (# s1, x #) -> case readByteArray# arr# (2# *# i# +# (unInt index0)) s1 of + (# s2, y #) -> (# s2, Word128 x y #) + +{-# INLINE writeByteArray128# #-} +writeByteArray128# :: MutableByteArray# s -> Int# -> Word128 -> State# s -> State# s +writeByteArray128# arr# i# (Word128 a b) = + \s0 -> case writeByteArray# arr# (2# *# i# +# (unInt index1)) a s0 of + s1 -> case writeByteArray# arr# (2# *# i# +# (unInt index0)) b s1 of + s2 -> s2 + +{-# INLINE setByteArray128# #-} +setByteArray128# :: MutableByteArray# s -> Int# -> Int# -> Word128 -> State# s -> State# s +setByteArray128# = defaultSetByteArray# + +{-# INLINE indexOffAddr128# #-} +indexOffAddr128# :: Addr# -> Int# -> Word128 +indexOffAddr128# addr# i# = + let x = indexOffAddr# addr# (2# *# i# +# (unInt index1)) + y = indexOffAddr# addr# (2# *# i# +# (unInt index0)) + in Word128 x y + +{-# INLINE readOffAddr128# #-} +readOffAddr128# :: Addr# -> Int# -> State# s -> (# State# s, Word128 #) +readOffAddr128# addr# i# = + \s0 -> case readOffAddr# addr# (2# *# i# +# (unInt index1)) s0 of + (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# (unInt index0)) s1 of + (# s2, y #) -> (# s2, Word128 x y #) + +{-# INLINE writeOffAddr128# #-} +writeOffAddr128# :: Addr# -> Int# -> Word128 -> State# s -> State# s +writeOffAddr128# addr# i# (Word128 a b) = + \s0 -> case writeOffAddr# addr# (2# *# i# +# (unInt index1)) a s0 of + s1 -> case writeOffAddr# addr# (2# *# i# +# (unInt index0)) b s1 of + s2 -> s2 + +{-# INLINE setOffAddr128# #-} +setOffAddr128# :: Addr# -> Int# -> Int# -> Word128 -> State# s -> State# s +setOffAddr128# = defaultSetOffAddr# + +-- ----------------------------------------------------------------------------- -- Constants. zeroWord128 :: Word128 @@ -442,6 +524,9 @@ 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 diff --git a/test/laws.hs b/test/laws.hs new file mode 100644 --- /dev/null +++ b/test/laws.hs @@ -0,0 +1,61 @@ +{-# 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 + +main :: IO () +main = lawsCheckMany allPropsApplied + +allPropsApplied :: [(String, [Laws])] +allPropsApplied = + [ ("Int128", allLaws (Proxy :: Proxy Int128)) + , ("Word128", allLaws (Proxy :: Proxy Word128)) + ] + +allLaws :: + ( Arbitrary a + , Bounded a + , Enum a + , Eq a + , Integral a + , Ord a + , Read a + , Show a + , Storable a + , Bits a + , FiniteBits a + , Semiring a + ) => Proxy a -> [Laws] +allLaws p = map ($ p) + [ bitsLaws + , boundedEnumLaws + , eqLaws + , integralLaws + , ordLaws + , semiringLaws + , storableLaws + ] + +instance Arbitrary Word128 where + arbitrary = Word128 <$> arbitrary <*> arbitrary + +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 Int128 where + zero = 0 + one = 1 + plus = (+) + times = (*) diff --git a/wide-word.cabal b/wide-word.cabal --- a/wide-word.cabal +++ b/wide-word.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wide-word -version: 0.1.0.7 +version: 0.1.0.8 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 @@ -37,7 +37,7 @@ build-depends: base >= 4.8 && < 5.0 , deepseq >= 1.3 && < 1.5 - , ghc-prim + , primitive >= 0.6.4.0 && < 0.7.0.0 test-suite test default-language: Haskell2010 @@ -55,4 +55,18 @@ , bytestring >= 0.10 , ghc-prim , hedgehog == 0.6.* + , 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 >= 4.8 && < 5.0 + , QuickCheck >= 2.9.2 && < 2.13 + , quickcheck-classes >= 0.4.0 && < 0.7.0 + , semirings >= 0.2 && < 0.3 , wide-word