diff --git a/GHC/Integer.hs b/GHC/Integer.hs new file mode 100644 --- /dev/null +++ b/GHC/Integer.hs @@ -0,0 +1,43 @@ + +{-# 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) +-- +-- An 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, -- XXX + andInteger, orInteger, xorInteger, complementInteger, + shiftLInteger, shiftRInteger, testBitInteger, + hashInteger, + ) where + +import GHC.Integer.Type + diff --git a/GHC/Integer/Logarithms.hs b/GHC/Integer/Logarithms.hs new file mode 100644 --- /dev/null +++ b/GHC/Integer/Logarithms.hs @@ -0,0 +1,43 @@ +{-# 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/GHC/Integer/Logarithms/Internals.hs b/GHC/Integer/Logarithms/Internals.hs new file mode 100644 --- /dev/null +++ b/GHC/Integer/Logarithms/Internals.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +#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/GHC/Integer/Simple/Internals.hs b/GHC/Integer/Simple/Internals.hs new file mode 100644 --- /dev/null +++ b/GHC/Integer/Simple/Internals.hs @@ -0,0 +1,23 @@ + +{-# 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) +-- +-- An simple definition of the 'Integer' type. +-- +----------------------------------------------------------------------------- + +module GHC.Integer.Simple.Internals ( + module GHC.Integer.Type + ) where + +import GHC.Integer.Type + diff --git a/GHC/Integer/Type.hs b/GHC/Integer/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/Integer/Type.hs @@ -0,0 +1,891 @@ + +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, BangPatterns, UnboxedTuples, + UnliftedFFITypes #-} + +-- Commentary of Integer library is located on the wiki: +-- http://ghc.haskell.org/trac/ghc/wiki/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) +-- +-- An 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 + +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 + +-- XXX this could be a lot more efficient, but this is a quick +-- reimplementation of the default Data.Bits instance, so that we can +-- implement the Integer interface +testBitInteger :: Integer -> Int# -> Bool +testBitInteger x i = (x `andInteger` (oneInteger `shiftLInteger` i)) + `neqInteger` Naught + +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 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< (# {- 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 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/integer-simple.cabal b/integer-simple.cabal new file mode 100644 --- /dev/null +++ b/integer-simple.cabal @@ -0,0 +1,31 @@ +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 an simple Integer library. +cabal-version: >=1.10 +build-type: Simple + +source-repository head + type: git + location: http://git.haskell.org/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-simple + -- (without a version number) as it's magic. + ghc-options: -this-unit-id integer-simple -Wall