diff --git a/data-dword.cabal b/data-dword.cabal --- a/data-dword.cabal +++ b/data-dword.cabal @@ -1,5 +1,5 @@ Name: data-dword -Version: 0.1 +Version: 0.2 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one @@ -27,7 +27,7 @@ Library Default-Language: Haskell2010 Build-Depends: - base >= 4.5 && < 5, + base >= 4.6 && < 5, hashable >= 1.1, template-haskell >= 2.8, ghc-prim diff --git a/src/Data/DoubleWord.hs b/src/Data/DoubleWord.hs --- a/src/Data/DoubleWord.hs +++ b/src/Data/DoubleWord.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module provides strict (low and high halves are unpacked) -- signed and unsigned binary word data types of sizes 96, 128, @@ -21,15 +23,23 @@ , Int256(..) ) where +import Data.Data +import GHC.Generics import Data.Word import Data.Int import Data.DoubleWord.Base import Data.DoubleWord.TH mkUnpackedDoubleWord "Word96" ''Word32 "Int96" ''Int32 ''Word64 + [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word128" ''Word64 "Int128" ''Int64 ''Word64 + [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word160" ''Word32 "Int160" ''Int32 ''Word128 + [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word192" ''Word64 "Int192" ''Int64 ''Word128 + [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word224" ''Word96 "Int224" ''Int96 ''Word128 + [''Typeable, ''Data, ''Generic] mkUnpackedDoubleWord "Word256" ''Word128 "Int256" ''Int128 ''Word128 + [''Typeable, ''Data, ''Generic] diff --git a/src/Data/DoubleWord/Base.hs b/src/Data/DoubleWord/Base.hs --- a/src/Data/DoubleWord/Base.hs +++ b/src/Data/DoubleWord/Base.hs @@ -233,7 +233,7 @@ #else unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) where lo = x + y - hi = if lo > x then 1 else 0 + hi = if lo < x then 1 else 0 {-# INLINABLE unwrappedAdd #-} #endif #if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64 @@ -244,16 +244,19 @@ {-# INLINE unwrappedMul #-} #else unwrappedMul x y = hi `seq` lo `seq` (hi, lo) - where xHi = hiWord x - xLo = loWord x - yHi = hiWord y - yLo = loWord y + where xHi = shiftR x 32 + xLo = x .&. 0xFFFFFFFF + yHi = shiftR y 32 + yLo = y .&. 0xFFFFFFFF hi0 = xHi * yHi lo0 = xLo * yLo p1 = xHi * yLo p2 = xLo * yHi - lo = lo0 + shiftL p1 32 + shiftL p2 32 - hi = hi0 + shiftR p1 32 + shiftR p2 32 + hi = hi0 + fromIntegral uHi1 + fromIntegral uHi2 + + shiftR p1 32 + shiftR p2 32 + lo = fromHiAndLo lo' (loWord lo0) + (uHi1, uLo) = unwrappedAdd (loWord p1) (loWord p2) + (uHi2, lo') = unwrappedAdd (hiWord lo0) uLo #endif #if WORD_SIZE_IN_BITS == 64 leadingZeroes w | w .&. 0xFFFFFFFF00000000 == 0 = go32 32 w diff --git a/src/Data/DoubleWord/TH.hs b/src/Data/DoubleWord/TH.hs --- a/src/Data/DoubleWord/TH.hs +++ b/src/Data/DoubleWord/TH.hs @@ -21,8 +21,8 @@ -- the specified low and high halves. The high halves /must/ have -- less or equal bit-length than the lover half. For each data type -- the following instances are declared: 'DoubleWord', 'Eq', 'Ord', --- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Hashable', --- 'Ix', 'Bits', 'BinaryWord'. +-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Read', +-- 'Hashable', 'Ix', 'Bits', 'BinaryWord'. mkDoubleWord ∷ String -- ^ Unsigned variant type name → String -- ^ Unsigned variant constructor name → Strict -- ^ Unsigned variant higher half strictness @@ -33,14 +33,16 @@ → Name -- ^ Signed variant higher half type → Strict -- ^ Lower half strictness → Name -- ^ Lower half type + → [Name] -- ^ List of instances for automatic derivation → Q [Dec] -mkDoubleWord un uc uhs uhn sn sc shs shn ls ln = - (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls (ConT ln) - <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls (ConT ln) +mkDoubleWord un uc uhs uhn sn sc shs shn ls ln ad = + (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls lt ad + <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls lt ad where un' = mkName un uc' = mkName uc sn' = mkName sn sc' = mkName sc + lt = ConT ln -- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for -- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@ @@ -49,18 +51,20 @@ → String -- ^ Signed variant type name → Name -- ^ Signed variant higher half type → Name -- ^ Lower half type + → [Name] -- ^ List of instances for automatic derivation → Q [Dec] -mkUnpackedDoubleWord un uhn sn shn ln = - mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln +mkUnpackedDoubleWord un uhn sn shn ln ad = + mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln ad mkDoubleWord' ∷ Bool → Name → Name → Name → Name → Strict → Type → Strict → Type + → [Name] → Q [Dec] -mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT = (<$> mkRules) $ (++) $ - [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] [] +mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT ad = (<$> mkRules) $ (++) $ + [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] ad , inst ''DoubleWord [tp] [ TySynInstD ''LoWord [tpT] loT , TySynInstD ''HiWord [tpT] hiT @@ -98,7 +102,7 @@ CaseE (appVN 'compare [hi, hi']) [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] , Match (VarP x) (NormalB (VarE x)) [] ] - , inline 'compare ] + , inlinable 'compare ] , inst ''Bounded [tp] {- minBound = W minBound minBound -} [ fun 'minBound $ appWN ['minBound, 'minBound] @@ -114,7 +118,7 @@ [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound]) (appW [appVN 'succ [hi], VarE 'minBound]) (appW [VarE hi, appVN 'succ [lo]]) - , inline 'succ + , inlinable 'succ {- pred (W hi lo) = if lo == minBound then W (pred hi) maxBound else W hi (pred lo) @@ -122,7 +126,7 @@ , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound]) (appW [appVN 'pred [hi], VarE 'maxBound]) (appW [VarE hi, appVN 'pred [lo]]) - , inline 'pred + , inlinable 'pred {- toEnum x | x < 0 = if signed @@ -145,7 +149,6 @@ ] else appV 'error [litS "toEnum: nagative value"]) (appW [VarE 'allZeroes, appVN 'toEnum [x]]) - , inline 'toEnum {- fromEnum (W 0 lo) = fromEnum lo fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo @@ -170,7 +173,6 @@ (NormalB $ appV 'error [litS "fromEnum: out of bounds"]) [] ] - , inline 'fromEnum {- enumFrom x = enumFromTo x maxBound -} , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] , inline 'enumFrom @@ -184,7 +186,7 @@ , VarE y , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound) ] - , inline 'enumFromThen + , inlinable 'enumFromThen {- enumFromTo x y = case y `compare` x of LT → x : down y x @@ -234,7 +236,6 @@ [ValD (VarP next) (NormalB $ appVN '(+) [c, 'lsb]) []] ] - , inlinable 'enumFromTo {- enumFromThenTo x y z = case y `compare` x of LT → if z > x then [] else down (x - y) z x @@ -282,7 +283,6 @@ (ConE '[]) (appVN up [step, to, next]) ]) [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]] - , inlinable 'enumFromThenTo ] , inst ''Num [tp] {- @@ -294,7 +294,7 @@ (appW [appVN 'negate [hi], zeroE]) (appW [ appV 'negate [appVN '(+) ['lsb, hi]] , appVN 'negate [lo] ]) - , inline 'negate + , inlinable 'negate {- abs x = if SIGNED then if x < 0 then negate x else x @@ -305,7 +305,7 @@ then CondE (appVN '(<) [x, 'allZeroes]) (appVN 'negate [x]) (VarE x) else VarE x - , inline 'abs + , if signed then inlinable 'abs else inline 'abs {- signum (W hi lo) = if SIGNED then case hi `compare` 0 of @@ -328,7 +328,7 @@ else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] , appVN '(==) [lo, 'allZeroes] ]) zeroE oneE - , inline 'signum + , inlinable 'signum {- (W hi lo) + (W hi' lo') = W y x where x = lo + lo' @@ -379,13 +379,12 @@ , appV '(+) [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ])] - , inlinable 'fromInteger ] , inst ''Real [tp] {- toRational x = toInteger x % 1 -} [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1] , inline 'toRational ] - , inst ''Integral [tp] + , inst ''Integral [tp] $ {- toInteger (W hi lo) = toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo @@ -811,11 +810,21 @@ , appVN 'signedWord [r] ]))) else fun 'divMod $ VarE 'quotRem - , inline 'divMod - ] + ] ++ + if signed then [] else [inline 'divMod] , inst ''Show [tp] [ fun 'show $ appVN '(.) ['show, 'toInteger] , inline 'show ] + , inst ''Read [tp] + {- + readsPrec x y = fmap (\(q, r) → (fromInteger q, r)) + $ readsPrec x y + -} + [ funXY 'readsPrec $ + appV 'fmap [ LamE [TupP [VarP q, VarP r]] + (TupE [appVN 'fromInteger [q], VarE r]) + , appVN 'readsPrec [x, y] ] + ] , inst ''Hashable [tp] {- hash (W hi lo) = hash hi `combine` hash lo -} [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]] @@ -833,7 +842,7 @@ , funTupZ 'inRange $ appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]] , inline 'inRange ] - , inst ''Bits [tp] + , inst ''Bits [tp] $ {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -} [ fun_ 'bitSize $ appV '(+) @@ -988,7 +997,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] - , inline 'bit + , inlinable 'bit {- setBit (W hi lo) x = if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x) @@ -1001,7 +1010,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] - , inline 'setBit + , inlinable 'setBit {- clearBit (W hi lo) x = if y >= 0 then W (clearBit hi y) lo @@ -1015,7 +1024,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] - , inline 'clearBit + , inlinable 'clearBit {- complementBit (W hi lo) x = if y >= 0 then W (complementBit hi y) lo @@ -1029,7 +1038,7 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] - , inline 'complementBit + , inlinable 'complementBit {- testBit (W hi lo) x = if y >= 0 then testBit hi y else testBit lo x @@ -1042,12 +1051,13 @@ [val y $ appV '(-) [ VarE x , appV 'bitSize [SigE (VarE 'undefined) loT] ]] - , inline 'testBit + , inlinable 'testBit {- popCount (W hi lo) = popCount hi + popCount lo -} , funHiLo 'popCount (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]]) , inline 'popCount - ] + ] ++ + if signed then [inline 'rotateL] else [] , inst ''BinaryWord [tp] [ TySynInstD ''UnsignedWord [tpT] $ ConT $ if signed then otp else tp @@ -1228,7 +1238,8 @@ [ val x $ appVN 'leadingZeroes [hi] , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] ] - , inline 'leadingZeroes + , if signed then inlinable 'leadingZeroes + else inline 'leadingZeroes {- UNSIGNED: trailingZeroes (W hi lo) = @@ -1249,7 +1260,8 @@ [ val x $ appVN 'trailingZeroes [lo] , val y $ appV 'bitSize [SigE (VarE 'undefined) loT] ] - , inline 'trailingZeroes + , if signed then inlinable 'trailingZeroes + else inline 'trailingZeroes {- allZeroes = W allZeroes allZeroes -} , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes] , inline 'allZeroes @@ -1305,16 +1317,16 @@ div1 = mkName "div1" div2 = mkName "div2" addT = mkName "addT" - by = mkName "by" - go = mkName "go" + by = mkName "by_" + go = mkName "go_" c = mkName "c" - next = mkName "next" - step = mkName "step" - to = mkName "to" - down = mkName "down" - up = mkName "up" - hi = mkName "hi" - lo = mkName "lo" + next = mkName "next_" + step = mkName "step_" + to = mkName "to_" + down = mkName "down_" + up = mkName "up_" + hi = mkName "hi_" + lo = mkName "lo_" hi' = mkName "hi'" lo' = mkName "lo'" tpT = ConT tp diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -59,7 +59,7 @@ , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ] mempty { ropt_test_options = - Just (mempty { topt_maximum_generated_tests = Just 1000 }) + Just (mempty { topt_maximum_generated_tests = Just 10000 }) } arbTestGroup name t = diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -7,7 +7,7 @@ import Data.Int import Data.DoubleWord.TH -$(mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32) -$(mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32) -$(mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48) +mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32 [] +mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32 [] +mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48 []