From 14cba45597aaf12fd50ffe257e7610a378f6b67f Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 12 Mar 2020 13:02:04 -0700 Subject: [PATCH] urbit-atom: Back out of vendoring integer-simple. --- pkg/hs/urbit-atom/lib/Urbit/Atom/Simple.hs | 42 - .../lib/Urbit/Atom/Simple/Internals.hs | 23 - .../lib/Urbit/Atom/Simple/Logarithms.hs | 43 - .../Urbit/Atom/Simple/Logarithms/Internals.hs | 166 ---- .../urbit-atom/lib/Urbit/Atom/Simple/Type.hs | 750 ------------------ 5 files changed, 1024 deletions(-) delete mode 100644 pkg/hs/urbit-atom/lib/Urbit/Atom/Simple.hs delete mode 100644 pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Internals.hs delete mode 100644 pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms.hs delete mode 100644 pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms/Internals.hs delete mode 100644 pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Type.hs diff --git a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple.hs b/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple.hs deleted file mode 100644 index 934fc03330..0000000000 --- a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} - ------------------------------------------------------------------------------ --- | --- Module : Urbit.Atom.Simple --- Copyright : (c) Ian Lynagh 2007-2012 --- License : BSD3 --- --- Maintainer : igloo@earth.li --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- An simple definition of the 'Atom' type. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module Urbit.Atom.Simple ( - Atom, mkAtom, - smallAtom, wordToAtom, integerToWord, integerToInt, -#if WORD_SIZE_IN_BITS < 64 - integerToWord64, word64ToAtom, - integerToInt64, int64ToAtom, -#endif - plusAtom, minusAtom, timesAtom, - eqAtom, neqAtom, absAtom, signumAtom, - leAtom, gtAtom, ltAtom, geAtom, compareAtom, - eqAtom#, neqAtom#, - leAtom#, gtAtom#, ltAtom#, geAtom#, - divAtom, modAtom, - divModAtom, quotRemAtom, quotAtom, remAtom, - encodeFloatAtom, decodeFloatAtom, floatFromAtom, - encodeDoubleAtom, decodeDoubleAtom, doubleFromAtom, - -- gcdAtom, lcmAtom, -- XXX - andAtom, orAtom, xorAtom, - shiftLAtom, shiftRAtom, testBitAtom, - hashAtom, - ) where - -import Urbit.Atom.Simple.Type - diff --git a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Internals.hs b/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Internals.hs deleted file mode 100644 index 5d910181f2..0000000000 --- a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Internals.hs +++ /dev/null @@ -1,23 +0,0 @@ - -{-# LANGUAGE NoImplicitPrelude #-} - ------------------------------------------------------------------------------ --- | --- Module : Urbit.Atom.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 'Atom' type. --- ------------------------------------------------------------------------------ - -module Urbit.Atom.Simple.Internals ( - module Urbit.Atom.Simple.Type - ) where - -import Urbit.Atom.Simple.Type - diff --git a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms.hs b/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms.hs deleted file mode 100644 index 562644fe2e..0000000000 --- a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-} -module Urbit.Atom.Simple.Logarithms - ( integerLogBase# - , integerLog2# - , wordLog2# - ) where - -import GHC.Prim -import Urbit.Atom.Simple -import qualified Urbit.Atom.Simple.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# :: Atom -> Atom -> Int# -integerLogBase# b m = case step b of - (# _, e #) -> e - where - step pw = - if m `ltAtom` pw - then (# m, 0# #) - else case step (pw `timesAtom` pw) of - (# q, e #) -> - if q `ltAtom` pw - then (# q, 2# *# e #) - else (# q `quotAtom` pw, 2# *# e +# 1# #) - --- | Calculate the integer base 2 logarithm of an 'Atom'. --- 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# :: Atom -> Int# -integerLog2# = I.integerLog2# - --- | This function calculates the integer base 2 logarithm of a 'Word#'. -wordLog2# :: Word# -> Int# -wordLog2# = I.wordLog2# diff --git a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms/Internals.hs b/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms/Internals.hs deleted file mode 100644 index 64530945bd..0000000000 --- a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Logarithms/Internals.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# 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 Urbit.Float, we must expose this --- module, but it should not show up in the docs. - -module Urbit.Atom.Simple.Logarithms.Internals - ( integerLog2# - , integerLog2IsPowerOf2# - , wordLog2# - , roundingMode# - ) where - -import GHC.Prim -import Urbit.Atom.Simple.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: Atom is strictly positive, --- otherwise return -1# arbitrarily --- Going up in word-sized steps should not be too bad. -integerLog2# :: Atom -> 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# :: Atom -> (# 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: Atom and Int# are strictly positive, Int# is less --- than logBase 2 of Atom, 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# :: Atom -> Int# -> Int# -roundingMode# m h = - case oneAtom `shiftLAtom` h of - c -> case m `andAtom` - ((c `plusAtom` c) `minusAtom` oneAtom) of - r -> - if c `ltAtom` r - then 2# - else if c `gtAtom` 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/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Type.hs b/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Type.hs deleted file mode 100644 index 51384d43af..0000000000 --- a/pkg/hs/urbit-atom/lib/Urbit/Atom/Simple/Type.hs +++ /dev/null @@ -1,750 +0,0 @@ - -{-# 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 : Urbit.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 'Atom' type. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module Urbit.Atom.Simple.Type where - -import Prelude (error) -import GHC.Exception.Type (underflowException) -import GHC.Prim -import GHC.Classes -import GHC.Types -import GHC.Tuple () -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif - -data Atom = Positive !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) - -mkAtom :: [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. - -> Atom -mkAtom is = f is - where f [] = Naught - f (I# i : is') = smallAtom i `orAtom` shiftLAtom (f is') 31# - -errorAtom :: Atom -errorAtom = Positive errorPositive - -errorPositive :: Positive -errorPositive = Some 47## None -- Random number - -{-# NOINLINE underflowError #-} -underflowError :: a -underflowError = raise# underflowException - -{-# NOINLINE smallAtom #-} -smallAtom :: Int# -> Atom -smallAtom i = if isTrue# (i >=# 0#) then wordToAtom (int2Word# i) - else underflowError - -{-# NOINLINE wordToAtom #-} -wordToAtom :: Word# -> Atom -wordToAtom w = if isTrue# (w `eqWord#` 0##) - then Naught - else Positive (Some w None) - -{-# NOINLINE integerToWord #-} -integerToWord :: Atom -> Word# -integerToWord (Positive (Some w _)) = w --- Must be Naught by the invariant: -integerToWord _ = 0## - -{-# NOINLINE integerToInt #-} -integerToInt :: Atom -> Int# -integerToInt i = word2Int# (integerToWord i) - -#if WORD_SIZE_IN_BITS == 64 --- Nothing -#elif WORD_SIZE_IN_BITS == 32 -{-# NOINLINE integerToWord64 #-} -integerToWord64 :: Atom -> Word64# -integerToWord64 i = int64ToWord64# (integerToInt64 i) - -{-# NOINLINE word64ToAtom #-} -word64ToAtom:: Word64# -> Atom -word64ToAtom w = if isTrue# (w `eqWord64#` wordToWord64# 0##) - then Naught - else Positive (word64ToPositive w) - -{-# NOINLINE integerToInt64 #-} -integerToInt64 :: Atom -> Int64# -integerToInt64 Naught = intToInt64# 0# -integerToInt64 (Positive p) = word64ToInt64# (positiveToWord64 p) - -{-# NOINLINE int64ToAtom #-} -int64ToAtom :: Int64# -> Atom -int64ToAtom i - = if isTrue# (i `eqInt64#` intToInt64# 0#) - then Naught - else if isTrue# (i `gtInt64#` intToInt64# 0#) - then Positive (word64ToPositive (int64ToWord64# i)) -#else -#error WORD_SIZE_IN_BITS not supported -#endif - -oneAtom :: Atom -oneAtom = Positive onePositive - -twoToTheThirtytwoAtom :: Atom -twoToTheThirtytwoAtom = Positive twoToTheThirtytwoPositive - -{-# NOINLINE encodeDoubleAtom #-} -encodeDoubleAtom :: Atom -> Int# -> Double# -encodeDoubleAtom (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#) -encodeDoubleAtom Naught _ = 0.0## - -foreign import ccall unsafe "__word_encodeDouble" - encodeDouble# :: Word# -> Int# -> Double# - -{-# NOINLINE encodeFloatAtom #-} -encodeFloatAtom :: Atom -> Int# -> Float# -encodeFloatAtom (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#) -encodeFloatAtom Naught _ = 0.0# - -foreign import ccall unsafe "__word_encodeFloat" - encodeFloat# :: Word# -> Int# -> Float# - -{-# NOINLINE decodeFloatAtom #-} -decodeFloatAtom :: Float# -> (# Atom, Int# #) -decodeFloatAtom f = case decodeFloat_Int# f of - (# mant, exp #) -> (# smallAtom 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 decodeDoubleAtom #-} -decodeDoubleAtom :: Double# -> (# Atom, Int# #) -decodeDoubleAtom d - = case decodeDouble_2Int# d of - (# mantSign, mantHigh, mantLow, exp #) -> - (# (smallAtom mantSign) `timesAtom` - ( (wordToAtom mantHigh `timesAtom` twoToTheThirtytwoAtom) - `plusAtom` wordToAtom mantLow), - exp #) - -{-# NOINLINE doubleFromAtom #-} -doubleFromAtom :: Atom -> Double# -doubleFromAtom Naught = 0.0## -doubleFromAtom (Positive p) = doubleFromPositive p - -{-# NOINLINE floatFromAtom #-} -floatFromAtom :: Atom -> Float# -floatFromAtom Naught = 0.0# -floatFromAtom (Positive p) = floatFromPositive p - -{-# NOINLINE andAtom #-} -andAtom :: Atom -> Atom -> Atom -Naught `andAtom` (!_) = Naught -(!_) `andAtom` Naught = Naught -Positive x `andAtom` Positive y = digitsToAtom (x `andDigits` y) - -{-# NOINLINE orAtom #-} -orAtom :: Atom -> Atom -> Atom -Naught `orAtom` (!i) = i -(!i) `orAtom` Naught = i -Positive x `orAtom` Positive y = Positive (x `orDigits` y) - -{-# NOINLINE xorAtom #-} -xorAtom :: Atom -> Atom -> Atom -Naught `xorAtom` (!i) = i -(!i) `xorAtom` Naught = i -Positive x `xorAtom` Positive y = digitsToAtom (x `xorDigits` y) - -{-# NOINLINE shiftLAtom #-} -shiftLAtom :: Atom -> Int# -> Atom -shiftLAtom (Positive p) i = Positive (shiftLPositive p i) -shiftLAtom Naught _ = Naught - -{-# NOINLINE shiftRAtom #-} -shiftRAtom :: Atom -> Int# -> Atom -shiftRAtom (Positive p) i = shiftRPositive p i -shiftRAtom 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 Atom interface -testBitAtom :: Atom -> Int# -> Bool -testBitAtom x i = (x `andAtom` (oneAtom `shiftLAtom` i)) - `neqAtom` 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) - --- Note [Avoid patError] -{-# NOINLINE plusAtom #-} -plusAtom :: Atom -> Atom -> Atom -Positive p1 `plusAtom` Positive p2 = Positive (p1 `plusPositive` p2) -Naught `plusAtom` Naught = Naught -Naught `plusAtom` i@(Positive _) = i -i@(Positive _) `plusAtom` Naught = i - -{-# NOINLINE minusAtom #-} -minusAtom :: Atom -> Atom -> Atom -i1 `minusAtom` i2 = i1 `plusAtom` error "negateAtom i2" - -{-# NOINLINE timesAtom #-} -timesAtom :: Atom -> Atom -> Atom -Positive p1 `timesAtom` Positive p2 = Positive (p1 `timesPositive` p2) -(!_) `timesAtom` (!_) = Naught - -{-# NOINLINE divModAtom #-} -divModAtom :: Atom -> Atom -> (# Atom, Atom #) -n `divModAtom` d = - case n `quotRemAtom` d of - (# q, r #) -> - if signumAtom r `eqAtom` - error "negateAtom (signumAtom d)" - then (# q `minusAtom` oneAtom, r `plusAtom` d #) - else (# q, r #) - -{-# NOINLINE divAtom #-} -divAtom :: Atom -> Atom -> Atom -n `divAtom` d = quotient - where (# quotient, _ #) = n `divModAtom` d - -{-# NOINLINE modAtom #-} -modAtom :: Atom -> Atom -> Atom -n `modAtom` d = modulus - where (# _, modulus #) = n `divModAtom` d - -{-# NOINLINE quotRemAtom #-} -quotRemAtom :: Atom -> Atom -> (# Atom, Atom #) -Naught `quotRemAtom` (!_) = (# Naught, Naught #) -(!_) `quotRemAtom` Naught - = (# errorAtom, errorAtom #) -- XXX Can't happen --- XXX _ `quotRemAtom` Naught = error "Division by zero" -Positive p1 `quotRemAtom` Positive p2 = p1 `quotRemPositive` p2 - -{-# NOINLINE quotAtom #-} -quotAtom :: Atom -> Atom -> Atom -x `quotAtom` y = case x `quotRemAtom` y of - (# q, _ #) -> q - -{-# NOINLINE remAtom #-} -remAtom :: Atom -> Atom -> Atom -x `remAtom` y = case x `quotRemAtom` y of - (# _, r #) -> r - -{-# NOINLINE compareAtom #-} -compareAtom :: Atom -> Atom -> Ordering -Positive x `compareAtom` Positive y = x `comparePositive` y -Positive _ `compareAtom` (!_) = GT -Naught `compareAtom` Naught = EQ -(!_) `compareAtom` (!_) = LT - -{-# NOINLINE eqAtom# #-} -eqAtom# :: Atom -> Atom -> Int# -x `eqAtom#` y = case x `compareAtom` y of - EQ -> 1# - _ -> 0# - -{-# NOINLINE neqAtom# #-} -neqAtom# :: Atom -> Atom -> Int# -x `neqAtom#` y = case x `compareAtom` y of - EQ -> 0# - _ -> 1# - -{-# INLINE eqAtom #-} -{-# INLINE neqAtom #-} -eqAtom, neqAtom :: Atom -> Atom -> Bool -eqAtom a b = isTrue# (a `eqAtom#` b) -neqAtom a b = isTrue# (a `neqAtom#` b) - -instance Eq Atom where - (==) = eqAtom - (/=) = neqAtom - -{-# NOINLINE ltAtom# #-} -ltAtom# :: Atom -> Atom -> Int# -x `ltAtom#` y = case x `compareAtom` y of - LT -> 1# - _ -> 0# - -{-# NOINLINE gtAtom# #-} -gtAtom# :: Atom -> Atom -> Int# -x `gtAtom#` y = case x `compareAtom` y of - GT -> 1# - _ -> 0# - -{-# NOINLINE leAtom# #-} -leAtom# :: Atom -> Atom -> Int# -x `leAtom#` y = case x `compareAtom` y of - GT -> 0# - _ -> 1# - -{-# NOINLINE geAtom# #-} -geAtom# :: Atom -> Atom -> Int# -x `geAtom#` y = case x `compareAtom` y of - LT -> 0# - _ -> 1# - -{-# INLINE leAtom #-} -{-# INLINE ltAtom #-} -{-# INLINE geAtom #-} -{-# INLINE gtAtom #-} -leAtom, gtAtom, ltAtom, geAtom :: Atom -> Atom -> Bool -leAtom a b = isTrue# (a `leAtom#` b) -gtAtom a b = isTrue# (a `gtAtom#` b) -ltAtom a b = isTrue# (a `ltAtom#` b) -geAtom a b = isTrue# (a `geAtom#` b) - -instance Ord Atom where - (<=) = leAtom - (>) = gtAtom - (<) = ltAtom - (>=) = geAtom - compare = compareAtom - -{-# NOINLINE absAtom #-} -absAtom :: Atom -> Atom -absAtom x = x - -{-# NOINLINE signumAtom #-} -signumAtom :: Atom -> Atom -signumAtom Naught = Naught -signumAtom (Positive _) = oneAtom - -{-# NOINLINE hashAtom #-} -hashAtom :: Atom -> Int# -hashAtom = 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 - -digitsMaybeZeroToAtom :: Digits -> Atom -digitsMaybeZeroToAtom None = Naught -digitsMaybeZeroToAtom ds = Positive ds - -digitsToAtom :: Digits -> Atom -digitsToAtom ds = case removeZeroTails ds of - None -> Naught - ds' -> Positive 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# -> Atom -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# -> Atom -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 -> (# Atom, Atom #) -(!xs) `quotRemPositive` (!ys) - = case f xs of - (# d, m #) -> (# digitsMaybeZeroToAtom d, - digitsMaybeZeroToAtom 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 ... ... --} -