diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-02-11 08:46:03 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2020-06-17 16:22:03 -0400 |
commit | 57db91d8ee501c7cf176c4bb1e2101d3092fd0f6 (patch) | |
tree | de653affe3cf915e557dc44ec233cd29af530ce3 | |
parent | 6cb84c469bf1ab6b03e099f5d100e78800ca09e0 (diff) | |
download | haskell-57db91d8ee501c7cf176c4bb1e2101d3092fd0f6.tar.gz |
Remove integer-simple
integer-simple uses lists of words (`[Word]`) to represent big numbers
instead of ByteArray#:
* it is less efficient than the newer ghc-bignum native backend
* it isn't compatible with the big number representation that is now
shared by all the ghc-bignum backends (based on the one that was
used only in integer-gmp before).
As a consequence, we simply drop integer-simple
-rw-r--r-- | libraries/integer-simple/.gitignore | 3 | ||||
-rw-r--r-- | libraries/integer-simple/GHC/Integer.hs | 44 | ||||
-rw-r--r-- | libraries/integer-simple/GHC/Integer/Logarithms.hs | 43 | ||||
-rw-r--r-- | libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs | 166 | ||||
-rw-r--r-- | libraries/integer-simple/GHC/Integer/Simple/Internals.hs | 23 | ||||
-rw-r--r-- | libraries/integer-simple/GHC/Integer/Type.hs | 986 | ||||
-rw-r--r-- | libraries/integer-simple/LICENSE | 26 | ||||
-rw-r--r-- | libraries/integer-simple/Setup.hs | 6 | ||||
-rw-r--r-- | libraries/integer-simple/integer-simple.cabal | 32 |
9 files changed, 0 insertions, 1329 deletions
diff --git a/libraries/integer-simple/.gitignore b/libraries/integer-simple/.gitignore deleted file mode 100644 index 8f4d26768c..0000000000 --- a/libraries/integer-simple/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -GNUmakefile -dist-install -ghc.mk diff --git a/libraries/integer-simple/GHC/Integer.hs b/libraries/integer-simple/GHC/Integer.hs deleted file mode 100644 index 1f2598c14d..0000000000 --- a/libraries/integer-simple/GHC/Integer.hs +++ /dev/null @@ -1,44 +0,0 @@ - -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Integer --- Copyright : (c) Ian Lynagh 2007-2012 --- License : BSD3 --- --- Maintainer : igloo@earth.li --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- A simple definition of the 'Integer' type. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module GHC.Integer ( - Integer, mkInteger, - smallInteger, wordToInteger, integerToWord, integerToInt, -#if WORD_SIZE_IN_BITS < 64 - integerToWord64, word64ToInteger, - integerToInt64, int64ToInteger, -#endif - plusInteger, minusInteger, timesInteger, negateInteger, - eqInteger, neqInteger, absInteger, signumInteger, - leInteger, gtInteger, ltInteger, geInteger, compareInteger, - eqInteger#, neqInteger#, - leInteger#, gtInteger#, ltInteger#, geInteger#, - divInteger, modInteger, - divModInteger, quotRemInteger, quotInteger, remInteger, - encodeFloatInteger, decodeFloatInteger, floatFromInteger, - encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger, - gcdInteger, lcmInteger, - andInteger, orInteger, xorInteger, complementInteger, - shiftLInteger, shiftRInteger, testBitInteger, - popCountInteger, bitInteger, - hashInteger, - ) where - -import GHC.Integer.Type - diff --git a/libraries/integer-simple/GHC/Integer/Logarithms.hs b/libraries/integer-simple/GHC/Integer/Logarithms.hs deleted file mode 100644 index cfafe14226..0000000000 --- a/libraries/integer-simple/GHC/Integer/Logarithms.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-} -module GHC.Integer.Logarithms - ( integerLogBase# - , integerLog2# - , wordLog2# - ) where - -import GHC.Prim -import GHC.Integer -import qualified GHC.Integer.Logarithms.Internals as I - --- | Calculate the integer logarithm for an arbitrary base. --- The base must be greater than 1, the second argument, the number --- whose logarithm is sought, should be positive, otherwise the --- result is meaningless. --- --- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1) --- --- for @base > 1@ and @m > 0@. -integerLogBase# :: Integer -> Integer -> Int# -integerLogBase# b m = case step b of - (# _, e #) -> e - where - step pw = - if m `ltInteger` pw - then (# m, 0# #) - else case step (pw `timesInteger` pw) of - (# q, e #) -> - if q `ltInteger` pw - then (# q, 2# *# e #) - else (# q `quotInteger` pw, 2# *# e +# 1# #) - --- | Calculate the integer base 2 logarithm of an 'Integer'. --- The calculation is more efficient than for the general case, --- on platforms with 32- or 64-bit words much more efficient. --- --- The argument must be strictly positive, that condition is /not/ checked. -integerLog2# :: Integer -> Int# -integerLog2# = I.integerLog2# - --- | This function calculates the integer base 2 logarithm of a 'Word#'. -wordLog2# :: Word# -> Int# -wordLog2# = I.wordLog2# diff --git a/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs b/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs deleted file mode 100644 index f8f2babe6a..0000000000 --- a/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} -{-# OPTIONS_HADDOCK not-home #-} - -#include "MachDeps.h" - --- (Hopefully) Fast integer logarithms to base 2. --- integerLog2# and wordLog2# are of general usefulness, --- the others are only needed for a fast implementation of --- fromRational. --- Since they are needed in GHC.Float, we must expose this --- module, but it should not show up in the docs. - -module GHC.Integer.Logarithms.Internals - ( integerLog2# - , integerLog2IsPowerOf2# - , wordLog2# - , roundingMode# - ) where - -import GHC.Prim -import GHC.Integer.Type -import GHC.Types - -default () - --- When larger word sizes become common, add support for those, --- it's not hard, just tedious. -#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) - --- We don't know whether the word has 30 bits or 128 or even more, --- so we can't start from the top, although that would be much more --- efficient. -wordLog2# :: Word# -> Int# -wordLog2# w = go 8# w - where - go acc u = case u `uncheckedShiftRL#` 8# of - 0## -> case leadingZeros of - BA ba -> acc -# indexInt8Array# ba (word2Int# u) - v -> go (acc +# 8#) v - -#else - --- This one at least can also be done efficiently. --- wordLog2# 0## = -1# -{-# INLINE wordLog2# #-} -wordLog2# :: Word# -> Int# -wordLog2# w = - case leadingZeros of - BA lz -> - let zeros u = indexInt8Array# lz (word2Int# u) in -#if WORD_SIZE_IN_BITS == 64 - case uncheckedShiftRL# w 56# of - a -> - if isTrue# (a `neWord#` 0##) - then 64# -# zeros a - else - case uncheckedShiftRL# w 48# of - b -> - if isTrue# (b `neWord#` 0##) - then 56# -# zeros b - else - case uncheckedShiftRL# w 40# of - c -> - if isTrue# (c `neWord#` 0##) - then 48# -# zeros c - else - case uncheckedShiftRL# w 32# of - d -> - if isTrue# (d `neWord#` 0##) - then 40# -# zeros d - else -#endif - case uncheckedShiftRL# w 24# of - e -> - if isTrue# (e `neWord#` 0##) - then 32# -# zeros e - else - case uncheckedShiftRL# w 16# of - f -> - if isTrue# (f `neWord#` 0##) - then 24# -# zeros f - else - case uncheckedShiftRL# w 8# of - g -> - if isTrue# (g `neWord#` 0##) - then 16# -# zeros g - else 8# -# zeros w - -#endif - --- Assumption: Integer is strictly positive, --- otherwise return -1# arbitrarily --- Going up in word-sized steps should not be too bad. -integerLog2# :: Integer -> Int# -integerLog2# (Positive digits) = step 0# digits - where - step acc (Some dig None) = acc +# wordLog2# dig - step acc (Some _ digs) = - step (acc +# WORD_SIZE_IN_BITS#) digs - step acc None = acc -- should be impossible, throw error? -integerLog2# _ = negateInt# 1# - --- Again, integer should be strictly positive -integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) -integerLog2IsPowerOf2# (Positive digits) = couldBe 0# digits - where - couldBe acc (Some dig None) = - (# acc +# wordLog2# dig, word2Int# (and# dig (minusWord# dig 1##)) #) - couldBe acc (Some dig digs) = - if isTrue# (eqWord# dig 0##) - then couldBe (acc +# WORD_SIZE_IN_BITS#) digs - else noPower (acc +# WORD_SIZE_IN_BITS#) digs - couldBe acc None = (# acc, 1# #) -- should be impossible, error? - noPower acc (Some dig None) = - (# acc +# wordLog2# dig, 1# #) - noPower acc (Some _ digs) = - noPower (acc +# WORD_SIZE_IN_BITS#) digs - noPower acc None = (# acc, 1# #) -- should be impossible, error? -integerLog2IsPowerOf2# _ = (# negateInt# 1#, 1# #) - --- Assumption: Integer and Int# are strictly positive, Int# is less --- than logBase 2 of Integer, otherwise havoc ensues. --- Used only for the numerator in fromRational when the denominator --- is a power of 2. --- The Int# argument is log2 n minus the number of bits in the mantissa --- of the target type, i.e. the index of the first non-integral bit in --- the quotient. --- --- 0# means round down (towards zero) --- 1# means we have a half-integer, round to even --- 2# means round up (away from zero) --- This function should probably be improved. -roundingMode# :: Integer -> Int# -> Int# -roundingMode# m h = - case oneInteger `shiftLInteger` h of - c -> case m `andInteger` - ((c `plusInteger` c) `minusInteger` oneInteger) of - r -> - if c `ltInteger` r - then 2# - else if c `gtInteger` r - then 0# - else 1# - --- Lookup table -data BA = BA ByteArray# - -leadingZeros :: BA -leadingZeros = - let mkArr s = - case newByteArray# 256# s of - (# s1, mba #) -> - case writeInt8Array# mba 0# 9# s1 of - s2 -> - let fillA lim val idx st = - if isTrue# (idx ==# 256#) - then st - else if isTrue# (idx <# lim) - then case writeInt8Array# mba idx val st of - nx -> fillA lim val (idx +# 1#) nx - else fillA (2# *# lim) (val -# 1#) idx st - in case fillA 2# 8# 1# s2 of - s3 -> case unsafeFreezeByteArray# mba s3 of - (# _, ba #) -> ba - in case mkArr realWorld# of - b -> BA b diff --git a/libraries/integer-simple/GHC/Integer/Simple/Internals.hs b/libraries/integer-simple/GHC/Integer/Simple/Internals.hs deleted file mode 100644 index 50733d4c0e..0000000000 --- a/libraries/integer-simple/GHC/Integer/Simple/Internals.hs +++ /dev/null @@ -1,23 +0,0 @@ - -{-# LANGUAGE NoImplicitPrelude #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Integer.Simple.Internals --- Copyright : (c) Ian Lynagh 2007-2008 --- License : BSD3 --- --- Maintainer : igloo@earth.li --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- A simple definition of the 'Integer' type. --- ------------------------------------------------------------------------------ - -module GHC.Integer.Simple.Internals ( - module GHC.Integer.Type - ) where - -import GHC.Integer.Type - diff --git a/libraries/integer-simple/GHC/Integer/Type.hs b/libraries/integer-simple/GHC/Integer/Type.hs deleted file mode 100644 index ceb4c38324..0000000000 --- a/libraries/integer-simple/GHC/Integer/Type.hs +++ /dev/null @@ -1,986 +0,0 @@ - -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, BangPatterns, UnboxedTuples, - UnliftedFFITypes #-} - --- Commentary of Integer library is located on the wiki: --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/libraries/integer --- --- It gives an in-depth description of implementation details and --- decisions. - ------------------------------------------------------------------------------ --- | --- Module : GHC.Integer.Type --- Copyright : (c) Ian Lynagh 2007-2012 --- License : BSD3 --- --- Maintainer : igloo@earth.li --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- A simple definition of the 'Integer' type. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module GHC.Integer.Type where - -import GHC.Prim -import GHC.Classes -import GHC.Types -import GHC.Tuple () -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - --- | Arbitrary precision integers. In contrast with fixed-size integral types --- such as 'Int', the 'Integer' type represents the entire infinite range of --- integers. -data Integer = Positive !Positive | Negative !Positive | Naught - -------------------------------------------------------------------- --- The hard work is done on positive numbers - --- Least significant bit is first - --- Positive's have the property that they contain at least one Bit, --- and their last Bit is One. -type Positive = Digits -type Positives = List Positive - -data Digits = Some !Digit !Digits - | None -type Digit = Word# - --- XXX Could move [] above us -data List a = Nil | Cons a (List a) - -mkInteger :: Bool -- non-negative? - -> [Int] -- absolute value in 31 bit chunks, least significant first - -- ideally these would be Words rather than Ints, but - -- we don't have Word available at the moment. - -> Integer -mkInteger nonNegative is = let abs = f is - in if nonNegative then abs else negateInteger abs - where f [] = Naught - f (I# i : is') = smallInteger i `orInteger` shiftLInteger (f is') 31# - -errorInteger :: Integer -errorInteger = Positive errorPositive - -errorPositive :: Positive -errorPositive = Some 47## None -- Random number - -{-# NOINLINE smallInteger #-} -smallInteger :: Int# -> Integer -smallInteger i = if isTrue# (i >=# 0#) then wordToInteger (int2Word# i) - else -- XXX is this right for -minBound? - negateInteger (wordToInteger (int2Word# (negateInt# i))) - -{-# NOINLINE wordToInteger #-} -wordToInteger :: Word# -> Integer -wordToInteger w = if isTrue# (w `eqWord#` 0##) - then Naught - else Positive (Some w None) - -{-# NOINLINE integerToWord #-} -integerToWord :: Integer -> Word# -integerToWord (Positive (Some w _)) = w -integerToWord (Negative (Some w _)) = 0## `minusWord#` w --- Must be Naught by the invariant: -integerToWord _ = 0## - -{-# NOINLINE integerToInt #-} -integerToInt :: Integer -> Int# -integerToInt i = word2Int# (integerToWord i) - -#if WORD_SIZE_IN_BITS == 64 --- Nothing -#elif WORD_SIZE_IN_BITS == 32 -{-# NOINLINE integerToWord64 #-} -integerToWord64 :: Integer -> Word64# -integerToWord64 i = int64ToWord64# (integerToInt64 i) - -{-# NOINLINE word64ToInteger #-} -word64ToInteger:: Word64# -> Integer -word64ToInteger w = if isTrue# (w `eqWord64#` wordToWord64# 0##) - then Naught - else Positive (word64ToPositive w) - -{-# NOINLINE integerToInt64 #-} -integerToInt64 :: Integer -> Int64# -integerToInt64 Naught = intToInt64# 0# -integerToInt64 (Positive p) = word64ToInt64# (positiveToWord64 p) -integerToInt64 (Negative p) - = negateInt64# (word64ToInt64# (positiveToWord64 p)) - -{-# NOINLINE int64ToInteger #-} -int64ToInteger :: Int64# -> Integer -int64ToInteger i - = if isTrue# (i `eqInt64#` intToInt64# 0#) - then Naught - else if isTrue# (i `gtInt64#` intToInt64# 0#) - then Positive (word64ToPositive (int64ToWord64# i)) - else Negative (word64ToPositive (int64ToWord64# (negateInt64# i))) -#else -#error WORD_SIZE_IN_BITS not supported -#endif - -oneInteger :: Integer -oneInteger = Positive onePositive - -negativeOneInteger :: Integer -negativeOneInteger = Negative onePositive - -twoToTheThirtytwoInteger :: Integer -twoToTheThirtytwoInteger = Positive twoToTheThirtytwoPositive - -{-# NOINLINE encodeDoubleInteger #-} -encodeDoubleInteger :: Integer -> Int# -> Double# -encodeDoubleInteger (Positive ds0) e0 = f 0.0## ds0 e0 - where f !acc None (!_) = acc - f !acc (Some d ds) !e = f (acc +## encodeDouble# d e) - ds - -- XXX We assume that this adding to e - -- isn't going to overflow - (e +# WORD_SIZE_IN_BITS#) -encodeDoubleInteger (Negative ds) e - = negateDouble# (encodeDoubleInteger (Positive ds) e) -encodeDoubleInteger Naught _ = 0.0## - -foreign import ccall unsafe "__word_encodeDouble" - encodeDouble# :: Word# -> Int# -> Double# - -{-# NOINLINE encodeFloatInteger #-} -encodeFloatInteger :: Integer -> Int# -> Float# -encodeFloatInteger (Positive ds0) e0 = f 0.0# ds0 e0 - where f !acc None (!_) = acc - f !acc (Some d ds) !e = f (acc `plusFloat#` encodeFloat# d e) - ds - -- XXX We assume that this adding to e - -- isn't going to overflow - (e +# WORD_SIZE_IN_BITS#) -encodeFloatInteger (Negative ds) e - = negateFloat# (encodeFloatInteger (Positive ds) e) -encodeFloatInteger Naught _ = 0.0# - -foreign import ccall unsafe "__word_encodeFloat" - encodeFloat# :: Word# -> Int# -> Float# - -{-# NOINLINE decodeFloatInteger #-} -decodeFloatInteger :: Float# -> (# Integer, Int# #) -decodeFloatInteger f = case decodeFloat_Int# f of - (# mant, exp #) -> (# smallInteger mant, exp #) - --- XXX This could be optimised better, by either (word-size dependent) --- using single 64bit value for the mantissa, or doing the multiplication --- by just building the Digits directly -{-# NOINLINE decodeDoubleInteger #-} -decodeDoubleInteger :: Double# -> (# Integer, Int# #) -decodeDoubleInteger d - = case decodeDouble_2Int# d of - (# mantSign, mantHigh, mantLow, exp #) -> - (# (smallInteger mantSign) `timesInteger` - ( (wordToInteger mantHigh `timesInteger` twoToTheThirtytwoInteger) - `plusInteger` wordToInteger mantLow), - exp #) - -{-# NOINLINE doubleFromInteger #-} -doubleFromInteger :: Integer -> Double# -doubleFromInteger Naught = 0.0## -doubleFromInteger (Positive p) = doubleFromPositive p -doubleFromInteger (Negative p) = negateDouble# (doubleFromPositive p) - -{-# NOINLINE floatFromInteger #-} -floatFromInteger :: Integer -> Float# -floatFromInteger Naught = 0.0# -floatFromInteger (Positive p) = floatFromPositive p -floatFromInteger (Negative p) = negateFloat# (floatFromPositive p) - -{-# NOINLINE andInteger #-} -andInteger :: Integer -> Integer -> Integer -Naught `andInteger` (!_) = Naught -(!_) `andInteger` Naught = Naught -Positive x `andInteger` Positive y = digitsToInteger (x `andDigits` y) -{- -To calculate x & -y we need to calculate - x & twosComplement y -The (imaginary) sign bits are 0 and 1, so &ing them give 0, i.e. positive. -Note that - twosComplement y -has infinitely many 1s, but x has a finite number of digits, so andDigits -will return a finite result. --} -Positive x `andInteger` Negative y = let y' = twosComplementPositive y - z = y' `andDigitsOnes` x - in digitsToInteger z -Negative x `andInteger` Positive y = Positive y `andInteger` Negative x -{- -To calculate -x & -y, naively we need to calculate - twosComplement (twosComplement x & twosComplement y) -but - twosComplement x & twosComplement y -has infinitely many 1s, so this won't work. Thus we use de Morgan's law -to get - -x & -y = !(!(-x) | !(-y)) - = !(!(twosComplement x) | !(twosComplement y)) - = !(!(!x + 1) | (!y + 1)) - = !((x - 1) | (y - 1)) -but the result is negative, so we need to take the two's complement of -this in order to get the magnitude of the result. - twosComplement !((x - 1) | (y - 1)) - = !(!((x - 1) | (y - 1))) + 1 - = ((x - 1) | (y - 1)) + 1 --} --- We don't know that x and y are /strictly/ greater than 1, but --- minusPositive gives us the required answer anyway. -Negative x `andInteger` Negative y = let x' = x `minusPositive` onePositive - y' = y `minusPositive` onePositive - z = x' `orDigits` y' - -- XXX Cheating the precondition: - z' = succPositive z - in digitsToNegativeInteger z' - -{-# NOINLINE orInteger #-} -orInteger :: Integer -> Integer -> Integer -Naught `orInteger` (!i) = i -(!i) `orInteger` Naught = i -Positive x `orInteger` Positive y = Positive (x `orDigits` y) -{- -x | -y = - (twosComplement (x | twosComplement y)) - = - (twosComplement !(!x & !(twosComplement y))) - = - (twosComplement !(!x & !(!y + 1))) - = - (twosComplement !(!x & (y - 1))) - = - ((!x & (y - 1)) + 1) --} -Positive x `orInteger` Negative y = let x' = flipBits x - y' = y `minusPositive` onePositive - z = x' `andDigitsOnes` y' - z' = succPositive z - in digitsToNegativeInteger z' -Negative x `orInteger` Positive y = Positive y `orInteger` Negative x -{- --x | -y = - (twosComplement (twosComplement x | twosComplement y)) - = - (twosComplement !(!(twosComplement x) & !(twosComplement y))) - = - (twosComplement !(!(!x + 1) & !(!y + 1))) - = - (twosComplement !((x - 1) & (y - 1))) - = - (((x - 1) & (y - 1)) + 1) --} -Negative x `orInteger` Negative y = let x' = x `minusPositive` onePositive - y' = y `minusPositive` onePositive - z = x' `andDigits` y' - z' = succPositive z - in digitsToNegativeInteger z' - -{-# NOINLINE xorInteger #-} -xorInteger :: Integer -> Integer -> Integer -Naught `xorInteger` (!i) = i -(!i) `xorInteger` Naught = i -Positive x `xorInteger` Positive y = digitsToInteger (x `xorDigits` y) -{- -x ^ -y = - (twosComplement (x ^ twosComplement y)) - = - (twosComplement !(x ^ !(twosComplement y))) - = - (twosComplement !(x ^ !(!y + 1))) - = - (twosComplement !(x ^ (y - 1))) - = - ((x ^ (y - 1)) + 1) --} -Positive x `xorInteger` Negative y = let y' = y `minusPositive` onePositive - z = x `xorDigits` y' - z' = succPositive z - in digitsToNegativeInteger z' -Negative x `xorInteger` Positive y = Positive y `xorInteger` Negative x -{- --x ^ -y = twosComplement x ^ twosComplement y - = (!x + 1) ^ (!y + 1) - = (!x + 1) ^ (!y + 1) - = !(!x + 1) ^ !(!y + 1) - = (x - 1) ^ (y - 1) --} -Negative x `xorInteger` Negative y = let x' = x `minusPositive` onePositive - y' = y `minusPositive` onePositive - z = x' `xorDigits` y' - in digitsToInteger z - -{-# NOINLINE complementInteger #-} -complementInteger :: Integer -> Integer -complementInteger x = negativeOneInteger `minusInteger` x - -{-# NOINLINE shiftLInteger #-} -shiftLInteger :: Integer -> Int# -> Integer -shiftLInteger (Positive p) i = Positive (shiftLPositive p i) -shiftLInteger (Negative n) i = Negative (shiftLPositive n i) -shiftLInteger Naught _ = Naught - -{-# NOINLINE shiftRInteger #-} -shiftRInteger :: Integer -> Int# -> Integer -shiftRInteger (Positive p) i = shiftRPositive p i -shiftRInteger j@(Negative _) i - = complementInteger (shiftRInteger (complementInteger j) i) -shiftRInteger Naught _ = Naught - -{-# NOINLINE popCountInteger #-} -popCountInteger :: Integer -> Int# -popCountInteger (Positive p) = popCountPositive p -popCountInteger Naught = 0# -popCountInteger (Negative n) = negateInt# (popCountPositive n) - -popCountPositive :: Positive -> Int# -popCountPositive p = word2Int# (go 0## p) - where - go :: Word# -> Positive -> Word# - go acc# None = acc# - go acc# (Some d ds) = go (popCnt# d `plusWord#` acc#) ds - -{-# NOINLINE bitInteger #-} --- | 'Integer' for which only /n/-th bit is set. Undefined behaviour --- for negative /n/ values. -bitInteger :: Int# -> Integer -bitInteger i# = if isTrue# (i# <# 0#) - then Naught - else Positive (bitPositive i#) - --- Assumes 0 <= i -bitPositive :: Int# -> Positive -bitPositive i# - = if isTrue# (i# >=# WORD_SIZE_IN_BITS#) - then Some 0## (bitPositive (i# -# WORD_SIZE_IN_BITS#)) - else Some (uncheckedShiftL# 1## i#) None - -{-# NOINLINE testBitInteger #-} -testBitInteger :: Integer -> Int# -> Bool -testBitInteger (!_) i# | isTrue# (i# <# 0#) = False -testBitInteger Naught _ = False -testBitInteger (Positive p) i# = isTrue# (testBitPositive p i#) - where - -- Straightforward decrement of 'j#' by the word size stopping when - -- 'j#' is less than the word size or the number runs out. - testBitPositive :: Positive -> Int# -> Int# - testBitPositive None _ = 0# - testBitPositive (Some w# ws) j# - = if isTrue# (j# >=# WORD_SIZE_IN_BITS#) - then testBitPositive ws (j# -# WORD_SIZE_IN_BITS#) - else neWord# (uncheckedShiftL# 1## j# `and#` w#) 0## -testBitInteger (Negative n) i# = isTrue# (testBitNegative n i#) - where - -- For negative numbers, we want to inspect the correct bit of the two's - -- complement. Like for positive numbers, we walk down the words until - -- 'j#' is less than the word size (or the number runs out). - testBitNegative :: Positive -> Int# -> Int# - testBitNegative (Some 0## ws) j# - -- If the number starts (on the low end) with a bunch of '0##' and 'j#' - -- falls in those, we know that @n - 1@ would have flipped all those - -- bits, so @!(n - 1) & i@ is false. - = if isTrue# (j# >=# WORD_SIZE_IN_BITS#) - then testBitNegative ws (j# -# WORD_SIZE_IN_BITS#) - else 1# - testBitNegative (Some w# ws) j# - -- Yet, as soon as we find something that isn't a '0##', we can subtract - -- and forget about the 1 altogether! - = testBitNegativeMinus1 (Some (w# `minusWord#` 1##) ws) j# - testBitNegative None _ = 0# -- XXX Can't happen due to Positive's invariant - - testBitNegativeMinus1 :: Positive -> Int# -> Int# - testBitNegativeMinus1 None _ = 1# - testBitNegativeMinus1 (Some w# ws) j# - = if isTrue# (j# >=# WORD_SIZE_IN_BITS#) - then testBitNegativeMinus1 ws (j# -# WORD_SIZE_IN_BITS#) - else neWord# (uncheckedShiftL# 1## j# `and#` not# w#) 0## - -twosComplementPositive :: Positive -> DigitsOnes -twosComplementPositive p = flipBits (p `minusPositive` onePositive) - -flipBits :: Digits -> DigitsOnes -flipBits ds = DigitsOnes (flipBitsDigits ds) - -flipBitsDigits :: Digits -> Digits -flipBitsDigits None = None -flipBitsDigits (Some w ws) = Some (not# w) (flipBitsDigits ws) - -{-# NOINLINE negateInteger #-} -negateInteger :: Integer -> Integer -negateInteger (Positive p) = Negative p -negateInteger (Negative p) = Positive p -negateInteger Naught = Naught - --- Note [Avoid patError] -{-# NOINLINE plusInteger #-} -plusInteger :: Integer -> Integer -> Integer -Positive p1 `plusInteger` Positive p2 = Positive (p1 `plusPositive` p2) -Negative p1 `plusInteger` Negative p2 = Negative (p1 `plusPositive` p2) -Positive p1 `plusInteger` Negative p2 - = case p1 `comparePositive` p2 of - GT -> Positive (p1 `minusPositive` p2) - EQ -> Naught - LT -> Negative (p2 `minusPositive` p1) -Negative p1 `plusInteger` Positive p2 - = Positive p2 `plusInteger` Negative p1 -Naught `plusInteger` Naught = Naught -Naught `plusInteger` i@(Positive _) = i -Naught `plusInteger` i@(Negative _) = i -i@(Positive _) `plusInteger` Naught = i -i@(Negative _) `plusInteger` Naught = i - -{-# NOINLINE minusInteger #-} -minusInteger :: Integer -> Integer -> Integer -i1 `minusInteger` i2 = i1 `plusInteger` negateInteger i2 - -{-# NOINLINE timesInteger #-} -timesInteger :: Integer -> Integer -> Integer -Positive p1 `timesInteger` Positive p2 = Positive (p1 `timesPositive` p2) -Negative p1 `timesInteger` Negative p2 = Positive (p1 `timesPositive` p2) -Positive p1 `timesInteger` Negative p2 = Negative (p1 `timesPositive` p2) -Negative p1 `timesInteger` Positive p2 = Negative (p1 `timesPositive` p2) -(!_) `timesInteger` (!_) = Naught - -{-# NOINLINE divModInteger #-} -divModInteger :: Integer -> Integer -> (# Integer, Integer #) -n `divModInteger` d = - case n `quotRemInteger` d of - (# q, r #) -> - if signumInteger r `eqInteger` - negateInteger (signumInteger d) - then (# q `minusInteger` oneInteger, r `plusInteger` d #) - else (# q, r #) - -{-# NOINLINE divInteger #-} -divInteger :: Integer -> Integer -> Integer -n `divInteger` d = quotient - where (# quotient, _ #) = n `divModInteger` d - -{-# NOINLINE modInteger #-} -modInteger :: Integer -> Integer -> Integer -n `modInteger` d = modulus - where (# _, modulus #) = n `divModInteger` d - -{-# NOINLINE quotRemInteger #-} -quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) -Naught `quotRemInteger` (!_) = (# Naught, Naught #) -(!_) `quotRemInteger` Naught - = (# errorInteger, errorInteger #) -- XXX Can't happen --- XXX _ `quotRemInteger` Naught = error "Division by zero" -Positive p1 `quotRemInteger` Positive p2 = p1 `quotRemPositive` p2 -Negative p1 `quotRemInteger` Positive p2 = case p1 `quotRemPositive` p2 of - (# q, r #) -> - (# negateInteger q, - negateInteger r #) -Positive p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of - (# q, r #) -> - (# negateInteger q, r #) -Negative p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of - (# q, r #) -> - (# q, negateInteger r #) - -{-# NOINLINE quotInteger #-} -quotInteger :: Integer -> Integer -> Integer -x `quotInteger` y = case x `quotRemInteger` y of - (# q, _ #) -> q - -{-# NOINLINE remInteger #-} -remInteger :: Integer -> Integer -> Integer -x `remInteger` y = case x `quotRemInteger` y of - (# _, r #) -> r - -{-# NOINLINE gcdInteger #-} -gcdInteger :: Integer -> Integer -> Integer -gcdInteger (Positive a) (Positive b) = Positive (gcdPositive a b) -gcdInteger (Positive a) (Negative b) = Positive (gcdPositive a b) -gcdInteger (Negative a) (Positive b) = Positive (gcdPositive a b) -gcdInteger (Negative a) (Negative b) = Positive (gcdPositive a b) -gcdInteger Naught b = absInteger b -gcdInteger a Naught = absInteger a - -gcdPositive :: Positive -> Positive -> Positive -gcdPositive p1 p2 = case p1 `quotRemPositive` p2 of - (# _, Positive r #) -> gcdPositive p2 r - (# _, Naught #) -> p2 - (# _, Negative _ #) -> errorPositive -- XXX Can't happen - - -{-# NOINLINE lcmInteger #-} -lcmInteger :: Integer -> Integer -> Integer -lcmInteger (Positive a) (Positive b) = Positive (lcmPositive a b) -lcmInteger (Positive a) (Negative b) = Positive (lcmPositive a b) -lcmInteger (Negative a) (Positive b) = Positive (lcmPositive a b) -lcmInteger (Negative a) (Negative b) = Positive (lcmPositive a b) -lcmInteger Naught _ = Naught -lcmInteger _ Naught = Naught - -lcmPositive :: Positive -> Positive -> Positive -lcmPositive p1 p2 = case p1 `quotRemPositive` (p1 `gcdPositive` p2) of - (# Positive q, _ #) -> q `timesPositive` p2 - (# _, _ #) -> errorPositive -- XXX Can't happen - - -{-# NOINLINE compareInteger #-} -compareInteger :: Integer -> Integer -> Ordering -Positive x `compareInteger` Positive y = x `comparePositive` y -Positive _ `compareInteger` (!_) = GT -Naught `compareInteger` Naught = EQ -Naught `compareInteger` Negative _ = GT -Negative x `compareInteger` Negative y = y `comparePositive` x -(!_) `compareInteger` (!_) = LT - -{-# NOINLINE eqInteger# #-} -eqInteger# :: Integer -> Integer -> Int# -x `eqInteger#` y = case x `compareInteger` y of - EQ -> 1# - _ -> 0# - -{-# NOINLINE neqInteger# #-} -neqInteger# :: Integer -> Integer -> Int# -x `neqInteger#` y = case x `compareInteger` y of - EQ -> 0# - _ -> 1# - -{-# INLINE eqInteger #-} -{-# INLINE neqInteger #-} -eqInteger, neqInteger :: Integer -> Integer -> Bool -eqInteger a b = isTrue# (a `eqInteger#` b) -neqInteger a b = isTrue# (a `neqInteger#` b) - -instance Eq Integer where - (==) = eqInteger - (/=) = neqInteger - -{-# NOINLINE ltInteger# #-} -ltInteger# :: Integer -> Integer -> Int# -x `ltInteger#` y = case x `compareInteger` y of - LT -> 1# - _ -> 0# - -{-# NOINLINE gtInteger# #-} -gtInteger# :: Integer -> Integer -> Int# -x `gtInteger#` y = case x `compareInteger` y of - GT -> 1# - _ -> 0# - -{-# NOINLINE leInteger# #-} -leInteger# :: Integer -> Integer -> Int# -x `leInteger#` y = case x `compareInteger` y of - GT -> 0# - _ -> 1# - -{-# NOINLINE geInteger# #-} -geInteger# :: Integer -> Integer -> Int# -x `geInteger#` y = case x `compareInteger` y of - LT -> 0# - _ -> 1# - -{-# INLINE leInteger #-} -{-# INLINE ltInteger #-} -{-# INLINE geInteger #-} -{-# INLINE gtInteger #-} -leInteger, gtInteger, ltInteger, geInteger :: Integer -> Integer -> Bool -leInteger a b = isTrue# (a `leInteger#` b) -gtInteger a b = isTrue# (a `gtInteger#` b) -ltInteger a b = isTrue# (a `ltInteger#` b) -geInteger a b = isTrue# (a `geInteger#` b) - -instance Ord Integer where - (<=) = leInteger - (>) = gtInteger - (<) = ltInteger - (>=) = geInteger - compare = compareInteger - -{-# NOINLINE absInteger #-} -absInteger :: Integer -> Integer -absInteger (Negative x) = Positive x -absInteger x = x - -{-# NOINLINE signumInteger #-} -signumInteger :: Integer -> Integer -signumInteger (Negative _) = negativeOneInteger -signumInteger Naught = Naught -signumInteger (Positive _) = oneInteger - -{-# NOINLINE hashInteger #-} -hashInteger :: Integer -> Int# -hashInteger = integerToInt - -------------------------------------------------------------------- --- The hard work is done on positive numbers - -onePositive :: Positive -onePositive = Some 1## None - -halfBoundUp, fullBound :: () -> Digit -lowHalfMask :: () -> Digit -highHalfShift :: () -> Int# -twoToTheThirtytwoPositive :: Positive -#if WORD_SIZE_IN_BITS == 64 -halfBoundUp () = 0x8000000000000000## -fullBound () = 0xFFFFFFFFFFFFFFFF## -lowHalfMask () = 0xFFFFFFFF## -highHalfShift () = 32# -twoToTheThirtytwoPositive = Some 0x100000000## None -#elif WORD_SIZE_IN_BITS == 32 -halfBoundUp () = 0x80000000## -fullBound () = 0xFFFFFFFF## -lowHalfMask () = 0xFFFF## -highHalfShift () = 16# -twoToTheThirtytwoPositive = Some 0## (Some 1## None) -#else -#error Unhandled WORD_SIZE_IN_BITS -#endif - -digitsMaybeZeroToInteger :: Digits -> Integer -digitsMaybeZeroToInteger None = Naught -digitsMaybeZeroToInteger ds = Positive ds - -digitsToInteger :: Digits -> Integer -digitsToInteger ds = case removeZeroTails ds of - None -> Naught - ds' -> Positive ds' - -digitsToNegativeInteger :: Digits -> Integer -digitsToNegativeInteger ds = case removeZeroTails ds of - None -> Naught - ds' -> Negative ds' - -removeZeroTails :: Digits -> Digits -removeZeroTails (Some w ds) = if isTrue# (w `eqWord#` 0##) - then case removeZeroTails ds of - None -> None - ds' -> Some w ds' - else Some w (removeZeroTails ds) -removeZeroTails None = None - -#if WORD_SIZE_IN_BITS < 64 -word64ToPositive :: Word64# -> Positive -word64ToPositive w - = if isTrue# (w `eqWord64#` wordToWord64# 0##) - then None - else Some (word64ToWord# w) (word64ToPositive (w `uncheckedShiftRL64#` 32#)) - -positiveToWord64 :: Positive -> Word64# -positiveToWord64 None = wordToWord64# 0## -- XXX Can't happen -positiveToWord64 (Some w None) = wordToWord64# w -positiveToWord64 (Some low (Some high _)) - = wordToWord64# low `or64#` (wordToWord64# high `uncheckedShiftL64#` 32#) -#endif - --- Note [Avoid patError] -comparePositive :: Positive -> Positive -> Ordering -Some x xs `comparePositive` Some y ys = case xs `comparePositive` ys of - EQ -> if isTrue# (x `ltWord#` y) then LT - else if isTrue# (x `gtWord#` y) then GT - else EQ - res -> res -None `comparePositive` None = EQ -(Some {}) `comparePositive` None = GT -None `comparePositive` (Some {}) = LT - -plusPositive :: Positive -> Positive -> Positive -plusPositive x0 y0 = addWithCarry 0## x0 y0 - where -- digit `elem` [0, 1] - -- Note [Avoid patError] - addWithCarry :: Digit -> Positive -> Positive -> Positive - addWithCarry c None None = addOnCarry c None - addWithCarry c xs@(Some {}) None = addOnCarry c xs - addWithCarry c None ys@(Some {}) = addOnCarry c ys - addWithCarry c xs@(Some x xs') ys@(Some y ys') - = if isTrue# (x `ltWord#` y) then addWithCarry c ys xs - -- Now x >= y - else if isTrue# (y `geWord#` halfBoundUp ()) - -- So they are both at least halfBoundUp, so we subtract - -- halfBoundUp from each and thus carry 1 - then case x `minusWord#` halfBoundUp () of - x' -> - case y `minusWord#` halfBoundUp () of - y' -> - case x' `plusWord#` y' `plusWord#` c of - this -> - Some this withCarry - else if isTrue# (x `geWord#` halfBoundUp ()) - then case x `minusWord#` halfBoundUp () of - x' -> - case x' `plusWord#` y `plusWord#` c of - z -> - -- We've taken off halfBoundUp, so now we need to - -- add it back on - if isTrue# (z `ltWord#` halfBoundUp ()) - then Some (z `plusWord#` halfBoundUp ()) withoutCarry - else Some (z `minusWord#` halfBoundUp ()) withCarry - else Some (x `plusWord#` y `plusWord#` c) withoutCarry - where withCarry = addWithCarry 1## xs' ys' - withoutCarry = addWithCarry 0## xs' ys' - - -- digit `elem` [0, 1] - addOnCarry :: Digit -> Positive -> Positive - addOnCarry (!c) (!ws) = if isTrue# (c `eqWord#` 0##) - then ws - else succPositive ws - --- digit `elem` [0, 1] -succPositive :: Positive -> Positive -succPositive None = Some 1## None -succPositive (Some w ws) = if isTrue# (w `eqWord#` fullBound ()) - then Some 0## (succPositive ws) - else Some (w `plusWord#` 1##) ws - --- Requires x > y --- In recursive calls, x >= y and x == y => result is None --- Note [Avoid patError] -minusPositive :: Positive -> Positive -> Positive -Some x xs `minusPositive` Some y ys - = if isTrue# (x `eqWord#` y) - then case xs `minusPositive` ys of - None -> None - s -> Some 0## s - else if isTrue# (x `gtWord#` y) then - Some (x `minusWord#` y) (xs `minusPositive` ys) - else case (fullBound () `minusWord#` y) `plusWord#` 1## of - z -> -- z = 2^n - y, calculated without overflow - case z `plusWord#` x of - z' -> -- z = 2^n + (x - y), calculated without overflow - Some z' ((xs `minusPositive` ys) `minusPositive` onePositive) -xs@(Some {}) `minusPositive` None = xs -None `minusPositive` None = None -None `minusPositive` (Some {}) = errorPositive -- XXX Can't happen --- XXX None `minusPositive` _ = error "minusPositive: Requirement x > y not met" - --- Note [Avoid patError] -timesPositive :: Positive -> Positive -> Positive --- XXX None's can't happen here: -None `timesPositive` None = errorPositive -None `timesPositive` (Some {}) = errorPositive -(Some {}) `timesPositive` None = errorPositive --- x and y are the last digits in Positive numbers, so are not 0: -xs@(Some x xs') `timesPositive` ys@(Some y ys') - = case xs' of - None -> - case ys' of - None -> - x `timesDigit` y - Some {} -> - ys `timesPositive` xs - Some {} -> - case ys' of - None -> - -- y is the last digit in a Positive number, so is not 0. - let zs = Some 0## (xs' `timesPositive` ys) - in -- We could actually skip this test, and everything would - -- turn out OK. We already play tricks like that in timesPositive. - if isTrue# (x `eqWord#` 0##) - then zs - else (x `timesDigit` y) `plusPositive` zs - Some {} -> - (Some x None `timesPositive` ys) `plusPositive` - Some 0## (xs' `timesPositive` ys) - -{- --- Requires arguments /= 0 -Suppose we have 2n bits in a Word. Then - x = 2^n xh + xl - y = 2^n yh + yl - x * y = (2^n xh + xl) * (2^n yh + yl) - = 2^(2n) (xh yh) - + 2^n (xh yl) - + 2^n (xl yh) - + (xl yl) - ~~~~~~~ - all fit in 2n bits --} -timesDigit :: Digit -> Digit -> Positive -timesDigit (!x) (!y) - = case splitHalves x of - (# xh, xl #) -> - case splitHalves y of - (# yh, yl #) -> - case xh `timesWord#` yh of - xhyh -> - case splitHalves (xh `timesWord#` yl) of - (# xhylh, xhyll #) -> - case xhyll `uncheckedShiftL#` highHalfShift () of - xhyll' -> - case splitHalves (xl `timesWord#` yh) of - (# xlyhh, xlyhl #) -> - case xlyhl `uncheckedShiftL#` highHalfShift () of - xlyhl' -> - case xl `timesWord#` yl of - xlyl -> - -- Add up all the high word results. As the result fits in - -- 4n bits this can't overflow. - case xhyh `plusWord#` xhylh `plusWord#` xlyhh of - high -> - -- low: xhyll<<n + xlyhl<<n + xlyl - -- From this point we might make (Some 0 None), but we know - -- that the final result will be positive and the addition - -- will work out OK, so everything will work out in the end. - -- One thing we do need to be careful of is avoiding returning - -- Some 0 (Some 0 None) + Some n None, as this will result in - -- Some n (Some 0 None) instead of Some n None. - let low = Some xhyll' None `plusPositive` - Some xlyhl' None `plusPositive` - Some xlyl None - in if isTrue# (high `eqWord#` 0##) - then low - else Some 0## (Some high None) `plusPositive` low - -splitHalves :: Digit -> (# {- High -} Digit, {- Low -} Digit #) -splitHalves (!x) = (# x `uncheckedShiftRL#` highHalfShift (), - x `and#` lowHalfMask () #) - --- Assumes 0 <= i -shiftLPositive :: Positive -> Int# -> Positive -shiftLPositive p i - = if isTrue# (i >=# WORD_SIZE_IN_BITS#) - then shiftLPositive (Some 0## p) (i -# WORD_SIZE_IN_BITS#) - else smallShiftLPositive p i - --- Assumes 0 <= i < WORD_SIZE_IN_BITS# -smallShiftLPositive :: Positive -> Int# -> Positive -smallShiftLPositive (!p) 0# = p -smallShiftLPositive (!p) (!i) = - case WORD_SIZE_IN_BITS# -# i of - j -> let f carry None = if isTrue# (carry `eqWord#` 0##) - then None - else Some carry None - f carry (Some w ws) = case w `uncheckedShiftRL#` j of - carry' -> - case w `uncheckedShiftL#` i of - me -> - Some (me `or#` carry) (f carry' ws) - in f 0## p - --- Assumes 0 <= i -shiftRPositive :: Positive -> Int# -> Integer -shiftRPositive None _ = Naught -shiftRPositive p@(Some _ q) i - = if isTrue# (i >=# WORD_SIZE_IN_BITS#) - then shiftRPositive q (i -# WORD_SIZE_IN_BITS#) - else smallShiftRPositive p i - --- Assumes 0 <= i < WORD_SIZE_IN_BITS# -smallShiftRPositive :: Positive -> Int# -> Integer -smallShiftRPositive (!p) (!i) = - if isTrue# (i ==# 0#) - then Positive p - else case smallShiftLPositive p (WORD_SIZE_IN_BITS# -# i) of - Some _ p'@(Some _ _) -> Positive p' - _ -> Naught - --- Long division -quotRemPositive :: Positive -> Positive -> (# Integer, Integer #) -(!xs) `quotRemPositive` (!ys) - = case f xs of - (# d, m #) -> (# digitsMaybeZeroToInteger d, - digitsMaybeZeroToInteger m #) - where - subtractors :: Positives - subtractors = mkSubtractors (WORD_SIZE_IN_BITS# -# 1#) - - mkSubtractors (!n) = if isTrue# (n ==# 0#) - then Cons ys Nil - else Cons (ys `smallShiftLPositive` n) - (mkSubtractors (n -# 1#)) - - -- The main function. Go the end of xs, then walk - -- back trying to divide the number we accumulate by ys. - f :: Positive -> (# Digits, Digits #) - f None = (# None, None #) - f (Some z zs) - = case f zs of - (# ds, m #) -> - let -- We need to avoid making (Some Zero None) here - m' = some z m - in case g 0## subtractors m' of - (# d, m'' #) -> - (# some d ds, m'' #) - - g :: Digit -> Positives -> Digits -> (# Digit, Digits #) - g (!d) Nil (!m) = (# d, m #) - g (!d) (Cons sub subs) (!m) - = case d `uncheckedShiftL#` 1# of - d' -> - case m `comparePositive` sub of - LT -> g d' subs m - _ -> g (d' `plusWord#` 1##) - subs - (m `minusPositive` sub) - -some :: Digit -> Digits -> Digits -some (!w) None = if isTrue# (w `eqWord#` 0##) then None else Some w None -some (!w) (!ws) = Some w ws - --- Note [Avoid patError] -andDigits :: Digits -> Digits -> Digits -andDigits None None = None -andDigits (Some {}) None = None -andDigits None (Some {}) = None -andDigits (Some w1 ws1) (Some w2 ws2) = Some (w1 `and#` w2) (andDigits ws1 ws2) - --- DigitsOnes is just like Digits, only None is really 0xFFFFFFF..., --- i.e. ones off to infinity. This makes sense when we want to "and" --- a DigitOnes with a Digits, as the latter will bound the size of the --- result. -newtype DigitsOnes = DigitsOnes Digits - --- Note [Avoid patError] -andDigitsOnes :: DigitsOnes -> Digits -> Digits -andDigitsOnes (DigitsOnes None) None = None -andDigitsOnes (DigitsOnes None) ws2@(Some {}) = ws2 -andDigitsOnes (DigitsOnes (Some {})) None = None -andDigitsOnes (DigitsOnes (Some w1 ws1)) (Some w2 ws2) - = Some (w1 `and#` w2) (andDigitsOnes (DigitsOnes ws1) ws2) - --- Note [Avoid patError] -orDigits :: Digits -> Digits -> Digits -orDigits None None = None -orDigits None ds@(Some {}) = ds -orDigits ds@(Some {}) None = ds -orDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `or#` w2) (orDigits ds1 ds2) - --- Note [Avoid patError] -xorDigits :: Digits -> Digits -> Digits -xorDigits None None = None -xorDigits None ds@(Some {}) = ds -xorDigits ds@(Some {}) None = ds -xorDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `xor#` w2) (xorDigits ds1 ds2) - --- XXX We'd really like word2Double# for this -doubleFromPositive :: Positive -> Double# -doubleFromPositive None = 0.0## -doubleFromPositive (Some w ds) - = case splitHalves w of - (# h, l #) -> - (doubleFromPositive ds *## (2.0## **## WORD_SIZE_IN_BITS_FLOAT##)) - +## (int2Double# (word2Int# h) *## - (2.0## **## int2Double# (highHalfShift ()))) - +## int2Double# (word2Int# l) - --- XXX We'd really like word2Float# for this -floatFromPositive :: Positive -> Float# -floatFromPositive None = 0.0# -floatFromPositive (Some w ds) - = case splitHalves w of - (# h, l #) -> - (floatFromPositive ds `timesFloat#` (2.0# `powerFloat#` WORD_SIZE_IN_BITS_FLOAT#)) - `plusFloat#` (int2Float# (word2Int# h) `timesFloat#` - (2.0# `powerFloat#` int2Float# (highHalfShift ()))) - `plusFloat#` int2Float# (word2Int# l) - -{- -Note [Avoid patError] - -If we use the natural set of definitions for functions, e.g.: - - orDigits None ds = ds - orDigits ds None = ds - orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ... - -then GHC may not be smart enough (especially when compiling with -O0) -to see that all the cases are handled, and will thus insert calls to -base:Control.Exception.Base.patError. But we are below base in the -package hierarchy, so this causes build failure! - -We therefore help GHC out, by being more explicit about what all the -cases are: - - orDigits None None = None - orDigits None ds@(Some {}) = ds - orDigits ds@(Some {}) None = ds - orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ... --} - diff --git a/libraries/integer-simple/LICENSE b/libraries/integer-simple/LICENSE deleted file mode 100644 index 7b87ed8855..0000000000 --- a/libraries/integer-simple/LICENSE +++ /dev/null @@ -1,26 +0,0 @@ -Copyright (c) Ian Lynagh, 2007-2008. -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. -3. Neither the name of the author nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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. diff --git a/libraries/integer-simple/Setup.hs b/libraries/integer-simple/Setup.hs deleted file mode 100644 index 6fa548caf7..0000000000 --- a/libraries/integer-simple/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/libraries/integer-simple/integer-simple.cabal b/libraries/integer-simple/integer-simple.cabal deleted file mode 100644 index 08e3acdc0f..0000000000 --- a/libraries/integer-simple/integer-simple.cabal +++ /dev/null @@ -1,32 +0,0 @@ -name: integer-simple -version: 0.1.1.1 --- GHC 7.6.1 released with 0.1.0.1 -license: BSD3 -license-file: LICENSE -maintainer: igloo@earth.li -synopsis: Simple Integer library -description: - This package contains a simple Integer library. -cabal-version: >=1.10 -build-type: Simple - -source-repository head - type: git - location: https://gitlab.haskell.org/ghc/ghc.git - subdir: libraries/integer-simple - -Library - default-language: Haskell2010 - - build-depends: ghc-prim - exposed-modules: GHC.Integer - GHC.Integer.Simple.Internals - GHC.Integer.Logarithms - GHC.Integer.Logarithms.Internals - other-modules: GHC.Integer.Type - default-extensions: CPP, MagicHash, BangPatterns, UnboxedTuples, - UnliftedFFITypes, NoImplicitPrelude - -- We need to set the unit ID to integer-wired-in - -- (without a version number) as it's magic. - -- See Note [The integer library] in PrelNames - ghc-options: -this-unit-id integer-wired-in -Wall |