urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-24 20:47:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

urbit-atom: Vendor integer-simple.

Browse Source
This commit is contained in:
Benjamin Summers 2020-03-12 10:19:14 -07:00
parent 0abf80cc8e
commit cd656b389f
9 changed files with 1221 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkg/hs/stack.yaml
View File

@ -7,6 +7,7 @@ packages:
- urbit-atom
- urbit-azimuth
- urbit-king
- urbit-integer-simple
extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38

26
pkg/hs/urbit-integer-simple/LICENSE Normal file
View File

@ -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.

6
pkg/hs/urbit-integer-simple/Setup.hs Normal file
View File

@ -0,0 +1,6 @@
module Main (main) where
import Distribution.Simple
main :: IO ()
main = defaultMain

42
pkg/hs/urbit-integer-simple/Urbit/Integer.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : Urbit.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 Urbit.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 Urbit.Integer.Type

43
pkg/hs/urbit-integer-simple/Urbit/Integer/Logarithms.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-}
module Urbit.Integer.Logarithms
( integerLogBase#
, integerLog2#
, wordLog2#
) where
import GHC.Prim
import Urbit.Integer
import qualified Urbit.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#

166
pkg/hs/urbit-integer-simple/Urbit/Integer/Logarithms/Internals.hs Normal file
View File

@ -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 Urbit.Float, we must expose this
-- module, but it should not show up in the docs.
module Urbit.Integer.Logarithms.Internals
( integerLog2#
, integerLog2IsPowerOf2#
, wordLog2#
, roundingMode#
) where
import GHC.Prim
import Urbit.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

23
pkg/hs/urbit-integer-simple/Urbit/Integer/Simple/Internals.hs Normal file
View File

@ -0,0 +1,23 @@
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : Urbit.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 Urbit.Integer.Simple.Internals (
module Urbit.Integer.Type
) where
import Urbit.Integer.Type

891
pkg/hs/urbit-integer-simple/Urbit/Integer/Type.hs Normal file
View File

@ -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 : 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 'Integer' type.
--
-----------------------------------------------------------------------------
#include "MachDeps.h"
module Urbit.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 ... ...
-}

23
pkg/hs/urbit-integer-simple/urbit-integer-simple.cabal Normal file
View File

@ -0,0 +1,23 @@
name: urbit-integer-simple
version: 0.1.1.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
Library
default-language: Haskell2010
build-depends: ghc-prim
exposed-modules: Urbit.Integer
Urbit.Integer.Simple.Internals
Urbit.Integer.Logarithms
Urbit.Integer.Logarithms.Internals
other-modules: Urbit.Integer.Type
default-extensions: CPP, MagicHash, BangPatterns, UnboxedTuples,
UnliftedFFITypes, NoImplicitPrelude
ghc-options: -Wall