integer-simple (empty) → 0.1.1.1
raw patch · 8 files changed
+1229/−0 lines, 8 filesdep +ghc-primsetup-changed
Dependencies added: ghc-prim
Files
- GHC/Integer.hs +43/−0
- GHC/Integer/Logarithms.hs +43/−0
- GHC/Integer/Logarithms/Internals.hs +166/−0
- GHC/Integer/Simple/Internals.hs +23/−0
- GHC/Integer/Type.hs +891/−0
- LICENSE +26/−0
- Setup.hs +6/−0
- integer-simple.cabal +31/−0
+ GHC/Integer.hs view
@@ -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+
+ GHC/Integer/Logarithms.hs view
@@ -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#
+ GHC/Integer/Logarithms/Internals.hs view
@@ -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
+ GHC/Integer/Simple/Internals.hs view
@@ -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+
+ GHC/Integer/Type.hs view
@@ -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<<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 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 ... ...+-}+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ integer-simple.cabal view
@@ -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