diff options
Diffstat (limited to 'libraries/integer-gmp')
30 files changed, 3589 insertions, 3332 deletions
diff --git a/libraries/integer-gmp/.gitignore b/libraries/integer-gmp/.gitignore index 4e7da368da..3f3fc66144 100644 --- a/libraries/integer-gmp/.gitignore +++ b/libraries/integer-gmp/.gitignore @@ -1,16 +1,14 @@ +/GNUmakefile /autom4te.cache/ -/cbits/GmpDerivedConstants.h -/cbits/mkGmpDerivedConstants /config.log /config.status /configure /dist-install/ /ghc.mk /gmp/config.mk -/GNUmakefile /include/HsIntegerGmp.h /integer-gmp.buildinfo -/mkGmpDerivedConstants/dist/ /gmp/gmp.h /gmp/gmpbuild +/include/ghc-gmp.h diff --git a/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs deleted file mode 100644 index 0a212f712e..0000000000 --- a/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - --- | This modules provides access to the 'Integer' constructors and --- exposes some highly optimized GMP-operations. --- --- Note that since @integer-gmp@ does not depend on `base`, error --- reporting via exceptions, 'error', or 'undefined' is not --- available. Instead, the low-level functions will crash the runtime --- if called with invalid arguments. --- --- See also --- <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer GHC Commentary: Libraries/Integer>. - -module GHC.Integer.GMP.Internals - ( -- * The 'Integer' type - Integer(..) - - -- * Number theoretic functions - , gcdInt - , gcdInteger - , gcdExtInteger - , lcmInteger - , nextPrimeInteger - , testPrimeInteger - - -- * Exponentiation functions - , powInteger - , powModInteger - , powModSecInteger - , recipModInteger - - -- * Import/export functions - , sizeInBaseInteger - , importIntegerFromByteArray - , importIntegerFromAddr - , exportIntegerToMutableByteArray - , exportIntegerToAddr - ) where - -import GHC.Integer.Type diff --git a/libraries/integer-gmp/GHC/Integer/GMP/Prim.hs b/libraries/integer-gmp/GHC/Integer/GMP/Prim.hs deleted file mode 100644 index 4137dd5da9..0000000000 --- a/libraries/integer-gmp/GHC/Integer/GMP/Prim.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, NoImplicitPrelude, UnboxedTuples - , UnliftedFFITypes, GHCForeignImportPrim #-} -{-# OPTIONS_HADDOCK hide #-} - -#include "MachDeps.h" -module GHC.Integer.GMP.Prim ( - MPZ#, - - cmpInteger#, - cmpIntegerInt#, - - plusInteger#, - plusIntegerInt#, - minusInteger#, - minusIntegerInt#, - timesInteger#, - timesIntegerInt#, - - quotRemInteger#, - quotRemIntegerWord#, - quotInteger#, - quotIntegerWord#, - remInteger#, - remIntegerWord#, - - divModInteger#, - divModIntegerWord#, - divInteger#, - divIntegerWord#, - modInteger#, - modIntegerWord#, - divExactInteger#, - divExactIntegerWord#, - - gcdInteger#, - gcdExtInteger#, - gcdIntegerInt#, - gcdInt#, - - decodeDouble#, - - int2Integer#, - integer2Int#, - - word2Integer#, - integer2Word#, - - andInteger#, - orInteger#, - xorInteger#, - complementInteger#, - - testBitInteger#, - mul2ExpInteger#, - fdivQ2ExpInteger#, - - powInteger#, - powModInteger#, - powModSecInteger#, - recipModInteger#, - - nextPrimeInteger#, - testPrimeInteger#, - - sizeInBaseInteger#, - importIntegerFromByteArray#, - importIntegerFromAddr#, - exportIntegerToMutableByteArray#, - exportIntegerToAddr#, - -#if WORD_SIZE_IN_BITS < 64 - int64ToInteger#, integerToInt64#, - word64ToInteger#, integerToWord64#, -#endif - -#ifndef WORD_SIZE_IN_BITS -#error WORD_SIZE_IN_BITS not defined!!! -#endif - - ) where - -import GHC.Prim -import GHC.Types - --- Double isn't available yet, and we shouldn't be using defaults anyway: -default () - --- | This is represents a @mpz_t@ value in a heap-saving way. --- --- The first tuple element, @/s/@, encodes the sign of the integer --- @/i/@ (i.e. @signum /s/ == signum /i/@), and the number of /limbs/ --- used to represent the magnitude. If @abs /s/ > 1@, the 'ByteArray#' --- contains @abs /s/@ limbs encoding the integer. Otherwise, if @abs --- /s/ < 2@, the single limb is stored in the 'Word#' element instead --- (and the 'ByteArray#' element is undefined and MUST NOT be accessed --- as it doesn't point to a proper 'ByteArray#' but rather to an --- unsafe-coerced 'Int' in order be polite to the GC -- see --- @DUMMY_BYTE_ARR@ in gmp-wrappers.cmm) --- --- More specifically, the following encoding is used (where `⊥` means --- undefined/unused): --- --- * (# 0#, ⊥, 0## #) -> value = 0 --- * (# 1#, ⊥, w #) -> value = w --- * (# -1#, ⊥, w #) -> value = -w --- * (# s#, d, 0## #) -> value = J# s d --- --- This representation allows to avoid temporary heap allocations --- (-> Trac #8647) of 1-limb 'ByteArray#'s which fit into the --- 'S#'-constructor. Moreover, this allows to delays 1-limb --- 'ByteArray#' heap allocations, as such 1-limb `mpz_t`s can be --- optimistically allocated on the Cmm stack and returned as a @#word@ --- in case the `mpz_t` wasn't grown beyond 1 limb by the GMP --- operation. --- --- See also the 'GHC.Integer.Type.mpzToInteger' function which ought --- to be used for converting 'MPZ#'s to 'Integer's and the --- @MP_INT_1LIMB_RETURN()@ macro in @gmp-wrappers.cmm@ which --- constructs 'MPZ#' values in the first place for implementation --- details. -type MPZ# = (# Int#, ByteArray#, Word# #) - --- | Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument. --- -foreign import prim "integer_cmm_cmpIntegerzh" cmpInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# - --- | Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which --- is an ordinary Int\#. -foreign import prim "integer_cmm_cmpIntegerIntzh" cmpIntegerInt# - :: Int# -> ByteArray# -> Int# -> Int# - --- | --- -foreign import prim "integer_cmm_plusIntegerzh" plusInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Optimized version of 'plusInteger#' for summing big-ints with small-ints --- -foreign import prim "integer_cmm_plusIntegerIntzh" plusIntegerInt# - :: Int# -> ByteArray# -> Int# -> MPZ# - --- | --- -foreign import prim "integer_cmm_minusIntegerzh" minusInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Optimized version of 'minusInteger#' for substracting small-ints from big-ints --- -foreign import prim "integer_cmm_minusIntegerIntzh" minusIntegerInt# - :: Int# -> ByteArray# -> Int# -> MPZ# - --- | --- -foreign import prim "integer_cmm_timesIntegerzh" timesInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Optimized version of 'timesInteger#' for multiplying big-ints with small-ints --- -foreign import prim "integer_cmm_timesIntegerIntzh" timesIntegerInt# - :: Int# -> ByteArray# -> Int# -> MPZ# - --- | Compute div and mod simultaneously, where div rounds towards negative --- infinity and\ @(q,r) = divModInteger#(x,y)@ implies --- @plusInteger# (timesInteger# q y) r = x@. --- -foreign import prim "integer_cmm_quotRemIntegerzh" quotRemInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# MPZ#, MPZ# #) - --- | Variant of 'quotRemInteger#' --- -foreign import prim "integer_cmm_quotRemIntegerWordzh" quotRemIntegerWord# - :: Int# -> ByteArray# -> Word# -> (# MPZ#, MPZ# #) - --- | Rounds towards zero. --- -foreign import prim "integer_cmm_quotIntegerzh" quotInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Rounds towards zero. -foreign import prim "integer_cmm_quotIntegerWordzh" quotIntegerWord# - :: Int# -> ByteArray# -> Word# -> MPZ# - --- | Satisfies \texttt{plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x}. --- -foreign import prim "integer_cmm_remIntegerzh" remInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Variant of 'remInteger#' -foreign import prim "integer_cmm_remIntegerWordzh" remIntegerWord# - :: Int# -> ByteArray# -> Word# -> MPZ# - --- | Compute div and mod simultaneously, where div rounds towards negative infinity --- and\texttt{(q,r) = divModInteger\#(x,y)} implies \texttt{plusInteger\# (timesInteger\# q y) r = x}. --- -foreign import prim "integer_cmm_divModIntegerzh" divModInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# MPZ#, MPZ# #) -foreign import prim "integer_cmm_divModIntegerWordzh" divModIntegerWord# - :: Int# -> ByteArray# -> Word# -> (# MPZ#, MPZ# #) -foreign import prim "integer_cmm_divIntegerzh" divInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# -foreign import prim "integer_cmm_divIntegerWordzh" divIntegerWord# - :: Int# -> ByteArray# -> Word# -> MPZ# -foreign import prim "integer_cmm_modIntegerzh" modInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# -foreign import prim "integer_cmm_modIntegerWordzh" modIntegerWord# - :: Int# -> ByteArray# -> Word# -> MPZ# - --- | Divisor is guaranteed to be a factor of dividend. --- -foreign import prim "integer_cmm_divExactIntegerzh" divExactInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - -foreign import prim "integer_cmm_divExactIntegerWordzh" divExactIntegerWord# - :: Int# -> ByteArray# -> Word# -> MPZ# - --- | Greatest common divisor. --- -foreign import prim "integer_cmm_gcdIntegerzh" gcdInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | Extended greatest common divisor. --- -foreign import prim "integer_cmm_gcdExtIntegerzh" gcdExtInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# MPZ#, MPZ# #) - --- | Greatest common divisor, where second argument is an ordinary {\tt Int\#}. --- -foreign import prim "integer_cmm_gcdIntegerIntzh" gcdIntegerInt# - :: Int# -> ByteArray# -> Int# -> Int# - --- | --- -foreign import prim "integer_cmm_gcdIntzh" gcdInt# - :: Int# -> Int# -> Int# - --- | Convert to arbitrary-precision integer. --- First {\tt Int\#} in result is the exponent; second {\tt Int\#} and {\tt ByteArray\#} --- represent an {\tt Integer\#} holding the mantissa. --- -foreign import prim "integer_cmm_decodeDoublezh" decodeDouble# - :: Double# -> (# Int#, MPZ# #) - --- | --- --- Note: This primitive doesn't use 'MPZ#' because its purpose is to instantiate a 'J#'-value. -foreign import prim "integer_cmm_int2Integerzh" int2Integer# - :: Int# -> (# Int#, ByteArray# #) - --- | --- --- Note: This primitive doesn't use 'MPZ#' because its purpose is to instantiate a 'J#'-value. -foreign import prim "integer_cmm_word2Integerzh" word2Integer# - :: Word# -> (# Int#, ByteArray# #) - --- | --- -foreign import prim "integer_cmm_andIntegerzh" andInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_orIntegerzh" orInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_xorIntegerzh" xorInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_testBitIntegerzh" testBitInteger# - :: Int# -> ByteArray# -> Int# -> Int# - --- | --- -foreign import prim "integer_cmm_mul2ExpIntegerzh" mul2ExpInteger# - :: Int# -> ByteArray# -> Int# -> MPZ# - --- | --- -foreign import prim "integer_cmm_fdivQ2ExpIntegerzh" fdivQ2ExpInteger# - :: Int# -> ByteArray# -> Int# -> MPZ# - --- | --- -foreign import prim "integer_cmm_powIntegerzh" powInteger# - :: Int# -> ByteArray# -> Word# -> MPZ# - --- | --- -foreign import prim "integer_cmm_powModIntegerzh" powModInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_powModSecIntegerzh" powModSecInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_recipModIntegerzh" recipModInteger# - :: Int# -> ByteArray# -> Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_nextPrimeIntegerzh" nextPrimeInteger# - :: Int# -> ByteArray# -> MPZ# - --- | --- -foreign import prim "integer_cmm_testPrimeIntegerzh" testPrimeInteger# - :: Int# -> ByteArray# -> Int# -> Int# - --- | --- -foreign import prim "integer_cmm_sizeInBasezh" sizeInBaseInteger# - :: Int# -> ByteArray# -> Int# -> Word# - --- | --- -foreign import prim "integer_cmm_importIntegerFromByteArrayzh" importIntegerFromByteArray# - :: ByteArray# -> Word# -> Word# -> Int# -> MPZ# - --- | --- -foreign import prim "integer_cmm_importIntegerFromAddrzh" importIntegerFromAddr# - :: Addr# -> Word# -> Int# -> State# s -> (# State# s, MPZ# #) - --- | --- -foreign import prim "integer_cmm_exportIntegerToMutableByteArrayzh" exportIntegerToMutableByteArray# - :: Int# -> ByteArray# -> MutableByteArray# s -> Word# -> Int# -> State# s -> (# State# s, Word# #) - --- | --- -foreign import prim "integer_cmm_exportIntegerToAddrzh" exportIntegerToAddr# - :: Int# -> ByteArray# -> Addr# -> Int# -> State# s -> (# State# s, Word# #) - --- | --- -foreign import prim "integer_cmm_complementIntegerzh" complementInteger# - :: Int# -> ByteArray# -> MPZ# - -#if WORD_SIZE_IN_BITS < 64 --- Note: This primitive doesn't use 'MPZ#' because its purpose is to instantiate a 'J#'-value. -foreign import prim "integer_cmm_int64ToIntegerzh" int64ToInteger# - :: Int64# -> (# Int#, ByteArray# #) - --- Note: This primitive doesn't use 'MPZ#' because its purpose is to instantiate a 'J#'-value. -foreign import prim "integer_cmm_word64ToIntegerzh" word64ToInteger# - :: Word64# -> (# Int#, ByteArray# #) - -foreign import ccall unsafe "hs_integerToInt64" - integerToInt64# :: Int# -> ByteArray# -> Int64# - -foreign import ccall unsafe "hs_integerToWord64" - integerToWord64# :: Int# -> ByteArray# -> Word64# -#endif - --- used to be primops: -integer2Int# :: Int# -> ByteArray# -> Int# -integer2Int# s d = if isTrue# (s ==# 0#) - then 0# - else let !v = indexIntArray# d 0# in - if isTrue# (s <# 0#) - then negateInt# v - else v - -integer2Word# :: Int# -> ByteArray# -> Word# -integer2Word# s d = int2Word# (integer2Int# s d) diff --git a/libraries/integer-gmp/GHC/Integer/Logarithms.hs b/libraries/integer-gmp/GHC/Integer/Logarithms.hs deleted file mode 100644 index cfafe14226..0000000000 --- a/libraries/integer-gmp/GHC/Integer/Logarithms.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-} -module GHC.Integer.Logarithms - ( integerLogBase# - , integerLog2# - , wordLog2# - ) where - -import GHC.Prim -import GHC.Integer -import qualified GHC.Integer.Logarithms.Internals as I - --- | Calculate the integer logarithm for an arbitrary base. --- The base must be greater than 1, the second argument, the number --- whose logarithm is sought, should be positive, otherwise the --- result is meaningless. --- --- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1) --- --- for @base > 1@ and @m > 0@. -integerLogBase# :: Integer -> Integer -> Int# -integerLogBase# b m = case step b of - (# _, e #) -> e - where - step pw = - if m `ltInteger` pw - then (# m, 0# #) - else case step (pw `timesInteger` pw) of - (# q, e #) -> - if q `ltInteger` pw - then (# q, 2# *# e #) - else (# q `quotInteger` pw, 2# *# e +# 1# #) - --- | Calculate the integer base 2 logarithm of an 'Integer'. --- The calculation is more efficient than for the general case, --- on platforms with 32- or 64-bit words much more efficient. --- --- The argument must be strictly positive, that condition is /not/ checked. -integerLog2# :: Integer -> Int# -integerLog2# = I.integerLog2# - --- | This function calculates the integer base 2 logarithm of a 'Word#'. -wordLog2# :: Word# -> Int# -wordLog2# = I.wordLog2# diff --git a/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs b/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs deleted file mode 100644 index 59c800a3f9..0000000000 --- a/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} -{-# OPTIONS_HADDOCK hide #-} - -#include "MachDeps.h" - --- 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.Types (isTrue#) -import GHC.Integer.Type - --- When larger word sizes become common, add support for those, --- it is not hard, just tedious. -#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) - --- Less than ideal implementations for strange word sizes - -import GHC.Integer - -default () - --- We do not know whether the word has 30 bits or 128 or even more, --- so we cannot start from the top, although that would be much more --- efficient. --- Count the bits until the highest set bit is found. -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 - --- Assumption: Integer is strictly positive -integerLog2# :: Integer -> Int# -integerLog2# (S# i) = wordLog2# (int2Word# i) -- that is easy -integerLog2# m = case step m (smallInteger 2#) 1# of - (# _, l #) -> l - where - -- Invariants: - -- pw = 2 ^ lg - -- case step n pw lg of - -- (q, e) -> pw^(2*e) <= n < pw^(2*e+2) - -- && q <= n/pw^(2*e) < (q+1) - -- && q < pw^2 - step n pw lg = - if n `ltInteger` pw - then (# n, 0# #) - else case step n (shiftLInteger pw lg) (2# *# lg) of - (# q, e #) -> - if q `ltInteger` pw - then (# q, 2# *# e #) - else (# q `shiftRInteger` lg, 2# *# e +# 1# #) - --- Calculate the log2 of a positive integer and check --- whether it is a power of 2. --- By coincidence, the presence of a power of 2 is --- signalled by zero and not one. -integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) -integerLog2IsPowerOf2# m = - case integerLog2# m of - lg -> if m `eqInteger` (smallInteger 1# `shiftLInteger` lg) - then (# lg, 0# #) - else (# lg, 1# #) - --- Detect the rounding mode, --- 0# means round to zero, --- 1# means round to even, --- 2# means round away from zero -roundingMode# :: Integer -> Int# -> Int# -roundingMode# m h = - case smallInteger 1# `shiftLInteger` h of - c -> case m `andInteger` - ((c `plusInteger` c) `minusInteger` smallInteger 1#) of - r -> - if c `ltInteger` r - then 2# - else if c `gtInteger` r - then 0# - else 1# - -#else - -default () - --- We have a nice word size, we can do much better now. - -#if WORD_SIZE_IN_BITS == 32 - -#define WSHIFT 5 -#define MMASK 31 - -#else - -#define WSHIFT 6 -#define MMASK 63 - -#endif - --- Assumption: Integer is strictly positive --- For small integers, use wordLog#, --- in the general case, check words from the most --- significant down, once a nonzero word is found, --- calculate its log2 and add the number of following bits. -integerLog2# :: Integer -> Int# -integerLog2# (S# i) = wordLog2# (int2Word# i) -integerLog2# (J# s ba) = check (s -# 1#) - where - check i = case indexWordArray# ba i of - 0## -> check (i -# 1#) - w -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) - --- Assumption: Integer is strictly positive --- First component is log2 n, second is 0# iff n is a power of two -integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) --- The power of 2 test is n&(n-1) == 0, thus powers of 2 --- are indicated bythe second component being zero. -integerLog2IsPowerOf2# (S# i) = - case int2Word# i of - w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #) --- Find the log2 as above, test whether that word is a power --- of 2, if so, check whether only zero bits follow. -integerLog2IsPowerOf2# (J# s ba) = check (s -# 1#) - where - check :: Int# -> (# Int#, Int# #) - check i = case indexWordArray# ba i of - 0## -> check (i -# 1#) - w -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) - , case w `and#` (w `minusWord#` 1##) of - 0## -> test (i -# 1#) - _ -> 1# #) - test :: Int# -> Int# - test i = if isTrue# (i <# 0#) - then 0# - else case indexWordArray# ba i of - 0## -> test (i -# 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) -roundingMode# :: Integer -> Int# -> Int# -roundingMode# (S# i) t = - case int2Word# i `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of - k -> case uncheckedShiftL# 1## t of - c -> if isTrue# (c `gtWord#` k) - then 0# - else if isTrue# (c `ltWord#` k) - then 2# - else 1# -roundingMode# (J# _ ba) t = - case word2Int# (int2Word# t `and#` MMASK##) of - j -> -- index of relevant bit in word - case uncheckedIShiftRA# t WSHIFT# of - k -> -- index of relevant word - case indexWordArray# ba k `and#` - ((uncheckedShiftL# 2## j) `minusWord#` 1##) of - r -> - case uncheckedShiftL# 1## j of - c -> if isTrue# (c `gtWord#` r) - then 0# - else if isTrue# (c `ltWord#` r) - then 2# - else test (k -# 1#) - where - test i = if isTrue# (i <# 0#) - then 1# - else case indexWordArray# ba i of - 0## -> test (i -# 1#) - _ -> 2# - --- 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 - --- Lookup table -data BA = BA ByteArray# - -leadingZeros :: BA -leadingZeros = - let mkArr s = - case newByteArray# 256# s of - (# s1, mba #) -> - case writeInt8Array# mba 0# 9# s1 of - s2 -> - let fillA lim val idx st = - if isTrue# (idx ==# 256#) - then st - else if isTrue# (idx <# lim) - then case writeInt8Array# mba idx val st of - nx -> fillA lim val (idx +# 1#) nx - else fillA (2# *# lim) (val -# 1#) idx st - in case fillA 2# 8# 1# s2 of - s3 -> case unsafeFreezeByteArray# mba s3 of - (# _, ba #) -> ba - in case mkArr realWorld# of - b -> BA b diff --git a/libraries/integer-gmp/GHC/Integer/Type.lhs b/libraries/integer-gmp/GHC/Integer/Type.lhs deleted file mode 100644 index 0f408ff0a0..0000000000 --- a/libraries/integer-gmp/GHC/Integer/Type.lhs +++ /dev/null @@ -1,1021 +0,0 @@ -\begin{code} -{-# LANGUAGE BangPatterns, CPP, UnboxedTuples, UnliftedFFITypes, MagicHash, NoImplicitPrelude #-} -{-# OPTIONS_HADDOCK hide #-} - --- 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. --- --- TODO: Try to use optimized big/small int primops on IL32P64 archs --- (mostly Windows/x86_64). Currently, we have to fall back to --- unoptimized code-paths for most big/small-int primops, due to --- @mpz_*()@ functions using @long@ types, which is smaller than --- @mp_limb_t@ on IL32P64. The @mpn_*()@ functions are often safe to --- use, as they use @mb_limb_t@ instead of @long@. --- (look out for @#if SIZEOF_HSWORD == SIZEOF_LONG@ occurences) --- - -#include "MachDeps.h" -#include "HsIntegerGmp.h" - -#if SIZEOF_HSWORD == 4 -#define INT_MINBOUND (-2147483648#) -#define NEG_INT_MINBOUND (S# 2147483647# `plusInteger` S# 1#) -#elif SIZEOF_HSWORD == 8 -#define INT_MINBOUND (-9223372036854775808#) -#define NEG_INT_MINBOUND (S# 9223372036854775807# `plusInteger` S# 1#) -#else -#error Unknown SIZEOF_HSWORD; can't define INT_MINBOUND and NEG_INT_MINBOUND -#endif - -module GHC.Integer.Type where - -import GHC.Prim ( - -- Other types we use, convert from, or convert to - Int#, Word#, Double#, Float#, ByteArray#, MutableByteArray#, Addr#, State#, - indexIntArray#, - -- Conversions between those types - int2Word#, int2Double#, int2Float#, word2Int#, - -- Operations on Int# that we use for operations on S# - quotInt#, remInt#, quotRemInt#, negateInt#, - (*#), (-#), - (==#), (/=#), (<=#), (>=#), (<#), (>#), - mulIntMayOflo#, addIntC#, subIntC#, - and#, or#, xor#, - ) - -import GHC.Integer.GMP.Prim ( - -- GMP-related primitives - MPZ#, - cmpInteger#, cmpIntegerInt#, - plusInteger#, minusInteger#, - timesInteger#, - quotRemInteger#, quotInteger#, remInteger#, - divModInteger#, divInteger#, modInteger#, - divExactInteger#, - gcdInteger#, gcdExtInteger#, gcdIntegerInt#, gcdInt#, - decodeDouble#, - int2Integer#, integer2Int#, word2Integer#, integer2Word#, - andInteger#, orInteger#, xorInteger#, complementInteger#, - testBitInteger#, mul2ExpInteger#, fdivQ2ExpInteger#, - powInteger#, powModInteger#, powModSecInteger#, recipModInteger#, - nextPrimeInteger#, testPrimeInteger#, - sizeInBaseInteger#, - importIntegerFromByteArray#, importIntegerFromAddr#, - exportIntegerToMutableByteArray#, exportIntegerToAddr#, - -#if SIZEOF_HSWORD == SIZEOF_LONG - plusIntegerInt#, minusIntegerInt#, - timesIntegerInt#, - divIntegerWord#, modIntegerWord#, divModIntegerWord#, - divExactIntegerWord#, - quotIntegerWord#, remIntegerWord#, quotRemIntegerWord#, -#endif - -#if WORD_SIZE_IN_BITS < 64 - int64ToInteger#, integerToInt64#, - word64ToInteger#, integerToWord64#, -#endif - ) - -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 ( - Int64#, Word64#, - int64ToWord64#, intToInt64#, - int64ToInt#, word64ToInt64#, - geInt64#, leInt64#, leWord64#, - ) -#endif - -import GHC.Classes -import GHC.Types - -default () -\end{code} - -%********************************************************* -%* * -\subsection{The @Integer@ type} -%* * -%********************************************************* - -Convenient boxed Integer PrimOps. - -\begin{code} --- | Arbitrary-precision integers. -data Integer - = S# Int# -- ^ \"small\" integers fitting into an 'Int#' - | J# Int# ByteArray# -- ^ \"big\" integers represented as GMP's @mpz_t@ structure. - -- - -- The 'Int#' field corresponds to @mpz_t@'s @_mp_size@ field, - -- which encodes the sign and the number of /limbs/ stored in the - -- 'ByteArray#' field (i.e. @mpz_t@'s @_mp_d@ field). Note: The - -- 'ByteArray#' may have been over-allocated, and thus larger - -- than the size denoted by the 'Int#' field. - -- - -- This representation tries to avoid using the GMP number - -- representation for small integers that fit into a native - -- 'Int#'. This allows to reduce (or at least defer) calling into GMP - -- for operations whose results remain in the 'Int#'-domain. - -- - -- Note: It does __not__ constitute a violation of invariants to - -- represent an integer which would fit into an 'Int#' with the - -- 'J#'-constructor. For instance, the value @0@ has (only) two valid - -- representations, either @'S#' 0#@ or @'J#' 0 _@. - --- | Construct 'Integer' value from list of 'Int's. --- --- This function is used by GHC for constructing 'Integer' literals. -mkInteger :: Bool -- ^ sign of integer ('True' if non-negative) - -> [Int] -- ^ absolute value expressed in 31 bit chunks, least significant first - - -- (ideally these would be machine-word 'Word's rather than 31-bit truncated 'Int's) - -> Integer -mkInteger nonNegative is = let abs = f is - in if nonNegative then abs else negateInteger abs - where f [] = S# 0# - f (I# i : is') = S# i `orInteger` shiftLInteger (f is') 31# - -{-# NOINLINE smallInteger #-} -smallInteger :: Int# -> Integer -smallInteger i = S# i - -{-# NOINLINE wordToInteger #-} -wordToInteger :: Word# -> Integer -wordToInteger w = if isTrue# (i >=# 0#) - then S# i - else case word2Integer# w of (# s, d #) -> J# s d - where - !i = word2Int# w - -{-# NOINLINE integerToWord #-} -integerToWord :: Integer -> Word# -integerToWord (S# i) = int2Word# i -integerToWord (J# s d) = integer2Word# s d - -#if WORD_SIZE_IN_BITS < 64 -{-# NOINLINE integerToWord64 #-} -integerToWord64 :: Integer -> Word64# -integerToWord64 (S# i) = int64ToWord64# (intToInt64# i) -integerToWord64 (J# s d) = integerToWord64# s d - -{-# NOINLINE word64ToInteger #-} -word64ToInteger :: Word64# -> Integer -word64ToInteger w = if isTrue# (w `leWord64#` int64ToWord64# (intToInt64# 0x7FFFFFFF#)) - then S# (int64ToInt# (word64ToInt64# w)) - else case word64ToInteger# w of - (# s, d #) -> J# s d - -{-# NOINLINE integerToInt64 #-} -integerToInt64 :: Integer -> Int64# -integerToInt64 (S# i) = intToInt64# i -integerToInt64 (J# s d) = integerToInt64# s d - -{-# NOINLINE int64ToInteger #-} -int64ToInteger :: Int64# -> Integer -int64ToInteger i = if isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#) && - isTrue# (i `geInt64#` intToInt64# -0x80000000#) - then smallInteger (int64ToInt# i) - else case int64ToInteger# i of - (# s, d #) -> J# s d -#endif - -integerToInt :: Integer -> Int# -{-# NOINLINE integerToInt #-} -integerToInt (S# i) = i -integerToInt (J# s d) = integer2Int# s d - --- This manually floated out constant is needed as GHC doesn't do it on its own -minIntAsBig :: Integer -minIntAsBig = case int2Integer# INT_MINBOUND of { (# s, d #) -> J# s d } - --- | Promote 'S#' to 'J#' -toBig :: Integer -> Integer -toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d } -toBig i@(J# _ _) = i - --- | Demote 'J#' to 'S#' if possible. See also 'smartJ#'. -toSmall :: Integer -> Integer -toSmall i@(S# _) = i -toSmall (J# s# mb#) = smartJ# s# mb# - - --- | Smart 'J#' constructor which tries to construct 'S#' if possible -smartJ# :: Int# -> ByteArray# -> Integer -smartJ# 0# _ = S# 0# -smartJ# 1# mb# | isTrue# (v ># 0#) = S# v - where - v = indexIntArray# mb# 0# -smartJ# (-1#) mb# | isTrue# (v <# 0#) = S# v - where - v = negateInt# (indexIntArray# mb# 0#) -smartJ# s# mb# = J# s# mb# - --- |Construct 'Integer' out of a 'MPZ#' as returned by GMP wrapper primops --- --- IMPORTANT: The 'ByteArray#' element MUST NOT be accessed unless the --- size-element indicates more than one limb! --- --- See notes at definition site of 'MPZ#' in "GHC.Integer.GMP.Prim" --- for more details. -mpzToInteger :: MPZ# -> Integer -mpzToInteger (# 0#, _, _ #) = S# 0# -mpzToInteger (# 1#, _, w# #) | isTrue# (v# >=# 0#) = S# v# - | True = case word2Integer# w# of (# _, d #) -> J# 1# d - where - v# = word2Int# w# -mpzToInteger (# -1#, _, w# #) | isTrue# (v# <=# 0#) = S# v# - | True = case word2Integer# w# of (# _, d #) -> J# -1# d - where - v# = negateInt# (word2Int# w#) -mpzToInteger (# s#, mb#, _ #) = J# s# mb# - --- | Variant of 'mpzToInteger' for pairs of 'Integer's -mpzToInteger2 :: (# MPZ#, MPZ# #) -> (# Integer, Integer #) -mpzToInteger2 (# mpz1, mpz2 #) = (# i1, i2 #) - where - !i1 = mpzToInteger mpz1 -- This use of `!` avoids creating thunks, - !i2 = mpzToInteger mpz2 -- see also Note [Use S# if possible]. - --- |Negate MPZ# -mpzNeg :: MPZ# -> MPZ# -mpzNeg (# s#, mb#, w# #) = (# negateInt# s#, mb#, w# #) - -\end{code} - -Note [Use S# if possible] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a big win to use S#, rather than J#, whenever possible. Not only -does it take less space, but (probably more important) subsequent -operations are more efficient. See Trac #8638. - -'smartJ#' is the smart constructor for J# that performs the necessary -tests. When returning a nested result, we always use smartJ# strictly, -thus - let !r = smartJ# a b in (# r, somthing_else #) -to avoid creating a thunk that is subsequently evaluated to a J#. -smartJ# itself does a pretty small amount of work, so it's not worth -thunking it. - -We call 'smartJ#' in places like quotRemInteger where a big input -might produce a small output. - -Just using smartJ# in this way has good results: - - Program Size Allocs Runtime Elapsed TotalMem --------------------------------------------------------------------------------- - gamteb +0.1% -19.0% 0.03 0.03 +0.0% - kahan +0.2% -1.2% 0.17 0.17 +0.0% - mandel +0.1% -7.7% 0.05 0.05 +0.0% - power +0.1% -40.8% -32.5% -32.5% +0.0% - symalg +0.2% -0.5% 0.01 0.01 +0.0% --------------------------------------------------------------------------------- - Min +0.0% -40.8% -32.5% -32.5% -5.1% - Max +0.2% +0.1% +2.0% +2.0% +0.0% - Geometric Mean +0.1% -1.0% -2.5% -2.5% -0.1% - -%********************************************************* -%* * -\subsection{Dividing @Integers@} -%* * -%********************************************************* - -\begin{code} --- XXX There's no good reason for us using unboxed tuples for the --- results, but we don't have Data.Tuple available. - --- Note that we don't check for divide-by-zero here. That needs --- to be done where it's used. --- (we don't have error) - -{-# NOINLINE quotRemInteger #-} -quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) -quotRemInteger (S# INT_MINBOUND) b = quotRemInteger minIntAsBig b -quotRemInteger (S# i) (S# j) = case quotRemInt# i j of - (# q, r #) -> (# S# q, S# r #) -#if SIZEOF_HSWORD == SIZEOF_LONG -quotRemInteger (J# s1 d1) (S# b) | isTrue# (b <# 0#) - = case quotRemIntegerWord# s1 d1 (int2Word# (negateInt# b)) of - (# q, r #) -> let !q' = mpzToInteger (mpzNeg q) - !r' = mpzToInteger r - in (# q', r' #) -- see also Trac #8726 -quotRemInteger (J# s1 d1) (S# b) - = mpzToInteger2 (quotRemIntegerWord# s1 d1 (int2Word# b)) -#else -quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2) -#endif -quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2 -quotRemInteger (J# s1 d1) (J# s2 d2) - = mpzToInteger2(quotRemInteger# s1 d1 s2 d2) -- See Note [Use S# if possible] - -{-# NOINLINE divModInteger #-} -divModInteger :: Integer -> Integer -> (# Integer, Integer #) -divModInteger (S# INT_MINBOUND) b = divModInteger minIntAsBig b -divModInteger (S# i) (S# j) = (# S# d, S# m #) - where - -- NB. don't inline these. (# S# (i `quotInt#` j), ... #) means - -- (# let q = i `quotInt#` j in S# q, ... #) which builds a - -- useless thunk. Placing the bindings here means they'll be - -- evaluated strictly. - !d = i `divInt#` j - !m = i `modInt#` j -#if SIZEOF_HSWORD == SIZEOF_LONG -divModInteger (J# s1 d1) (S# b) | isTrue# (b <# 0#) - = case divModIntegerWord# (negateInt# s1) d1 (int2Word# (negateInt# b)) of - (# q, r #) -> let !q' = mpzToInteger q - !r' = mpzToInteger (mpzNeg r) - in (# q', r' #) -- see also Trac #8726 -divModInteger (J# s1 d1) (S# b) - = mpzToInteger2(divModIntegerWord# s1 d1 (int2Word# b)) -#else -divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2) -#endif -divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2 -divModInteger (J# s1 d1) (J# s2 d2) = mpzToInteger2 (divModInteger# s1 d1 s2 d2) - -{-# NOINLINE remInteger #-} -remInteger :: Integer -> Integer -> Integer -remInteger (S# INT_MINBOUND) b = remInteger minIntAsBig b -remInteger (S# a) (S# b) = S# (remInt# a b) -{- Special case doesn't work, because a 1-element J# has the range - -(2^32-1) -- 2^32-1, whereas S# has the range -2^31 -- (2^31-1) -remInteger ia@(S# a) (J# sb b) - | sb ==# 1# = S# (remInt# a (word2Int# (integer2Word# sb b))) - | sb ==# -1# = S# (remInt# a (0# -# (word2Int# (integer2Word# sb b)))) - | 0# <# sb = ia - | otherwise = S# (0# -# a) --} -remInteger ia@(S# _) ib@(J# _ _) = remInteger (toBig ia) ib -#if SIZEOF_HSWORD == SIZEOF_LONG -remInteger (J# sa a) (S# b) - = mpzToInteger (remIntegerWord# sa a w) - where - w = int2Word# (if isTrue# (b <# 0#) then negateInt# b else b) -#else -remInteger i1@(J# _ _) i2@(S# _) = remInteger i1 (toBig i2) -#endif -remInteger (J# sa a) (J# sb b) - = mpzToInteger (remInteger# sa a sb b) - -{-# NOINLINE quotInteger #-} -quotInteger :: Integer -> Integer -> Integer -quotInteger (S# INT_MINBOUND) b = quotInteger minIntAsBig b -quotInteger (S# a) (S# b) = S# (quotInt# a b) -{- Special case disabled, see remInteger above -quotInteger (S# a) (J# sb b) - | sb ==# 1# = S# (quotInt# a (word2Int# (integer2Word# sb b))) - | sb ==# -1# = S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b)))) - | otherwise = S# 0 --} -quotInteger ia@(S# _) ib@(J# _ _) = quotInteger (toBig ia) ib -#if SIZEOF_HSWORD == SIZEOF_LONG -quotInteger (J# sa a) (S# b) | isTrue# (b <# 0#) - = mpzToInteger (mpzNeg (quotIntegerWord# sa a (int2Word# (negateInt# b)))) -quotInteger (J# sa a) (S# b) - = mpzToInteger (quotIntegerWord# sa a (int2Word# b)) -#else -quotInteger i1@(J# _ _) i2@(S# _) = quotInteger i1 (toBig i2) -#endif -quotInteger (J# sa a) (J# sb b) - = mpzToInteger (quotInteger# sa a sb b) - -{-# NOINLINE modInteger #-} -modInteger :: Integer -> Integer -> Integer -modInteger (S# INT_MINBOUND) b = modInteger minIntAsBig b -modInteger (S# a) (S# b) = S# (modInt# a b) -modInteger ia@(S# _) ib@(J# _ _) = modInteger (toBig ia) ib -#if SIZEOF_HSWORD == SIZEOF_LONG -modInteger (J# sa a) (S# b) | isTrue# (b <# 0#) - = mpzToInteger (mpzNeg (modIntegerWord# (negateInt# sa) a (int2Word# (negateInt# b)))) -modInteger (J# sa a) (S# b) - = mpzToInteger (modIntegerWord# sa a (int2Word# b)) -#else -modInteger i1@(J# _ _) i2@(S# _) = modInteger i1 (toBig i2) -#endif -modInteger (J# sa a) (J# sb b) - = mpzToInteger (modInteger# sa a sb b) - -{-# NOINLINE divInteger #-} -divInteger :: Integer -> Integer -> Integer -divInteger (S# INT_MINBOUND) b = divInteger minIntAsBig b -divInteger (S# a) (S# b) = S# (divInt# a b) -divInteger ia@(S# _) ib@(J# _ _) = divInteger (toBig ia) ib -#if SIZEOF_HSWORD == SIZEOF_LONG -divInteger (J# sa a) (S# b) | isTrue# (b <# 0#) - = mpzToInteger (divIntegerWord# (negateInt# sa) a (int2Word# (negateInt# b))) -divInteger (J# sa a) (S# b) - = mpzToInteger (divIntegerWord# sa a (int2Word# b)) -#else -divInteger i1@(J# _ _) i2@(S# _) = divInteger i1 (toBig i2) -#endif -divInteger (J# sa a) (J# sb b) - = mpzToInteger (divInteger# sa a sb b) -\end{code} - - - -\begin{code} --- | Compute greatest common divisor. -{-# NOINLINE gcdInteger #-} -gcdInteger :: Integer -> Integer -> Integer --- SUP: Do we really need the first two cases? -gcdInteger (S# INT_MINBOUND) b = gcdInteger minIntAsBig b -gcdInteger a (S# INT_MINBOUND) = gcdInteger a minIntAsBig -gcdInteger (S# a) (S# b) = S# (gcdInt a b) -gcdInteger ia@(S# a) ib@(J# sb b) - = if isTrue# (a ==# 0#) then absInteger ib - else if isTrue# (sb ==# 0#) then absInteger ia - else S# (gcdIntegerInt# absSb b absA) - where !absA = if isTrue# (a <# 0#) then negateInt# a else a - !absSb = if isTrue# (sb <# 0#) then negateInt# sb else sb -gcdInteger ia@(J# _ _) ib@(S# _) = gcdInteger ib ia -gcdInteger (J# sa a) (J# sb b) = mpzToInteger (gcdInteger# sa a sb b) - --- | Extended euclidean algorithm. --- --- For @/a/@ and @/b/@, compute their greatest common divisor @/g/@ --- and the coefficient @/s/@ satisfying @/a//s/ + /b//t/ = /g/@. --- --- /Since: 0.5.1.0/ -{-# NOINLINE gcdExtInteger #-} -gcdExtInteger :: Integer -> Integer -> (# Integer, Integer #) -gcdExtInteger a@(S# _) b@(S# _) = gcdExtInteger (toBig a) (toBig b) -gcdExtInteger a@(S# _) b@(J# _ _) = gcdExtInteger (toBig a) b -gcdExtInteger a@(J# _ _) b@(S# _) = gcdExtInteger a (toBig b) -gcdExtInteger (J# sa a) (J# sb b) = mpzToInteger2 (gcdExtInteger# sa a sb b) - --- | Compute least common multiple. -{-# NOINLINE lcmInteger #-} -lcmInteger :: Integer -> Integer -> Integer -lcmInteger a b = if a `eqInteger` S# 0# then S# 0# - else if b `eqInteger` S# 0# then S# 0# - else (divExact aa (gcdInteger aa ab)) `timesInteger` ab - where aa = absInteger a - ab = absInteger b - --- | Compute greatest common divisor. -gcdInt :: Int# -> Int# -> Int# -gcdInt 0# y = absInt y -gcdInt x 0# = absInt x -gcdInt x y = gcdInt# (absInt x) (absInt y) - -absInt :: Int# -> Int# -absInt x = if isTrue# (x <# 0#) then negateInt# x else x - -divExact :: Integer -> Integer -> Integer -divExact (S# INT_MINBOUND) b = divExact minIntAsBig b -divExact (S# a) (S# b) = S# (quotInt# a b) -divExact (S# a) (J# sb b) - = S# (quotInt# a (integer2Int# sb b)) -#if SIZEOF_HSWORD == SIZEOF_LONG -divExact (J# sa a) (S# b) | isTrue# (b <# 0#) - = mpzToInteger (divExactIntegerWord# (negateInt# sa) a (int2Word# (negateInt# b))) -divExact (J# sa a) (S# b) = mpzToInteger (divExactIntegerWord# sa a (int2Word# b)) -#else -divExact i1@(J# _ _) i2@(S# _) = divExact i1 (toBig i2) -#endif -divExact (J# sa a) (J# sb b) = mpzToInteger (divExactInteger# sa a sb b) -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instances for @Eq@, @Ord@} -%* * -%********************************************************* - -\begin{code} - --- | /Since: 0.5.1.0/ -{-# NOINLINE eqInteger# #-} -eqInteger# :: Integer -> Integer -> Int# -eqInteger# (S# i) (S# j) = i ==# j -eqInteger# (S# i) (J# s d) = cmpIntegerInt# s d i ==# 0# -eqInteger# (J# s d) (S# i) = cmpIntegerInt# s d i ==# 0# -eqInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0# - --- | /Since: 0.5.1.0/ -{-# NOINLINE neqInteger# #-} -neqInteger# :: Integer -> Integer -> Int# -neqInteger# (S# i) (S# j) = i /=# j -neqInteger# (S# i) (J# s d) = cmpIntegerInt# s d i /=# 0# -neqInteger# (J# s d) (S# i) = cmpIntegerInt# s d i /=# 0# -neqInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0# - -{-# 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 - ------------------------------------------------------------------------- - --- | /Since: 0.5.1.0/ -{-# NOINLINE leInteger# #-} -leInteger# :: Integer -> Integer -> Int# -leInteger# (S# i) (S# j) = i <=# j -leInteger# (J# s d) (S# i) = cmpIntegerInt# s d i <=# 0# -leInteger# (S# i) (J# s d) = cmpIntegerInt# s d i >=# 0# -leInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0# - --- | /Since: 0.5.1.0/ -{-# NOINLINE gtInteger# #-} -gtInteger# :: Integer -> Integer -> Int# -gtInteger# (S# i) (S# j) = i ># j -gtInteger# (J# s d) (S# i) = cmpIntegerInt# s d i ># 0# -gtInteger# (S# i) (J# s d) = cmpIntegerInt# s d i <# 0# -gtInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0# - --- | /Since: 0.5.1.0/ -{-# NOINLINE ltInteger# #-} -ltInteger# :: Integer -> Integer -> Int# -ltInteger# (S# i) (S# j) = i <# j -ltInteger# (J# s d) (S# i) = cmpIntegerInt# s d i <# 0# -ltInteger# (S# i) (J# s d) = cmpIntegerInt# s d i ># 0# -ltInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0# - --- | /Since: 0.5.1.0/ -{-# NOINLINE geInteger# #-} -geInteger# :: Integer -> Integer -> Int# -geInteger# (S# i) (S# j) = i >=# j -geInteger# (J# s d) (S# i) = cmpIntegerInt# s d i >=# 0# -geInteger# (S# i) (J# s d) = cmpIntegerInt# s d i <=# 0# -geInteger# (J# s1 d1) (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0# - -{-# 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) - -{-# NOINLINE compareInteger #-} -compareInteger :: Integer -> Integer -> Ordering -compareInteger (S# i) (S# j) - = if isTrue# (i ==# j) then EQ - else if isTrue# (i <=# j) then LT - else GT -compareInteger (J# s d) (S# i) - = case cmpIntegerInt# s d i of { res# -> - if isTrue# (res# <# 0#) then LT else - if isTrue# (res# ># 0#) then GT else EQ - } -compareInteger (S# i) (J# s d) - = case cmpIntegerInt# s d i of { res# -> - if isTrue# (res# ># 0#) then LT else - if isTrue# (res# <# 0#) then GT else EQ - } -compareInteger (J# s1 d1) (J# s2 d2) - = case cmpInteger# s1 d1 s2 d2 of { res# -> - if isTrue# (res# <# 0#) then LT else - if isTrue# (res# ># 0#) then GT else EQ - } - -instance Ord Integer where - (<=) = leInteger - (<) = ltInteger - (>) = gtInteger - (>=) = geInteger - compare = compareInteger -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instances for @Num@} -%* * -%********************************************************* - -\begin{code} -{-# NOINLINE absInteger #-} -absInteger :: Integer -> Integer -absInteger (S# INT_MINBOUND) = NEG_INT_MINBOUND -absInteger n@(S# i) = if isTrue# (i >=# 0#) then n else S# (negateInt# i) -absInteger n@(J# s d) = if isTrue# (s >=# 0#) then n else J# (negateInt# s) d - -{-# NOINLINE signumInteger #-} -signumInteger :: Integer -> Integer -signumInteger (S# i) = if isTrue# (i <# 0#) then S# -1# - else if isTrue# (i ==# 0#) then S# 0# - else S# 1# -signumInteger (J# s d) - = let - !cmp = cmpIntegerInt# s d 0# - in - if isTrue# (cmp ># 0#) then S# 1# - else if isTrue# (cmp ==# 0#) then S# 0# - else S# (negateInt# 1#) - -{-# NOINLINE plusInteger #-} -plusInteger :: Integer -> Integer -> Integer -plusInteger (S# i) (S# j) = case addIntC# i j of - (# r, c #) -> - if isTrue# (c ==# 0#) - then S# r -#if SIZEOF_HSWORD == SIZEOF_LONG - else case int2Integer# i of - (# s, d #) -> mpzToInteger (plusIntegerInt# s d j) -#else - else plusInteger (toBig (S# i)) (toBig (S# j)) -#endif -plusInteger i1@(J# _ _) (S# 0#) = i1 -#if SIZEOF_HSWORD == SIZEOF_LONG -plusInteger (J# s1 d1) (S# j) = mpzToInteger (plusIntegerInt# s1 d1 j) -#else -plusInteger i1@(J# _ _) i2@(S# _) = plusInteger i1 (toBig i2) -#endif -plusInteger i1@(S# _) i2@(J# _ _) = plusInteger i2 i1 -plusInteger (J# s1 d1) (J# s2 d2) = mpzToInteger (plusInteger# s1 d1 s2 d2) - -{-# NOINLINE minusInteger #-} -minusInteger :: Integer -> Integer -> Integer -minusInteger (S# i) (S# j) = case subIntC# i j of - (# r, c #) -> - if isTrue# (c ==# 0#) then S# r -#if SIZEOF_HSWORD == SIZEOF_LONG - else case int2Integer# i of - (# s, d #) -> mpzToInteger (minusIntegerInt# s d j) -#else - else minusInteger (toBig (S# i)) (toBig (S# j)) -#endif -minusInteger i1@(J# _ _) (S# 0#) = i1 -minusInteger (S# 0#) (J# s2 d2) = J# (negateInt# s2) d2 -#if SIZEOF_HSWORD == SIZEOF_LONG -minusInteger (J# s1 d1) (S# j) = mpzToInteger (minusIntegerInt# s1 d1 j) -minusInteger (S# i) (J# s2 d2) = mpzToInteger (plusIntegerInt# (negateInt# s2) d2 i) -#else -minusInteger i1@(J# _ _) i2@(S# _) = minusInteger i1 (toBig i2) -minusInteger i1@(S# _) i2@(J# _ _) = minusInteger (toBig i1) i2 -#endif -minusInteger (J# s1 d1) (J# s2 d2) = mpzToInteger (minusInteger# s1 d1 s2 d2) - -{-# NOINLINE timesInteger #-} -timesInteger :: Integer -> Integer -> Integer -timesInteger (S# i) (S# j) = if isTrue# (mulIntMayOflo# i j ==# 0#) - then S# (i *# j) -#if SIZEOF_HSWORD == SIZEOF_LONG - else case int2Integer# i of - (# s, d #) -> mpzToInteger (timesIntegerInt# s d j) -#else - else timesInteger (toBig (S# i)) (toBig (S# j)) -#endif -timesInteger (S# 0#) _ = S# 0# -timesInteger (S# -1#) i2 = negateInteger i2 -timesInteger (S# 1#) i2 = i2 -#if SIZEOF_HSWORD == SIZEOF_LONG -timesInteger (S# i1) (J# s2 d2) = mpzToInteger (timesIntegerInt# s2 d2 i1) -#else -timesInteger i1@(S# _) i2@(J# _ _) = timesInteger (toBig i1) i2 -#endif -timesInteger i1@(J# _ _) i2@(S# _) = timesInteger i2 i1 -- swap args & retry -timesInteger (J# s1 d1) (J# s2 d2) = mpzToInteger (timesInteger# s1 d1 s2 d2) - -{-# NOINLINE negateInteger #-} -negateInteger :: Integer -> Integer -negateInteger (S# INT_MINBOUND) = NEG_INT_MINBOUND -negateInteger (S# i) = S# (negateInt# i) -negateInteger (J# s d) = J# (negateInt# s) d -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ stuff for Double@} -%* * -%********************************************************* - -\begin{code} -{-# NOINLINE encodeFloatInteger #-} -encodeFloatInteger :: Integer -> Int# -> Float# -encodeFloatInteger (S# i) j = int_encodeFloat# i j -encodeFloatInteger (J# s# d#) e = encodeFloat# s# d# e - -{-# NOINLINE encodeDoubleInteger #-} -encodeDoubleInteger :: Integer -> Int# -> Double# -encodeDoubleInteger (S# i) j = int_encodeDouble# i j -encodeDoubleInteger (J# s# d#) e = encodeDouble# s# d# e - -{-# NOINLINE decodeDoubleInteger #-} -decodeDoubleInteger :: Double# -> (# Integer, Int# #) -decodeDoubleInteger d = case decodeDouble# d of - (# exp#, man# #) -> let !man = mpzToInteger man# - in (# man, exp# #) - --- previous code: doubleFromInteger n = fromInteger n = encodeFloat n 0 --- doesn't work too well, because encodeFloat is defined in --- terms of ccalls which can never be simplified away. We --- want simple literals like (fromInteger 3 :: Float) to turn --- into (F# 3.0), hence the special case for S# here. - -{-# NOINLINE doubleFromInteger #-} -doubleFromInteger :: Integer -> Double# -doubleFromInteger (S# i#) = int2Double# i# -doubleFromInteger (J# s# d#) = encodeDouble# s# d# 0# - -{-# NOINLINE floatFromInteger #-} -floatFromInteger :: Integer -> Float# -floatFromInteger (S# i#) = int2Float# i# -floatFromInteger (J# s# d#) = encodeFloat# s# d# 0# - -foreign import ccall unsafe "integer_cbits_encodeFloat" - encodeFloat# :: Int# -> ByteArray# -> Int# -> Float# -foreign import ccall unsafe "__int_encodeFloat" - int_encodeFloat# :: Int# -> Int# -> Float# - -foreign import ccall unsafe "integer_cbits_encodeDouble" - encodeDouble# :: Int# -> ByteArray# -> Int# -> Double# -foreign import ccall unsafe "__int_encodeDouble" - int_encodeDouble# :: Int# -> Int# -> Double# -\end{code} - -%********************************************************* -%* * -\subsection{The @Integer@ Bit definitions@} -%* * -%********************************************************* - -We explicitly pattern match against J# and S# in order to produce -Core that doesn't have pattern matching errors, as that would -introduce a spurious dependency to base. - -\begin{code} -{-# NOINLINE andInteger #-} -andInteger :: Integer -> Integer -> Integer -(S# x) `andInteger` (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y)) -x@(S# _) `andInteger` y@(J# _ _) = toBig x `andInteger` y -x@(J# _ _) `andInteger` y@(S# _) = x `andInteger` toBig y -(J# s1 d1) `andInteger` (J# s2 d2) = - mpzToInteger (andInteger# s1 d1 s2 d2) - -{-# NOINLINE orInteger #-} -orInteger :: Integer -> Integer -> Integer -(S# x) `orInteger` (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y)) -x@(S# _) `orInteger` y@(J# _ _) = toBig x `orInteger` y -x@(J# _ _) `orInteger` y@(S# _) = x `orInteger` toBig y -(J# s1 d1) `orInteger` (J# s2 d2) = - mpzToInteger (orInteger# s1 d1 s2 d2) - -{-# NOINLINE xorInteger #-} -xorInteger :: Integer -> Integer -> Integer -(S# x) `xorInteger` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y)) -x@(S# _) `xorInteger` y@(J# _ _) = toBig x `xorInteger` y -x@(J# _ _) `xorInteger` y@(S# _) = x `xorInteger` toBig y -(J# s1 d1) `xorInteger` (J# s2 d2) = - mpzToInteger (xorInteger# s1 d1 s2 d2) - -{-# NOINLINE complementInteger #-} -complementInteger :: Integer -> Integer -complementInteger (S# x) - = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#))) -complementInteger (J# s d) - = mpzToInteger (complementInteger# s d) - -{-# NOINLINE shiftLInteger #-} -shiftLInteger :: Integer -> Int# -> Integer -shiftLInteger j@(S# _) i = shiftLInteger (toBig j) i -shiftLInteger (J# s d) i = mpzToInteger (mul2ExpInteger# s d i) - -{-# NOINLINE shiftRInteger #-} -shiftRInteger :: Integer -> Int# -> Integer -shiftRInteger j@(S# _) i = shiftRInteger (toBig j) i -shiftRInteger (J# s d) i = mpzToInteger (fdivQ2ExpInteger# s d i) - --- | /Since: 0.5.1.0/ -{-# NOINLINE testBitInteger #-} -testBitInteger :: Integer -> Int# -> Bool -testBitInteger j@(S# _) i = testBitInteger (toBig j) i -testBitInteger (J# s d) i = isTrue# (testBitInteger# s d i /=# 0#) - --- | \"@'powInteger' /b/ /e/@\" computes base @/b/@ raised to exponent @/e/@. --- --- /Since: 0.5.1.0/ -{-# NOINLINE powInteger #-} -powInteger :: Integer -> Word# -> Integer -powInteger j@(S# _) e = powInteger (toBig j) e -powInteger (J# s d) e = mpzToInteger (powInteger# s d e) - --- | \"@'powModInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- Negative exponents are supported if an inverse modulo @/m/@ --- exists. It's advised to avoid calling this primitive with negative --- exponents unless it is guaranteed the inverse exists, as failure to --- do so will likely cause program abortion due to a divide-by-zero --- fault. See also 'recipModInteger'. --- --- /Since: 0.5.1.0/ -{-# NOINLINE powModInteger #-} -powModInteger :: Integer -> Integer -> Integer -> Integer -powModInteger (J# s1 d1) (J# s2 d2) (J# s3 d3) = - mpzToInteger (powModInteger# s1 d1 s2 d2 s3 d3) -powModInteger b e m = powModInteger (toBig b) (toBig e) (toBig m) - --- | \"@'powModSecInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. It is required that @/e/ > 0@ and --- @/m/@ is odd. --- --- This is a \"secure\" variant of 'powModInteger' using the --- @mpz_powm_sec()@ function which is designed to be resilient to side --- channel attacks and is therefore intended for cryptographic --- applications. --- --- This primitive is only available when the underlying GMP library --- supports it (GMP >= 5). Otherwise, it internally falls back to --- @'powModInteger'@, and a warning will be emitted when used. --- --- /Since: 0.5.1.0/ -{-# NOINLINE powModSecInteger #-} -powModSecInteger :: Integer -> Integer -> Integer -> Integer -powModSecInteger (J# s1 d1) (J# s2 d2) (J# s3 d3) = - mpzToInteger (powModSecInteger# s1 d1 s2 d2 s3 d3) -powModSecInteger b e m = powModSecInteger (toBig b) (toBig e) (toBig m) - -#if HAVE_SECURE_POWM == 0 -{-# WARNING powModSecInteger "The underlying GMP library does not support a secure version of powModInteger which is side-channel resistant - you need at least GMP version 5 to support this" #-} -#endif - --- | \"@'recipModInteger' /x/ /m/@\" computes the inverse of @/x/@ modulo @/m/@. If --- the inverse exists, the return value @/y/@ will satisfy @0 < /y/ < --- abs(/m/)@, otherwise the result is @0@. --- --- Note: The implementation exploits the undocumented property of --- @mpz_invert()@ to not mangle the result operand (which is initialized --- to 0) in case of non-existence of the inverse. --- --- /Since: 0.5.1.0/ -{-# NOINLINE recipModInteger #-} -recipModInteger :: Integer -> Integer -> Integer -recipModInteger j@(S# _) m@(S# _) = recipModInteger (toBig j) (toBig m) -recipModInteger j@(S# _) m@(J# _ _) = recipModInteger (toBig j) m -recipModInteger j@(J# _ _) m@(S# _) = recipModInteger j (toBig m) -recipModInteger (J# s d) (J# ms md) = mpzToInteger (recipModInteger# s d ms md) - --- | Probalistic Miller-Rabin primality test. --- --- \"@'testPrimeInteger' /n/ /k/@\" determines whether @/n/@ is prime --- and returns one of the following results: --- --- * @2#@ is returned if @/n/@ is definitely prime, --- --- * @1#@ if @/n/@ is a /probable prime/, or --- --- * @0#@ if @/n/@ is definitely not a prime. --- --- The @/k/@ argument controls how many test rounds are performed for --- determining a /probable prime/. For more details, see --- <http://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fprobab_005fprime_005fp-360 GMP documentation for `mpz_probab_prime_p()`>. --- --- /Since: 0.5.1.0/ -{-# NOINLINE testPrimeInteger #-} -testPrimeInteger :: Integer -> Int# -> Int# -testPrimeInteger j@(S# _) reps = testPrimeInteger (toBig j) reps -testPrimeInteger (J# s d) reps = testPrimeInteger# s d reps - --- | Compute next prime greater than @/n/@ probalistically. --- --- According to the GMP documentation, the underlying function --- @mpz_nextprime()@ \"uses a probabilistic algorithm to identify --- primes. For practical purposes it's adequate, the chance of a --- composite passing will be extremely small.\" --- --- /Since: 0.5.1.0/ -{-# NOINLINE nextPrimeInteger #-} -nextPrimeInteger :: Integer -> Integer -nextPrimeInteger j@(S# _) = nextPrimeInteger (toBig j) -nextPrimeInteger (J# s d) = mpzToInteger (nextPrimeInteger# s d) - --- | Compute number of digits (without sign) in given @/base/@. --- --- It's recommended to avoid calling 'sizeInBaseInteger' for small --- integers as this function would currently convert those to big --- integers in order to call @mpz_sizeinbase()@. --- --- This function wraps @mpz_sizeinbase()@ which has some --- implementation pecularities to take into account: --- --- * \"@'sizeInBaseInteger' 0 /base/ = 1@\" (see also comment in 'exportIntegerToMutableByteArray'). --- --- * This function is only defined if @/base/ >= 2#@ and @/base/ <= 256#@ --- (Note: the documentation claims that only @/base/ <= 62#@ is --- supported, however the actual implementation supports up to base 256). --- --- * If @/base/@ is a power of 2, the result will be exact. In other --- cases (e.g. for @/base/ = 10#@), the result /may/ be 1 digit too large --- sometimes. --- --- * \"@'sizeInBaseInteger' /i/ 2#@\" can be used to determine the most --- significant bit of @/i/@. --- --- /Since: 0.5.1.0/ -{-# NOINLINE sizeInBaseInteger #-} -sizeInBaseInteger :: Integer -> Int# -> Word# -sizeInBaseInteger (J# s d) b = sizeInBaseInteger# s d b -sizeInBaseInteger j@(S# _) b = sizeInBaseInteger (toBig j) b -- TODO - --- | Dump 'Integer' (without sign) to mutable byte-array in base-256 representation. --- --- The call --- --- @'exportIntegerToMutableByteArray' /i/ /mba/ /offset/ /order/@ --- --- writes --- --- * the 'Integer' @/i/@ --- --- * into the 'MutableByteArray#' @/mba/@ starting at @/offset/@ --- --- * with most significant byte first if @order@ is @1#@ or least --- significant byte first if @order@ is @-1#@, and --- --- * returns number of bytes written. --- --- Use \"@'sizeInBaseInteger' /i/ 256#@\" to compute the exact number of --- bytes written in advance for @/i/ /= 0@. In case of @/i/ == 0@, --- 'exportIntegerToMutableByteArray' will write and report zero bytes --- written, whereas 'sizeInBaseInteger' report one byte. --- --- It's recommended to avoid calling 'exportIntegerToMutableByteArray' for small --- integers as this function would currently convert those to big --- integers in order to call @mpz_export()@. --- --- /Since: 0.5.1.0/ -{-# NOINLINE exportIntegerToMutableByteArray #-} -exportIntegerToMutableByteArray :: Integer -> MutableByteArray# s -> Word# -> Int# -> State# s -> (# State# s, Word# #) -exportIntegerToMutableByteArray (J# s d) mba o e = exportIntegerToMutableByteArray# s d mba o e -exportIntegerToMutableByteArray j@(S# _) mba o e = exportIntegerToMutableByteArray (toBig j) mba o e -- TODO - --- | Dump 'Integer' (without sign) to @/addr/@ in base-256 representation. --- --- @'exportIntegerToAddr' /addr/ /o/ /e/@ --- --- See description of 'exportIntegerToMutableByteArray' for more details. --- --- /Since: 0.5.1.0/ -{-# NOINLINE exportIntegerToAddr #-} -exportIntegerToAddr :: Integer -> Addr# -> Int# -> State# s -> (# State# s, Word# #) -exportIntegerToAddr (J# s d) addr o e = exportIntegerToAddr# s d addr o e -exportIntegerToAddr j@(S# _) addr o e = exportIntegerToAddr (toBig j) addr o e -- TODO - --- | Read 'Integer' (without sign) from byte-array in base-256 representation. --- --- The call --- --- @'importIntegerFromByteArray' /ba/ /offset/ /size/ /order/@ --- --- reads --- --- * @/size/@ bytes from the 'ByteArray#' @/ba/@ starting at @/offset/@ --- --- * with most significant byte first if @/order/@ is @1#@ or least --- significant byte first if @/order/@ is @-1#@, and --- --- * returns a new 'Integer' --- --- /Since: 0.5.1.0/ -{-# NOINLINE importIntegerFromByteArray #-} -importIntegerFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> Integer -importIntegerFromByteArray ba o l e = mpzToInteger (importIntegerFromByteArray# ba o l e) - --- | Read 'Integer' (without sign) from memory location at @/addr/@ in --- base-256 representation. --- --- @'importIntegerFromAddr' /addr/ /size/ /order/@ --- --- See description of 'importIntegerFromByteArray' for more details. --- --- /Since: 0.5.1.0/ -{-# NOINLINE importIntegerFromAddr #-} -importIntegerFromAddr :: Addr# -> Word# -> Int# -> State# s -> (# State# s, Integer #) -importIntegerFromAddr addr l e st = case importIntegerFromAddr# addr l e st of - (# st', mpz #) -> let !j = mpzToInteger mpz in (# st', j #) - -\end{code} - -%********************************************************* -%* * -\subsection{The @Integer@ hashing@} -%* * -%********************************************************* - -\begin{code} --- This is used by hashUnique - --- | 'hashInteger' returns the same value as 'fromIntegral', although in --- unboxed form. It might be a reasonable hash function for 'Integer', --- given a suitable distribution of 'Integer' values. --- --- Note: 'hashInteger' is currently just an alias for 'integerToInt'. - -hashInteger :: Integer -> Int# -hashInteger = integerToInt -\end{code} - diff --git a/libraries/integer-gmp/LICENSE b/libraries/integer-gmp/LICENSE index 7ac76a6db4..0ce51e0bd0 100644 --- a/libraries/integer-gmp/LICENSE +++ b/libraries/integer-gmp/LICENSE @@ -1,62 +1,30 @@ -This library (libraries/integer(-gmp)) is derived from code from several -sources: +Copyright (c) 2014, Herbert Valerio Riedel - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - -The full text of these licenses is reproduced below. All of the -licenses are BSD-style or compatible. - ------------------------------------------------------------------------------ - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- 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. - -- Neither name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE 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 -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. - ------------------------------------------------------------------------------ - -Code derived from the document "Report on the Programming Language -Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/libraries/integer-gmp/Setup.hs b/libraries/integer-gmp/Setup.hs index 6fa548caf7..54f57d6f11 100644 --- a/libraries/integer-gmp/Setup.hs +++ b/libraries/integer-gmp/Setup.hs @@ -3,4 +3,4 @@ module Main (main) where import Distribution.Simple main :: IO () -main = defaultMain +main = defaultMainWithHooks autoconfUserHooks diff --git a/libraries/integer-gmp/cbits/alloc.c b/libraries/integer-gmp/cbits/alloc.c deleted file mode 100644 index e7111109c7..0000000000 --- a/libraries/integer-gmp/cbits/alloc.c +++ /dev/null @@ -1,97 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2012 - * - * ---------------------------------------------------------------------------*/ - -#include <string.h> - -#include "Rts.h" - -#include "gmp.h" - -void * stgAllocForGMP (size_t size_in_bytes); -void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size); -void stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED); - -static void initAllocForGMP( void ) __attribute__((constructor)); - -/* ----------------------------------------------------------------------------- - Tell GMP to use our custom heap allocation functions. - - Our allocation strategy is to use GHC heap allocations rather than malloc - and co. The heap objects we use are ByteArray#s which of course have their - usual header word or two. But gmp doesn't know about ghc heap objects and - header words. So our allocator has to make a ByteArray# and return a pointer - to its interior! When the gmp function returns we receive that interior - pointer. Then we look back a couple words to get the proper ByteArray# - pointer (which then gets returned as a ByteArray# and thus get tracked - properly by the GC). - - WARNING!! WARNING!! WARNING!! - - It is absolutely vital that this initialisation function be called before - any of the gmp functions are called. We'd still be looking back a couple - words for the ByteArray# header, but if we were accidentally using malloc - then it'd all go wrong because of course there would be no ByteArray# - header, just malloc's own internal book keeping info. To make things worse - we would not notice immediately, it'd only be when the GC comes round to - inspect things... BANG! - - > Program received signal SIGSEGV, Segmentation fault. - > [Switching to Thread 0x7f5a9ebc76f0 (LWP 17838)] - > evacuate1 (p=0x7f5a99acd2e0) at rts/sm/Evac.c:375 - > 375 switch (info->type) { - - -------------------------------------------------------------------------- */ - -static void initAllocForGMP( void ) -{ - mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP); -} - - -/* ----------------------------------------------------------------------------- - Allocation functions for GMP. - - These all use the allocate() interface - we can't have any garbage - collection going on during a gmp operation, so we use allocate() - which always succeeds. The gmp operations which might need to - allocate will ask the storage manager (via doYouWantToGC()) whether - a garbage collection is required, in case we get into a loop doing - only allocate() style allocation. - -------------------------------------------------------------------------- */ - -void * -stgAllocForGMP (size_t size_in_bytes) -{ - StgArrWords* arr; - nat data_size_in_words, total_size_in_words; - Capability *cap; - - /* round up to a whole number of words */ - data_size_in_words = ROUNDUP_BYTES_TO_WDS(size_in_bytes); - total_size_in_words = sizeofW(StgArrWords) + data_size_in_words; - - /* allocate and fill it in. */ - cap = rts_unsafeGetMyCapability(); - arr = (StgArrWords *)allocate(cap, total_size_in_words); - SET_ARR_HDR(arr, &stg_ARR_WORDS_info, ((CapabilityPublic*)cap)->r.rCCCS, size_in_bytes); - - /* and return a ptr to the goods inside the array */ - return arr->payload; -} - -void * -stgReallocForGMP (void *ptr, size_t old_size, size_t new_size) -{ - size_t min_size = old_size < new_size ? old_size : new_size; - - return memcpy(stgAllocForGMP(new_size), ptr, min_size); -} - -void -stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED) -{ - /* easy for us: the garbage collector does the dealloc'n */ -} diff --git a/libraries/integer-gmp/cbits/cbits.c b/libraries/integer-gmp/cbits/cbits.c deleted file mode 100644 index 3d53c6ba62..0000000000 --- a/libraries/integer-gmp/cbits/cbits.c +++ /dev/null @@ -1,14 +0,0 @@ - -/* We combine the C files here. - * - * There is actually a good reason for this, really! - * The alloc file contains a __attribute__((constructor)) function. We must - * have this function in the same .o file as other stuff that actually gets - * used otherwise the static linker doesn't bother to pull in the .o file - * containing the constructor function. While we could just stick them in - * the same .c file that'd be a bit annoying. So we combine them here. - * */ - -#include "alloc.c" -#include "float.c" -#include "longlong.c" diff --git a/libraries/integer-gmp/cbits/float.c b/libraries/integer-gmp/cbits/float.c deleted file mode 100644 index 73a89f577a..0000000000 --- a/libraries/integer-gmp/cbits/float.c +++ /dev/null @@ -1,249 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) Lennart Augustsson - * (c) The GHC Team, 1998-2000 - * - * Support for floating-point <-> gmp integer primitives - * - * ---------------------------------------------------------------------------*/ - -/* TODO: do we need PosixSource.h ? it lives in rts/ not public includes/ */ -/* #include "PosixSource.h" */ -#include "Rts.h" -#include "gmp.h" -#include "GmpDerivedConstants.h" - -#include <math.h> - -#define IEEE_FLOATING_POINT 1 - -/* - * Encoding and decoding Doubles. Code based on the HBC code - * (lib/fltcode.c). - */ - -#define SIZEOF_LIMB_T SIZEOF_MP_LIMB_T - -#if SIZEOF_LIMB_T == 4 -#define GMP_BASE 4294967296.0 -#define LIMBBITS_LOG_2 5 -#elif SIZEOF_LIMB_T == 8 -#define GMP_BASE 18446744073709551616.0 -#define LIMBBITS_LOG_2 6 -#else -#error Cannot cope with SIZEOF_LIMB_T -- please add definition of GMP_BASE -#endif - -#define DNBIGIT ((SIZEOF_DOUBLE+SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T) -#define FNBIGIT ((SIZEOF_FLOAT +SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T) - -#if IEEE_FLOATING_POINT -#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) -/* DMINEXP is defined in values.h on Linux (for example) */ -#define DHIGHBIT 0x00100000 -#define DMSBIT 0x80000000 - -#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1) -#define FHIGHBIT 0x00800000 -#define FMSBIT 0x80000000 -#endif - -#if defined(WORDS_BIGENDIAN) || defined(FLOAT_WORDS_BIGENDIAN) -#define L 1 -#define H 0 -#else -#define L 0 -#define H 1 -#endif - -#define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) - -StgDouble -integer_cbits_encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ -{ - StgDouble r; - const mp_limb_t *const arr = (const mp_limb_t *)ba; - I_ i; - - /* Convert MP_INT to a double; knows a lot about internal rep! */ - i = __abs(size)-1; - if ((i < 15) || (e >= 0)) /* overflows only if the final result does */ - { - /* This would cause overflow if a large MP_INT is passed, even if the - * exponent would scale it back into range, so we do it only when it's safe. */ - for(r = 0.0; i >= 0; i--) - r = (r * GMP_BASE) + arr[i]; - - } else { /* possibly more than 1024 bits in the MP_INT, but gets scaled down */ - - /* Find the first nonzero limb; normally it would be the first */ - r = 0.0; - while((i >= 0) && (r == 0.0)) - { - r = arr[i--]; - } - if (i >= 0) - r = (r * GMP_BASE) + arr[i]; -#if SIZEOF_LIMB_T < 8 - if (i > 0) - r = (r * GMP_BASE) + arr[--i]; -#endif - /* Now we have at least the 65 leading bits of the MP_INT or all of it. - * Any further bits would be rounded down, so from now on everything is - * multiplication by powers of 2. - * If i is positive, arr contains i limbs we haven't looked at yet, so - * adjust the exponent by i*8*SIZEOF_LIMB_T. Unfortunately, we must - * beware of overflow, so we can't simply add this to e. */ - if (i > 0) - { - /* first add the number of whole limbs that would be cancelled */ - i = i + e / (8 * SIZEOF_LIMB_T); - /* check for overflow */ - if ((i > 0) && ((i >> (8*sizeof(I_) - 1 - LIMBBITS_LOG_2)) > 0)) - { - /* overflow, give e a large dummy value */ - e = 2147483647; - } else { - /* no overflow, get the exact value */ - e = i * (8 * SIZEOF_LIMB_T) + (e % (8 * SIZEOF_LIMB_T)); - } - } - } - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (size < 0) - r = -r; - - return r; -} - -StgFloat -integer_cbits_encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ -{ - StgFloat r; - const mp_limb_t *arr = (const mp_limb_t *)ba; - I_ i; - - /* Convert MP_INT to a float; knows a lot about internal rep! */ - i = __abs(size)-1; - /* just in case StgFloat is a double, check sizes */ -#if SIZEOF_FLOAT == 4 - if ((i < 2) || (e >= 0)) -#else - if ((i < 15) || (e >= 0)) -#endif - { - for(r = 0.0; i >= 0; i--) - r = (r * GMP_BASE) + arr[i]; - } else { - - /* Find the first nonzero limb; normally it would be the first */ - r = 0.0; - while((i >= 0) && (r == 0.0)) - { - r = arr[i--]; - } - if (i >= 0) - r = (r * GMP_BASE) + arr[i]; -#if (SIZEOF_LIMB_T < 8) && (SIZEOF_FLOAT > 4) - if (i > 0) - r = (r * GMP_BASE) + arr[--i]; -#endif - /* Now we have enough leading bits of the MP_INT. - * Any further bits would be rounded down, so from now on everything is - * multiplication by powers of 2. - * If i is positive, arr contains i limbs we haven't looked at yet, so - * adjust the exponent by i*8*SIZEOF_LIMB_T. Unfortunately, we must - * beware of overflow, so we can't simply add this to e. */ - if (i > 0) - { - /* first add the number of whole limbs that would be cancelled */ - i = i + e / (8 * SIZEOF_LIMB_T); - /* check for overflow */ - if ((i > 0) && ((i >> (8*sizeof(I_) - 1 - LIMBBITS_LOG_2)) > 0)) - { - /* overflow, give e a large dummy value */ - e = 2147483647; - } else { - /* no overflow, get the exact value */ - e = i * (8 * SIZEOF_LIMB_T) + (e % (8 * SIZEOF_LIMB_T)); - } - } - } - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (size < 0) - r = -r; - - return r; -} - -/* This only supports IEEE floating point */ - -void -integer_cbits_decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) -{ - /* Do some bit fiddling on IEEE */ - unsigned int low, high; /* assuming 32 bit ints */ - int sign, iexp; - union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ - - ASSERT(sizeof(unsigned int ) == 4 ); - ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE); - ASSERT(sizeof(man->_mp_d[0]) == SIZEOF_LIMB_T); - ASSERT(DNBIGIT*SIZEOF_LIMB_T >= SIZEOF_DOUBLE); - - u.d = dbl; /* grab chunks of the double */ - low = u.i[L]; - high = u.i[H]; - - /* we know the MP_INT* passed in has size zero, so we realloc - no matter what. - */ - man->_mp_alloc = DNBIGIT; - - if (low == 0 && (high & ~DMSBIT) == 0) { - man->_mp_size = 0; - *exp = 0L; - } else { - man->_mp_size = DNBIGIT; - iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; - sign = high; - - high &= DHIGHBIT-1; - if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ - high |= DHIGHBIT; - else { - iexp++; - /* A denorm, normalize the mantissa */ - while (! (high & DHIGHBIT)) { - high <<= 1; - if (low & DMSBIT) - high++; - low <<= 1; - iexp--; - } - } - *exp = (I_) iexp; -#if DNBIGIT == 2 - man->_mp_d[0] = (mp_limb_t)low; - man->_mp_d[1] = (mp_limb_t)high; -#else -#if DNBIGIT == 1 - man->_mp_d[0] = ((mp_limb_t)high) << 32 | (mp_limb_t)low; -#else -#error Cannot cope with DNBIGIT -#endif -#endif - if (sign < 0) - man->_mp_size = -man->_mp_size; - } -} diff --git a/libraries/integer-gmp/cbits/gmp-wrappers.cmm b/libraries/integer-gmp/cbits/gmp-wrappers.cmm deleted file mode 100644 index a5652511bd..0000000000 --- a/libraries/integer-gmp/cbits/gmp-wrappers.cmm +++ /dev/null @@ -1,823 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2012 - * - * Out-of-line primitive operations - * - * This file contains the implementations of all the primitive - * operations ("primops") which are not expanded inline. See - * ghc/compiler/prelude/primops.txt.pp for a list of all the primops; - * this file contains code for most of those with the attribute - * out_of_line=True. - * - * Entry convention: the entry convention for a primop is that all the - * args are in Stg registers (R1, R2, etc.). This is to make writing - * the primops easier. (see compiler/codeGen/CgCallConv.hs). - * - * Return convention: results from a primop are generally returned - * using the ordinary unboxed tuple return convention. The C-- parser - * implements the RET_xxxx() macros to perform unboxed-tuple returns - * based on the prevailing return convention. - * - * This file is written in a subset of C--, extended with various - * features specific to GHC. It is compiled by GHC directly. For the - * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. - * - * ---------------------------------------------------------------------------*/ - -#include "Cmm.h" -#include "GmpDerivedConstants.h" -#include "HsIntegerGmp.h" - -import "integer-gmp" __gmpz_add; -import "integer-gmp" __gmpz_add_ui; -import "integer-gmp" __gmpz_sub; -import "integer-gmp" __gmpz_sub_ui; -import "integer-gmp" __gmpz_mul; -import "integer-gmp" __gmpz_mul_2exp; -import "integer-gmp" __gmpz_mul_si; -import "integer-gmp" __gmpz_tstbit; -import "integer-gmp" __gmpz_fdiv_q_2exp; -import "integer-gmp" __gmpz_gcd; -import "integer-gmp" __gmpz_gcdext; -import "integer-gmp" __gmpn_gcd_1; -import "integer-gmp" __gmpn_cmp; -import "integer-gmp" __gmpz_tdiv_q; -import "integer-gmp" __gmpz_tdiv_q_ui; -import "integer-gmp" __gmpz_tdiv_r; -import "integer-gmp" __gmpz_tdiv_r_ui; -import "integer-gmp" __gmpz_fdiv_q; -import "integer-gmp" __gmpz_fdiv_q_ui; -import "integer-gmp" __gmpz_fdiv_r; -import "integer-gmp" __gmpz_fdiv_r_ui; -import "integer-gmp" __gmpz_tdiv_qr; -import "integer-gmp" __gmpz_tdiv_qr_ui; -import "integer-gmp" __gmpz_fdiv_qr; -import "integer-gmp" __gmpz_fdiv_qr_ui; -import "integer-gmp" __gmpz_divexact; -import "integer-gmp" __gmpz_divexact_ui; -import "integer-gmp" __gmpz_and; -import "integer-gmp" __gmpz_xor; -import "integer-gmp" __gmpz_ior; -import "integer-gmp" __gmpz_com; -import "integer-gmp" __gmpz_pow_ui; -import "integer-gmp" __gmpz_powm; -#if HAVE_SECURE_POWM == 1 -import "integer-gmp" __gmpz_powm_sec; -#endif -import "integer-gmp" __gmpz_invert; -import "integer-gmp" __gmpz_nextprime; -import "integer-gmp" __gmpz_probab_prime_p; -import "integer-gmp" __gmpz_sizeinbase; -import "integer-gmp" __gmpz_import; -import "integer-gmp" __gmpz_export; - -import "integer-gmp" integer_cbits_decodeDouble; - -import "rts" stg_INTLIKE_closure; - -/* ----------------------------------------------------------------------------- - Arbitrary-precision Integer operations. - - There are some assumptions in this code that mp_limb_t == W_. This is - the case for all the platforms that GHC supports, currently. - -------------------------------------------------------------------------- */ - -#if SIZEOF_MP_LIMB_T != SIZEOF_W -#error "sizeof(mp_limb_t) != sizeof(W_)" -#endif - -/* This is used when a dummy pointer is needed for a ByteArray# return value - - Ideally this would be a statically allocated 'ByteArray#' - containing SIZEOF_W 0-bytes. However, since in those cases when a - dummy value is needed, the 'ByteArray#' is not supposed to be - accessed anyway, this is should be a tolerable hack. - */ -#define DUMMY_BYTE_ARR (stg_INTLIKE_closure+1) - -/* set mpz_t from Int#/ByteArray# */ -#define MP_INT_SET_FROM_BA(mp_ptr,i,ba) \ - MP_INT__mp_alloc(mp_ptr) = W_TO_INT(BYTE_ARR_WDS(ba)); \ - MP_INT__mp_size(mp_ptr) = W_TO_INT(i); \ - MP_INT__mp_d(mp_ptr) = BYTE_ARR_CTS(ba) - -/* convert mpz_t to Int#/ByteArray# return pair */ -#define MP_INT_AS_PAIR(mp_ptr) \ - TO_W_(MP_INT__mp_size(mp_ptr)),(MP_INT__mp_d(mp_ptr)-SIZEOF_StgArrWords) - -#define MP_INT_TO_BA(mp_ptr) \ - (MP_INT__mp_d(mp_ptr)-SIZEOF_StgArrWords) - -/* Size of mpz_t with single limb */ -#define SIZEOF_MP_INT_1LIMB (SIZEOF_MP_INT+WDS(1)) - -/* Initialize 0-valued single-limb mpz_t at mp_ptr */ -#define MP_INT_1LIMB_INIT0(mp_ptr) \ - MP_INT__mp_alloc(mp_ptr) = W_TO_INT(1); \ - MP_INT__mp_size(mp_ptr) = W_TO_INT(0); \ - MP_INT__mp_d(mp_ptr) = (mp_ptr+SIZEOF_MP_INT) - - -/* return mpz_t as (# s::Int#, d::ByteArray#, l1::Word# #) tuple - * - * semantics: - * - * (# 0, _, 0 #) -> value = 0 - * (# 1, _, w #) -> value = w - * (# -1, _, w #) -> value = -w - * (# s, d, 0 #) -> value = J# s d - * - */ -#define MP_INT_1LIMB_RETURN(mp_ptr) \ - CInt __mp_s; \ - __mp_s = MP_INT__mp_size(mp_ptr); \ - \ - if (__mp_s == W_TO_INT(0)) \ - { \ - return (0,DUMMY_BYTE_ARR,0); \ - } \ - \ - if (__mp_s == W_TO_INT(-1) || __mp_s == W_TO_INT(1)) \ - { \ - return (TO_W_(__mp_s),DUMMY_BYTE_ARR,W_[MP_INT__mp_d(mp_ptr)]); \ - } \ - \ - return (TO_W_(__mp_s),MP_INT_TO_BA(mp_ptr),0) - -/* Helper macro used by MP_INT_1LIMB_RETURN2 */ -#define MP_INT_1LIMB_AS_TUP3(s,d,w,mp_ptr) \ - CInt s; P_ d; W_ w; \ - s = MP_INT__mp_size(mp_ptr); \ - \ - if (s == W_TO_INT(0)) \ - { \ - d = DUMMY_BYTE_ARR; w = 0; \ - } else { \ - if (s == W_TO_INT(-1) || s == W_TO_INT(1)) \ - { \ - d = DUMMY_BYTE_ARR; w = W_[MP_INT__mp_d(mp_ptr)]; \ - } else { \ - d = MP_INT_TO_BA(mp_ptr); w = 0; \ - } \ - } - -#define MP_INT_1LIMB_RETURN2(mp_ptr1,mp_ptr2) \ - MP_INT_1LIMB_AS_TUP3(__r1s,__r1d,__r1w,mp_ptr1); \ - MP_INT_1LIMB_AS_TUP3(__r2s,__r2d,__r2w,mp_ptr2); \ - return (TO_W_(__r1s),__r1d,__r1w, TO_W_(__r2s),__r2d,__r2w) - -/* :: ByteArray# -> Word# -> Word# -> Int# -> (# Int#, ByteArray#, Word# #) */ -integer_cmm_importIntegerFromByteArrayzh (P_ ba, W_ of, W_ sz, W_ e) -{ - W_ src_ptr; - W_ mp_result; - -again: - STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB); - MAYBE_GC(again); - - mp_result = Sp - SIZEOF_MP_INT_1LIMB; - MP_INT_1LIMB_INIT0(mp_result); - - src_ptr = BYTE_ARR_CTS(ba) + of; - - ccall __gmpz_import(mp_result "ptr", sz, W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, src_ptr "ptr"); - - MP_INT_1LIMB_RETURN(mp_result); -} - -/* :: Addr# -> Word# -> Int# -> State# s -> (# State# s, Int#, ByteArray#, Word# #) */ -integer_cmm_importIntegerFromAddrzh (W_ src_ptr, W_ sz, W_ e) -{ - W_ mp_result; - -again: - STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB); - MAYBE_GC(again); - - mp_result = Sp - SIZEOF_MP_INT_1LIMB; - - MP_INT_1LIMB_INIT0(mp_result); - - ccall __gmpz_import(mp_result "ptr", sz, W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, src_ptr "ptr"); - - MP_INT_1LIMB_RETURN(mp_result); -} - -/* :: Int# -> ByteArray# -> MutableByteArray# s -> Word# -> Int# -> State# s -> (# State# s, Word# #) */ -integer_cmm_exportIntegerToMutableByteArrayzh (W_ ws1, P_ d1, P_ mba, W_ of, W_ e) -{ - W_ dst_ptr; - W_ mp_tmp; - W_ cnt_result; - -again: - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); - MAYBE_GC(again); - - mp_tmp = Sp - SIZEOF_MP_INT; - MP_INT_SET_FROM_BA(mp_tmp, ws1, d1); - - cnt_result = Sp - (SIZEOF_MP_INT + SIZEOF_W); - W_[cnt_result] = 0; - - dst_ptr = BYTE_ARR_CTS(mba) + of; - - ccall __gmpz_export(dst_ptr "ptr", cnt_result "ptr", W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, mp_tmp "ptr"); - - return (W_[cnt_result]); -} - -/* :: Int# -> ByteArray# -> Addr# -> Int# -> State# s -> (# State# s, Word# #) */ -integer_cmm_exportIntegerToAddrzh (W_ ws1, P_ d1, W_ dst_ptr, W_ e) -{ - W_ mp_tmp; - W_ cnt_result; - -again: - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); - MAYBE_GC(again); - - mp_tmp = Sp - SIZEOF_MP_INT; - MP_INT_SET_FROM_BA(mp_tmp, ws1, d1); - - cnt_result = Sp - (SIZEOF_MP_INT + SIZEOF_W); - W_[cnt_result] = 0; - - ccall __gmpz_export(dst_ptr "ptr", cnt_result "ptr", W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, mp_tmp "ptr"); - - return (W_[cnt_result]); -} - -integer_cmm_int2Integerzh (W_ val) -{ - W_ s, p; /* to avoid aliasing */ - - ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_int2Integerzh, val); - - p = Hp - SIZEOF_StgArrWords; - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(p) = SIZEOF_W; - - /* mpz_set_si is inlined here, makes things simpler */ - if (%lt(val,0)) { - s = -1; - Hp(0) = -val; - } else { - if (%gt(val,0)) { - s = 1; - Hp(0) = val; - } else { - s = 0; - } - } - - /* returns (# size :: Int#, - data :: ByteArray# - #) - */ - return (s,p); -} - -integer_cmm_word2Integerzh (W_ val) -{ - W_ s, p; /* to avoid aliasing */ - - ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_word2Integerzh, val); - - p = Hp - SIZEOF_StgArrWords; - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(p) = SIZEOF_W; - - if (val != 0) { - s = 1; - W_[Hp] = val; - } else { - s = 0; - } - - /* returns (# size :: Int#, - data :: ByteArray# #) - */ - return (s,p); -} - - -/* - * 'long long' primops for converting to/from Integers. - */ - -#if WORD_SIZE_IN_BITS < 64 - -integer_cmm_int64ToIntegerzh (L_ val) -{ - W_ hi, lo, s, neg, words_needed, p; - - neg = 0; - - hi = TO_W_(val >> 32); - lo = TO_W_(val); - - if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) ) { - // minimum is one word - words_needed = 1; - } else { - words_needed = 2; - } - - ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed)); - - p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(p) = WDS(words_needed); - - if ( %lt(hi,0) ) { - neg = 1; - lo = -lo; - if(lo == 0) { - hi = -hi; - } else { - hi = -hi - 1; - } - } - - if ( words_needed == 2 ) { - s = 2; - Hp(-1) = lo; - Hp(0) = hi; - } else { - if ( lo != 0 ) { - s = 1; - Hp(0) = lo; - } else /* val==0 */ { - s = 0; - } - } - if ( neg != 0 ) { - s = -s; - } - - /* returns (# size :: Int#, - data :: ByteArray# #) - */ - return (s,p); -} -integer_cmm_word64ToIntegerzh (L_ val) -{ - W_ hi, lo, s, words_needed, p; - - hi = TO_W_(val >> 32); - lo = TO_W_(val); - - if ( hi != 0 ) { - words_needed = 2; - } else { - words_needed = 1; - } - - ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed)); - - p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(p) = WDS(words_needed); - - if ( hi != 0 ) { - s = 2; - Hp(-1) = lo; - Hp(0) = hi; - } else { - if ( lo != 0 ) { - s = 1; - Hp(0) = lo; - } else /* val==0 */ { - s = 0; - } - } - - /* returns (# size :: Int#, - data :: ByteArray# #) - */ - return (s,p); -} - -#endif /* WORD_SIZE_IN_BITS < 64 */ - -#define GMP_TAKE2_RET1(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ ws2, P_ d2) \ -{ \ - W_ mp_tmp1; \ - W_ mp_tmp2; \ - W_ mp_result1; \ - \ -again: \ - STK_CHK_GEN_N (2*SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ - mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ - mp_result1 = Sp - 2*SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ - MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ - \ - MP_INT_1LIMB_INIT0(mp_result1); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result1 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr"); \ - \ - MP_INT_1LIMB_RETURN(mp_result1); \ -} - -#define GMP_TAKE3_RET1(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ ws2, P_ d2, W_ ws3, P_ d3) \ -{ \ - W_ mp_tmp1; \ - W_ mp_tmp2; \ - W_ mp_tmp3; \ - W_ mp_result1; \ - \ -again: \ - STK_CHK_GEN_N (3*SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ - mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ - mp_tmp3 = Sp - 3*SIZEOF_MP_INT; \ - mp_result1 = Sp - 3*SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ - MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ - MP_INT_SET_FROM_BA(mp_tmp3,ws3,d3); \ - \ - MP_INT_1LIMB_INIT0(mp_result1); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result1 "ptr", \ - mp_tmp1 "ptr", mp_tmp2 "ptr", mp_tmp3 "ptr"); \ - \ - MP_INT_1LIMB_RETURN(mp_result1); \ -} - -#define GMP_TAKE1_UL1_RET1(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ wul) \ -{ \ - W_ mp_tmp; \ - W_ mp_result; \ - \ - /* call doYouWantToGC() */ \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp = Sp - SIZEOF_MP_INT; \ - mp_result = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ - \ - MP_INT_1LIMB_INIT0(mp_result); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(wul)); \ - \ - MP_INT_1LIMB_RETURN(mp_result); \ -} - -#define GMP_TAKE1_I1_RETI1(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ wi) \ -{ \ - CInt res; \ - W_ mp_tmp; \ - \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT); \ - MAYBE_GC(again); \ - \ - mp_tmp = Sp - 1 * SIZEOF_MP_INT; \ - MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ - \ - /* Perform the operation */ \ - (res) = ccall mp_fun(mp_tmp "ptr", W_TO_INT(wi)); \ - \ - return (TO_W_(res)); \ -} - -#define GMP_TAKE1_UL1_RETI1(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ wul) \ -{ \ - CInt res; \ - W_ mp_tmp; \ - \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT); \ - MAYBE_GC(again); \ - \ - mp_tmp = Sp - 1 * SIZEOF_MP_INT; \ - MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ - \ - /* Perform the operation */ \ - (res) = ccall mp_fun(mp_tmp "ptr", W_TO_LONG(wul)); \ - \ - return (TO_W_(res)); \ -} - -#define GMP_TAKE1_RET1(name,mp_fun) \ -name (W_ ws1, P_ d1) \ -{ \ - W_ mp_tmp1; \ - W_ mp_result1; \ - \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp1 = Sp - SIZEOF_MP_INT; \ - mp_result1 = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ - \ - MP_INT_1LIMB_INIT0(mp_result1); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result1 "ptr",mp_tmp1 "ptr"); \ - \ - MP_INT_1LIMB_RETURN(mp_result1); \ -} - -#define GMP_TAKE2_RET2(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ ws2, P_ d2) \ -{ \ - W_ mp_tmp1; \ - W_ mp_tmp2; \ - W_ mp_result1; \ - W_ mp_result2; \ - \ -again: \ - STK_CHK_GEN_N (2*SIZEOF_MP_INT + 2*SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ - mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ - mp_result1 = Sp - 2*SIZEOF_MP_INT - 1*SIZEOF_MP_INT_1LIMB; \ - mp_result2 = Sp - 2*SIZEOF_MP_INT - 2*SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ - MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ - \ - MP_INT_1LIMB_INIT0(mp_result1); \ - MP_INT_1LIMB_INIT0(mp_result2); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result1 "ptr", mp_result2 "ptr", \ - mp_tmp1 "ptr", mp_tmp2 "ptr"); \ - \ - MP_INT_1LIMB_RETURN2(mp_result1, mp_result2); \ -} - -#define GMP_TAKE1_UL1_RET2(name,mp_fun) \ -name (W_ ws1, P_ d1, W_ wul2) \ -{ \ - W_ mp_tmp1; \ - W_ mp_result1; \ - W_ mp_result2; \ - \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT + 2*SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp1 = Sp - SIZEOF_MP_INT; \ - mp_result1 = Sp - SIZEOF_MP_INT - 1*SIZEOF_MP_INT_1LIMB; \ - mp_result2 = Sp - SIZEOF_MP_INT - 2*SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ - \ - MP_INT_1LIMB_INIT0(mp_result1); \ - MP_INT_1LIMB_INIT0(mp_result2); \ - \ - /* Perform the operation */ \ - ccall mp_fun(mp_result1 "ptr", mp_result2 "ptr", \ - mp_tmp1 "ptr", W_TO_LONG(wul2)); \ - \ - MP_INT_1LIMB_RETURN2(mp_result1, mp_result2); \ -} - -GMP_TAKE2_RET1(integer_cmm_plusIntegerzh, __gmpz_add) -GMP_TAKE2_RET1(integer_cmm_minusIntegerzh, __gmpz_sub) -GMP_TAKE2_RET1(integer_cmm_timesIntegerzh, __gmpz_mul) -GMP_TAKE1_UL1_RET1(integer_cmm_timesIntegerIntzh, __gmpz_mul_si) -GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh, __gmpz_gcd) -#define CMM_GMPZ_GCDEXT(g,s,a,b) __gmpz_gcdext(g,s,NULL,a,b) -GMP_TAKE2_RET2(integer_cmm_gcdExtIntegerzh, CMM_GMPZ_GCDEXT) -GMP_TAKE2_RET1(integer_cmm_quotIntegerzh, __gmpz_tdiv_q) -GMP_TAKE1_UL1_RET1(integer_cmm_quotIntegerWordzh, __gmpz_tdiv_q_ui) -GMP_TAKE2_RET1(integer_cmm_remIntegerzh, __gmpz_tdiv_r) -GMP_TAKE1_UL1_RET1(integer_cmm_remIntegerWordzh, __gmpz_tdiv_r_ui) -GMP_TAKE2_RET1(integer_cmm_divIntegerzh, __gmpz_fdiv_q) -GMP_TAKE1_UL1_RET1(integer_cmm_divIntegerWordzh, __gmpz_fdiv_q_ui) -GMP_TAKE2_RET1(integer_cmm_modIntegerzh, __gmpz_fdiv_r) -GMP_TAKE1_UL1_RET1(integer_cmm_modIntegerWordzh, __gmpz_fdiv_r_ui) -GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact) -GMP_TAKE1_UL1_RET1(integer_cmm_divExactIntegerWordzh, __gmpz_divexact_ui) -GMP_TAKE2_RET1(integer_cmm_andIntegerzh, __gmpz_and) -GMP_TAKE2_RET1(integer_cmm_orIntegerzh, __gmpz_ior) -GMP_TAKE2_RET1(integer_cmm_xorIntegerzh, __gmpz_xor) -GMP_TAKE1_UL1_RETI1(integer_cmm_testBitIntegerzh, __gmpz_tstbit) -GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh, __gmpz_mul_2exp) -GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh, __gmpz_fdiv_q_2exp) -GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com) - -GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr) -GMP_TAKE1_UL1_RET2(integer_cmm_quotRemIntegerWordzh,__gmpz_tdiv_qr_ui) -GMP_TAKE2_RET2(integer_cmm_divModIntegerzh, __gmpz_fdiv_qr) -GMP_TAKE1_UL1_RET2(integer_cmm_divModIntegerWordzh, __gmpz_fdiv_qr_ui) - -GMP_TAKE3_RET1(integer_cmm_powModIntegerzh, __gmpz_powm) -#if HAVE_SECURE_POWM == 1 -GMP_TAKE3_RET1(integer_cmm_powModSecIntegerzh, __gmpz_powm_sec) -#else -GMP_TAKE3_RET1(integer_cmm_powModSecIntegerzh, __gmpz_powm) -#endif - -GMP_TAKE2_RET1(integer_cmm_recipModIntegerzh, __gmpz_invert) -GMP_TAKE1_UL1_RET1(integer_cmm_powIntegerzh, __gmpz_pow_ui) - -GMP_TAKE1_RET1(integer_cmm_nextPrimeIntegerzh, __gmpz_nextprime) -GMP_TAKE1_I1_RETI1(integer_cmm_testPrimeIntegerzh, __gmpz_probab_prime_p) - -GMP_TAKE1_I1_RETI1(integer_cmm_sizeInBasezh, __gmpz_sizeinbase) - -integer_cmm_gcdIntzh (W_ int1, W_ int2) -{ - W_ r; - W_ mp_tmp_w; - - STK_CHK_GEN_N (1 * SIZEOF_W); - - mp_tmp_w = Sp - 1 * SIZEOF_W; - - W_[mp_tmp_w] = int1; - (r) = ccall __gmpn_gcd_1(mp_tmp_w "ptr", 1, int2); - - return (r); -} - - -integer_cmm_gcdIntegerIntzh (W_ s1, P_ d1, W_ int) -{ - W_ r; - (r) = ccall __gmpn_gcd_1 (BYTE_ARR_CTS(d1) "ptr", s1, int); - return (r); -} - - -integer_cmm_cmpIntegerIntzh (W_ usize, P_ d1, W_ v_digit) -{ - W_ vsize, u_digit; - - vsize = 0; - - // paraphrased from __gmpz_cmp_si() in the GMP sources - if (%gt(v_digit,0)) { - vsize = 1; - } else { - if (%lt(v_digit,0)) { - vsize = -1; - v_digit = -v_digit; - } - } - - if (usize != vsize) { - return (usize - vsize); - } - - if (usize == 0) { - return (0); - } - - u_digit = W_[BYTE_ARR_CTS(d1)]; - - if (u_digit == v_digit) { - return (0); - } - - if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's - return (usize); - } else { - return (-usize); - } -} - -integer_cmm_cmpIntegerzh (W_ usize, P_ d1, W_ vsize, P_ d2) -{ - W_ size, up, vp; - CInt cmp; - - // paraphrased from __gmpz_cmp() in the GMP sources - - if (usize != vsize) { - return (usize - vsize); - } - - if (usize == 0) { - return (0); - } - - if (%lt(usize,0)) { // NB. not <, which is unsigned - size = -usize; - } else { - size = usize; - } - - up = BYTE_ARR_CTS(d1); - vp = BYTE_ARR_CTS(d2); - - (cmp) = ccall __gmpn_cmp(up "ptr", vp "ptr", size); - - if (cmp == 0 :: CInt) { - return (0); - } - - if (%lt(cmp,0 :: CInt) == %lt(usize,0)) { - return (1); - } else { - return (-1); - } -} - -#define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE -#define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE) - -integer_cmm_decodeDoublezh (D_ arg) -{ - W_ mp_tmp1; - W_ mp_tmp_w; - -#if SIZEOF_DOUBLE != SIZEOF_W - W_ p; - - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); - ALLOC_PRIM (ARR_SIZE); - - mp_tmp1 = Sp - SIZEOF_MP_INT; - mp_tmp_w = Sp - SIZEOF_MP_INT - SIZEOF_W; - - /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble - where mantissa.d can be put (it does not care about the rest) */ - p = Hp - ARR_SIZE + WDS(1); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(p) = DOUBLE_MANTISSA_SIZE; - MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p); - -#else - /* When SIZEOF_DOUBLE == SIZEOF_W == 8, the result will fit into a - single 8-byte limb, and so we avoid allocating on the Heap and - use only the Stack instead */ - - STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB + SIZEOF_W); - - mp_tmp1 = Sp - SIZEOF_MP_INT_1LIMB; - mp_tmp_w = Sp - SIZEOF_MP_INT_1LIMB - SIZEOF_W; - - MP_INT_1LIMB_INIT0(mp_tmp1); -#endif - - /* Perform the operation */ - ccall integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr", arg); - - /* returns: (Int# (expn), MPZ#) */ - MP_INT_1LIMB_AS_TUP3(r1s, r1d, r1w, mp_tmp1); - - return (W_[mp_tmp_w], TO_W_(r1s), r1d, r1w); -} - -/* :: Int# -> ByteArray# -> Int# -> (# Int#, ByteArray#, Word# #) */ -#define GMPX_TAKE1_UL1_RET1(name,pos_arg_fun,neg_arg_fun) \ -name(W_ ws1, P_ d1, W_ wl) \ -{ \ - W_ mp_tmp; \ - W_ mp_result; \ - \ -again: \ - STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ - MAYBE_GC(again); \ - \ - mp_tmp = Sp - SIZEOF_MP_INT; \ - mp_result = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ - \ - MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ - \ - MP_INT_1LIMB_INIT0(mp_result); \ - \ - if(%lt(wl,0)) { \ - ccall neg_arg_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(-wl)); \ - } else { \ - ccall pos_arg_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(wl)); \ - } \ - \ - MP_INT_1LIMB_RETURN(mp_result); \ -} - -/* NB: We need both primitives as we can't express 'minusIntegerInt#' - in terms of 'plusIntegerInt#' for @minBound :: Int@ */ -GMPX_TAKE1_UL1_RET1(integer_cmm_plusIntegerIntzh,__gmpz_add_ui,__gmpz_sub_ui) -GMPX_TAKE1_UL1_RET1(integer_cmm_minusIntegerIntzh,__gmpz_sub_ui,__gmpz_add_ui) diff --git a/libraries/integer-gmp/cbits/longlong.c b/libraries/integer-gmp/cbits/longlong.c deleted file mode 100644 index 1bf101819c..0000000000 --- a/libraries/integer-gmp/cbits/longlong.c +++ /dev/null @@ -1,66 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.4 2002/12/13 14:23:42 simonmar Exp $ - * - * (c) The GHC Team, 1998-1999 - * - * Primitive operations over (64-bit) long longs - * (only used on 32-bit platforms.) - * - * ---------------------------------------------------------------------------*/ - - -/* -Primitive Integer conversions to/from HsInt64 and HsWord64s. -N.B. These are not primops! - -Instead of going the normal (boring) route of making the list -of primitive operations even longer to cope with operations -over 64-bit entities, we implement them instead 'out-of-line'. - -The primitive ops get their own routine (in C) that implements -the operation, requiring the caller to _ccall_ out. This has -performance implications of course, but we currently don't -expect intensive use of either Int64 or Word64 types. -*/ - -#include "Rts.h" - -#if WORD_SIZE_IN_BITS < 64 - -HsWord64 hs_integerToWord64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - HsInt s; - HsWord64 res; - d = (mp_limb_t *)da; - s = sa; - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -(HsWord64)d[0]; break; - default: - res = (HsWord64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -HsInt64 hs_integerToInt64 (HsInt sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - HsInt s; - HsInt64 res; - d = (mp_limb_t *)da; - s = (sa); - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -(HsInt64)d[0]; break; - default: - res = (HsInt64)d[0] + ((HsWord64)d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -#endif /* WORD_SIZE_IN_BITS < 64 */ diff --git a/libraries/integer-gmp/cbits/wrappers.c b/libraries/integer-gmp/cbits/wrappers.c new file mode 100644 index 0000000000..1736efdc5c --- /dev/null +++ b/libraries/integer-gmp/cbits/wrappers.c @@ -0,0 +1,832 @@ +/* + * `integer-gmp` GMP FFI wrappers + * + * Copyright (c) 2014, Herbert Valerio Riedel <hvr@gnu.org> + * + * BSD3 licensed, see ../LICENSE file for details + * + */ + +#define _ISOC99_SOURCE + +#include "HsFFI.h" +#include "MachDeps.h" + +#include <assert.h> +#include <stdbool.h> +#include <stdlib.h> +#include <stdint.h> +#include <string.h> +#include <math.h> +#include <float.h> +#include <stdio.h> + +#include <gmp.h> + + +// GMP 4.x compatibility +#if !defined(__GNU_MP_VERSION) +# error __GNU_MP_VERSION not defined +#elif __GNU_MP_VERSION < 4 +# error need GMP 4.0 or later +#elif __GNU_MP_VERSION < 5 +typedef unsigned long int mp_bitcnt_t; +#endif + +#if (GMP_NUMB_BITS) != (GMP_LIMB_BITS) +# error GMP_NUMB_BITS != GMP_LIMB_BITS not supported +#endif + +#if (WORD_SIZE_IN_BITS) != (GMP_LIMB_BITS) +# error WORD_SIZE_IN_BITS != GMP_LIMB_BITS not supported +#endif + +// sanity check +#if (SIZEOF_HSWORD*8) != WORD_SIZE_IN_BITS +# error (SIZEOF_HSWORD*8) != WORD_SIZE_IN_BITS +#endif + +// Turn a (const) {xp,xn} pair into static initializer +#define CONST_MPZ_INIT(xp,xn) \ + {{ ._mp_alloc = 0, ._mp_size = (xn), ._mp_d = (mp_limb_t*)(xp) }} + +// Test if {sp,sn} represents a zero value +static inline int +mp_limb_zero_p(const mp_limb_t sp[], mp_size_t sn) +{ + return !sn || ((sn == 1 || sn == -1) && !sp[0]); +} + +static inline mp_size_t +mp_size_abs(const mp_size_t x) +{ + return x>=0 ? x : -x; +} + +static inline mp_size_t +mp_size_min(const mp_size_t x, const mp_size_t y) +{ + return x<y ? x : y; +} + +static inline mp_size_t +mp_size_minabs(const mp_size_t x, const mp_size_t y) +{ + return mp_size_min(mp_size_abs(x), mp_size_abs(y)); +} + +/* Perform arithmetic right shift on MPNs (multi-precision naturals) + * + * pre-conditions: + * - 0 < count < sn*GMP_NUMB_BITS + * - rn = sn - floor(count / GMP_NUMB_BITS) + * - sn > 0 + * + * write {sp,sn} right-shifted by count bits into {rp,rn} + * + * return value: most-significant limb stored in {rp,rn} result + */ +mp_limb_t +integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], mp_size_t sn, + mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn = sn - limb_shift; + + if (bit_shift) + mpn_rshift(rp, &sp[limb_shift], rn, bit_shift); + else + memcpy(rp, &sp[limb_shift], rn*sizeof(mp_limb_t)); + + return rp[rn-1]; +} + +/* Twos-complement version of 'integer_gmp_mpn_rshift' for performing + * arithmetic right shifts on "negative" MPNs. + * + * Same pre-conditions as 'integer_gmp_mpn_rshift' + * + * This variant is needed to operate on MPNs interpreted as negative + * numbers, which require "rounding" towards minus infinity iff a + * non-zero bit is shifted out. + */ +mp_limb_t +integer_gmp_mpn_rshift_2c (mp_limb_t rp[], const mp_limb_t sp[], + const mp_size_t sn, const mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn = sn - limb_shift; + + // whether non-zero bits were shifted out + bool nz_shift_out = false; + + if (bit_shift) { + if (mpn_rshift(rp, &sp[limb_shift], rn, bit_shift)) + nz_shift_out = true; + } else + memcpy(rp, &sp[limb_shift], rn*sizeof(mp_limb_t)); + + if (!nz_shift_out) + for (unsigned i = 0; i < limb_shift; i++) + if (sp[i]) { + nz_shift_out = true; + break; + } + + // round if non-zero bits were shifted out + if (nz_shift_out) + if (mpn_add_1(rp, rp, rn, 1)) + abort(); /* should never happen */ + + return rp[rn-1]; +} + +/* Perform left-shift operation on MPN + * + * pre-conditions: + * - 0 < count + * - rn = sn + ceil(count / GMP_NUMB_BITS) + * - sn > 0 + * + * return value: most-significant limb stored in {rp,rn} result + */ +mp_limb_t +integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], + const mp_size_t sn, const mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn0 = sn + limb_shift; + + memset(rp, 0, limb_shift*sizeof(mp_limb_t)); + if (bit_shift) { + const mp_limb_t msl = mpn_lshift(&rp[limb_shift], sp, sn, bit_shift); + rp[rn0] = msl; + return msl; + } else { + memcpy(&rp[limb_shift], sp, sn*sizeof(mp_limb_t)); + return rp[rn0-1]; + } +} + +/* Convert bignum to a `double`, truncating if necessary + * (i.e. rounding towards zero). + * + * sign of mp_size_t argument controls sign of converted double + */ +HsDouble +integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn, + const HsInt exponent) +{ + if (mp_limb_zero_p(sp, sn)) + return 0.0; + + const mpz_t mpz = CONST_MPZ_INIT(sp, sn); + + if (!exponent) + return mpz_get_d(mpz); + + long e = 0; + double d = mpz_get_d_2exp (&e, mpz); + + // TODO: over/underflow handling? + return ldexp(d, e+exponent); +} + +mp_limb_t +integer_gmp_gcd_word(const mp_limb_t x, const mp_limb_t y) +{ + if (!x) return y; + if (!y) return x; + + return mpn_gcd_1(&x, 1, y); +} + +mp_limb_t +integer_gmp_mpn_gcd_1(const mp_limb_t x[], const mp_size_t xn, + const mp_limb_t y) +{ + assert (xn > 0); + assert (xn == 1 || y != 0); + + if (xn == 1) + return integer_gmp_gcd_word(x[0], y); + + return mpn_gcd_1(x, xn, y); +} + + +mp_size_t +integer_gmp_mpn_gcd(mp_limb_t r[], + const mp_limb_t x0[], const mp_size_t xn, + const mp_limb_t y0[], const mp_size_t yn) +{ + assert (xn >= yn); + assert (yn > 0); + assert (xn == yn || yn > 1 || y0[0] != 0); + /* post-condition: rn <= xn */ + + if (yn == 1) { + if (y0[0]) { + r[0] = integer_gmp_mpn_gcd_1(x0, xn, y0[0]); + return 1; + } else { /* {y0,yn} == 0 */ + assert (xn==yn); /* NB: redundant assertion */ + memcpy(r, x0, xn*sizeof(mp_limb_t)); + return xn; + } + } else { + // mpn_gcd() seems to require non-trivial normalization of its + // input arguments (which does not seem to be documented anywhere, + // see source of mpz_gcd() for more details), so we resort to just + // use mpz_gcd() which does the tiresome normalization for us at + // the cost of a few additional temporary buffer allocations in + // C-land. + + const mpz_t op1 = CONST_MPZ_INIT(x0, xn); + const mpz_t op2 = CONST_MPZ_INIT(y0, yn); + + mpz_t rop; + mpz_init (rop); + + mpz_gcd(rop, op1, op2); + + const mp_size_t rn = rop[0]._mp_size; + assert(rn > 0); + assert(rn <= xn); + + /* the allocation/memcpy of the result can be neglectable since + mpz_gcd() already has to allocate other temporary buffers + anyway */ + memcpy(r, rop[0]._mp_d, rn*sizeof(mp_limb_t)); + + mpz_clear(rop); + + return rn; + } +} + +/* wraps mpz_gcdext() + * + * Set g to the greatest common divisor of x and y, and in addition + * set s and t to coefficients satisfying x*s + y*t = g. + * + * The {gp,gn} array is zero-padded (as otherwise 'gn' can't be + * reconstructed). + * + * g must have space for exactly gn=min(xn,yn) limbs. + * s must have space for at least xn limbs. + * + * return value: signed 'sn' of {sp,sn} + */ +mp_size_t +integer_gmp_gcdext(mp_limb_t s0[], mp_limb_t g0[], + const mp_limb_t x0[], const mp_size_t xn, + const mp_limb_t y0[], const mp_size_t yn) +{ + const mp_size_t gn0 = mp_size_minabs(xn, yn); + const mpz_t x = CONST_MPZ_INIT(x0, mp_limb_zero_p(x0,xn) ? 0 : xn); + const mpz_t y = CONST_MPZ_INIT(y0, mp_limb_zero_p(y0,yn) ? 0 : yn); + + mpz_t g, s; + mpz_init (g); + mpz_init (s); + + mpz_gcdext (g, s, NULL, x, y); + + const mp_size_t gn = g[0]._mp_size; + assert(0 <= gn && gn <= gn0); + memset(g0, 0, gn0*sizeof(mp_limb_t)); + memcpy(g0, g[0]._mp_d, gn*sizeof(mp_limb_t)); + mpz_clear (g); + + const mp_size_t ssn = s[0]._mp_size; + const mp_size_t sn = mp_size_abs(ssn); + assert(sn <= xn); + memcpy(s0, s[0]._mp_d, sn*sizeof(mp_limb_t)); + mpz_clear (s); + + if (!sn) { + s0[0] = 0; + return 1; + } + + return ssn; +} + +/* Truncating (i.e. rounded towards zero) integer division-quotient of MPN */ +void +integer_gmp_mpn_tdiv_q (mp_limb_t q[], + const mp_limb_t n[], const mp_size_t nn, + const mp_limb_t d[], const mp_size_t dn) +{ + /* qn = 1+nn-dn; rn = dn */ + assert(nn>=dn); + + if (dn > 128) { + // Use temporary heap allocated throw-away buffer for MPNs larger + // than 1KiB for 64bit-sized limbs (larger than 512bytes for + // 32bit-sized limbs) + mp_limb_t *const r = malloc(dn*sizeof(mp_limb_t)); + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + free (r); + } else { // allocate smaller arrays on the stack + mp_limb_t r[dn]; + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + } +} + +/* Truncating (i.e. rounded towards zero) integer division-remainder of MPNs */ +void +integer_gmp_mpn_tdiv_r (mp_limb_t r[], + const mp_limb_t n[], const mp_size_t nn, + const mp_limb_t d[], const mp_size_t dn) +{ + /* qn = 1+nn-dn; rn = dn */ + assert(nn>=dn); + const mp_size_t qn = 1+nn-dn; + + if (qn > 128) { + // Use temporary heap allocated throw-away buffer for MPNs larger + // than 1KiB for 64bit-sized limbs (larger than 512bytes for + // 32bit-sized limbs) + mp_limb_t *const q = malloc(qn*sizeof(mp_limb_t)); + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + free (q); + } else { // allocate smaller arrays on the stack + mp_limb_t q[qn]; + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + } +} + + +/* Wraps GMP's 'mpz_sizeinbase()' function */ +HsWord +integer_gmp_mpn_sizeinbase(const mp_limb_t s[], const mp_size_t sn, + const HsInt base) +{ + assert (2 <= base && base <= 256); + + if (mp_limb_zero_p(s,sn)) return 1; + + const mpz_t zs = CONST_MPZ_INIT(s, sn); + + return mpz_sizeinbase(zs, base); +} + +/* Single-limb version of 'integer_gmp_mpn_sizeinbase()' */ +HsWord +integer_gmp_mpn_sizeinbase1(const mp_limb_t s, const HsInt base) +{ + return s ? integer_gmp_mpn_sizeinbase(&s, 1, base) : 1; +} + +/* Wrapper around GMP's 'mpz_export()' function */ +HsWord +integer_gmp_mpn_export(const mp_limb_t s[], const mp_size_t sn, + void *destptr, HsInt destofs, HsInt msbf) +{ + /* TODO: implement w/o GMP, c.f. 'integer_gmp_mpn_import()' */ + assert (msbf == 0 || msbf == 1); + + if (mp_limb_zero_p(s,sn)) return 0; + + const mpz_t zs = CONST_MPZ_INIT(s, sn); + + size_t written = 0; + + // mpz_export (void *rop, size_t *countp, int order, size_t size, int endian, + // size_t nails, const mpz_t op) + (void) mpz_export(((char *)destptr)+destofs, &written, !msbf ? -1 : 1, + /* size */ 1, /* endian */ 0, /* nails */ 0, zs); + + return written; +} + +/* Single-limb version of 'integer_gmp_mpn_export()' */ +HsWord +integer_gmp_mpn_export1(const mp_limb_t s, + void *destptr, const HsInt destofs, const HsInt msbf) +{ + /* TODO: implement w/o GMP */ + return integer_gmp_mpn_export(&s, 1, destptr, destofs, msbf); +} + +/* Import single limb from memory location + * + * We can't use GMP's 'mpz_import()' + */ +HsWord +integer_gmp_mpn_import1(const uint8_t *srcptr, const HsWord srcofs, + const HsWord srclen, const HsInt msbf) +{ + assert (msbf == 0 || msbf == 1); + assert (srclen <= SIZEOF_HSWORD); + + srcptr += srcofs; + + HsWord result = 0; + + if (msbf) + for (unsigned i = 0; i < srclen; ++i) + result |= (HsWord)srcptr[i] << ((srclen-i-1)*8); + else // lsbf + for (unsigned i = 0; i < srclen; ++i) + result |= (HsWord)srcptr[i] << (i*8); + + return result; +} + +/* import into mp_limb_t[] from memory location */ +void +integer_gmp_mpn_import(mp_limb_t * restrict r, const uint8_t * restrict srcptr, + const HsWord srcofs, const HsWord srclen, + const HsInt msbf) +{ + assert (msbf == 0 || msbf == 1); + + srcptr += srcofs; + + const unsigned limb_cnt_rem = srclen % SIZEOF_HSWORD; + const mp_size_t limb_cnt = srclen / SIZEOF_HSWORD; + + if (msbf) { + if (limb_cnt_rem) { // partial limb + r[limb_cnt] = integer_gmp_mpn_import1(srcptr, 0, limb_cnt_rem, 1); + srcptr += limb_cnt_rem; + } + + for (unsigned ri = 0; ri < limb_cnt; ++ri) { + r[limb_cnt-ri-1] = integer_gmp_mpn_import1(srcptr, 0, SIZEOF_HSWORD, 1); + srcptr += SIZEOF_HSWORD; + } + } else { // lsbf + for (unsigned ri = 0; ri < limb_cnt; ++ri) { + r[ri] = integer_gmp_mpn_import1(srcptr, 0, SIZEOF_HSWORD, 0); + srcptr += SIZEOF_HSWORD; + } + + if (limb_cnt_rem) // partial limb + r[limb_cnt] = integer_gmp_mpn_import1(srcptr, 0, limb_cnt_rem, 0); + } +} + +/* Scan for first non-zero byte starting at srcptr[srcofs], ending at + * srcptr[srcofs+srclen-1]; + * + * If no non-zero byte found, returns srcofs+srclen; otherwise returns + * index of srcptr where first non-zero byte was found. + */ +HsWord +integer_gmp_scan_nzbyte(const uint8_t *srcptr, + const HsWord srcofs, const HsWord srclen) +{ + // TODO: consider implementing this function in Haskell-land + srcptr += srcofs; + + for (unsigned i = 0; i < srclen; ++i) + if (srcptr[i]) + return srcofs+i; + + return srcofs+srclen; +} + +/* Reverse scan for non-zero byte + * starting at srcptr[srcofs+srclen-1], ending at srcptr[srcofs]. + * + * Returns new length srclen1 such that srcptr[srcofs+i] == 0 for + * srclen1 <= i < srclen. + */ +HsWord +integer_gmp_rscan_nzbyte(const uint8_t *srcptr, + const HsWord srcofs, const HsWord srclen) +{ + // TODO: consider implementing this function in Haskell-land + srcptr += srcofs; + + for (unsigned i = srclen; i > 0; --i) + if (srcptr[i-1]) + return i; + + return 0; +} + +/* wrapper around mpz_probab_prime_p */ +HsInt +integer_gmp_test_prime(const mp_limb_t s[], const mp_size_t sn, const HsInt rep) +{ + if (mp_limb_zero_p(s,sn)) return 0; + + const mpz_t sz = CONST_MPZ_INIT(s, sn); + + // int mpz_probab_prime_p (const mpz_t n, int reps) + return mpz_probab_prime_p(sz, rep); +} + +/* wrapper around mpz_probab_prime_p */ +HsInt +integer_gmp_test_prime1(const mp_limb_t limb, const HsInt rep) +{ + if (!limb) return 0; + + return integer_gmp_test_prime(&limb, 1, rep); +} + +/* wrapper around mpz_nextprime() + * + * Stores next prime (relative to {sp,sn}) in {rp,sn}. + * Return value is most significant limb of {rp,sn+1}. + */ +mp_limb_t +integer_gmp_next_prime(mp_limb_t rp[], const mp_limb_t sp[], + const mp_size_t sn) +{ + assert (sn>=0); + + if (!sn) return 2; + if (sn == 1 && sp[0] < 2) { + rp[0] = 2; + return 0; + } + + const mpz_t op = CONST_MPZ_INIT(sp, sn); + + mpz_t rop; + mpz_init (rop); + mpz_nextprime (rop, op); + + const mp_size_t rn = rop[0]._mp_size; + + // copy result into {rp,sn} buffer + assert (rn == sn || rn == sn+1); + memcpy(rp, rop[0]._mp_d, sn*sizeof(mp_limb_t)); + const mp_limb_t result = rn>sn ? rop[0]._mp_d[sn] : 0; + + mpz_clear (rop); + + return result; +} + +/* wrapper around mpz_nextprime() + * + * returns next prime modulo 2^GMP_LIMB_BITS + */ +mp_limb_t +integer_gmp_next_prime1(const mp_limb_t limb) +{ + if (limb < 2) return 2; + + const mpz_t op = CONST_MPZ_INIT(&limb, 1); + + mpz_t rop; + mpz_init (rop); + mpz_nextprime (rop, op); + assert (rop[0]._mp_size > 0); + const mp_limb_t result = rop[0]._mp_d[0]; + mpz_clear (rop); + + return result; +} + +/* wrapper around mpz_powm() + * + * Store '(B^E) mod M' in {rp,rn} + * + * rp must have allocated mn limbs; This function's return value is + * the actual number rn (0 < rn <= mn) of limbs written to the rp limb-array. + * + * bn and en are allowed to be negative to denote negative numbers + */ +mp_size_t +integer_gmp_powm(mp_limb_t rp[], // result + const mp_limb_t bp[], const mp_size_t bn, // base + const mp_limb_t ep[], const mp_size_t en, // exponent + const mp_limb_t mp[], const mp_size_t mn) // mod +{ + assert(!mp_limb_zero_p(mp,mn)); + + if ((mn == 1 || mn == -1) && mp[0] == 1) { + rp[0] = 0; + return 1; + } + + if (mp_limb_zero_p(ep,en)) { + rp[0] = 1; + return 1; + } + + const mpz_t b = CONST_MPZ_INIT(bp, mp_limb_zero_p(bp,bn) ? 0 : bn); + const mpz_t e = CONST_MPZ_INIT(ep, mp_limb_zero_p(ep,en) ? 0 : en); + const mpz_t m = CONST_MPZ_INIT(mp, mn); + + mpz_t r; + mpz_init (r); + + mpz_powm(r, b, e, m); + + const mp_size_t rn = r[0]._mp_size; + + if (rn) { + assert(0 < rn && rn <= mn); + memcpy(rp, r[0]._mp_d, rn*sizeof(mp_limb_t)); + } + + mpz_clear (r); + + if (!rn) { + rp[0] = 0; + return 1; + } + + return rn; +} + +/* version of integer_gmp_powm() for single-limb moduli */ +mp_limb_t +integer_gmp_powm1(const mp_limb_t bp[], const mp_size_t bn, // base + const mp_limb_t ep[], const mp_size_t en, // exponent + const mp_limb_t m0) // mod +{ + assert(m0); + + if (m0==1) return 0; + if (mp_limb_zero_p(ep,en)) return 1; + + const mpz_t b = CONST_MPZ_INIT(bp, mp_limb_zero_p(bp,bn) ? 0 : bn); + const mpz_t e = CONST_MPZ_INIT(ep, en); + const mpz_t m = CONST_MPZ_INIT(&m0, !!m0); + + mpz_t r; + mpz_init (r); + mpz_powm(r, b, e, m); + + assert(r[0]._mp_size == 0 || r[0]._mp_size == 1); + const mp_limb_t result = r[0]._mp_size ? r[0]._mp_d[0] : 0; + + mpz_clear (r); + + return result; +} + +/* version of integer_gmp_powm() for single-limb arguments */ +mp_limb_t +integer_gmp_powm_word(const mp_limb_t b0, // base + const mp_limb_t e0, // exponent + const mp_limb_t m0) // mod +{ + return integer_gmp_powm1(&b0, !!b0, &e0, !!e0, m0); +} + + +/* wrapper around mpz_invert() + * + * Store '(1/X) mod abs(M)' in {rp,rn} + * + * rp must have allocated mn limbs; This function's return value is + * the actual number rn (0 < rn <= mn) of limbs written to the rp limb-array. + * + * Returns 0 if inverse does not exist. + */ +mp_size_t +integer_gmp_invert(mp_limb_t rp[], // result + const mp_limb_t xp[], const mp_size_t xn, // base + const mp_limb_t mp[], const mp_size_t mn) // mod +{ + if (mp_limb_zero_p(xp,xn) + || mp_limb_zero_p(mp,mn) + || ((mn == 1 || mn == -1) && mp[0] == 1)) { + rp[0] = 0; + return 1; + } + + const mpz_t x = CONST_MPZ_INIT(xp, xn); + const mpz_t m = CONST_MPZ_INIT(mp, mn); + + mpz_t r; + mpz_init (r); + + const int inv_exists = mpz_invert(r, x, m); + + const mp_size_t rn = inv_exists ? r[0]._mp_size : 0; + + if (rn) { + assert(0 < rn && rn <= mn); + memcpy(rp, r[0]._mp_d, rn*sizeof(mp_limb_t)); + } + + mpz_clear (r); + + if (!rn) { + rp[0] = 0; + return 1; + } + + return rn; +} + + +/* Version of integer_gmp_invert() operating on single limbs */ +mp_limb_t +integer_gmp_invert_word(const mp_limb_t x0, const mp_limb_t m0) +{ + if (!x0 || m0<=1) return 0; + if (x0 == 1) return 1; + + const mpz_t x = CONST_MPZ_INIT(&x0, 1); + const mpz_t m = CONST_MPZ_INIT(&m0, 1); + + mpz_t r; + mpz_init (r); + + const int inv_exists = mpz_invert(r, x, m); + const mp_size_t rn = inv_exists ? r[0]._mp_size : 0; + + assert (rn == 0 || rn == 1); + const mp_limb_t r0 = rn ? r[0]._mp_d[0] : 0; + + mpz_clear (r); + + return r0; +} + + +/* Wrappers for GMP 4.x compat + * + * In GMP 5.0 the following operations were added: + * + * mpn_sqr, mpn_and_n, mpn_ior_n, mpn_xor_n, mpn_nand_n, mpn_nior_n, + * mpn_xnor_n, mpn_andn_n, mpn_iorn_n, mpn_com, mpn_neg, mpn_copyi, + * mpn_copyd, mpn_zero + * + * We use some of those, but for GMP 4.x compatibility we need to + * emulate those (while incurring some overhead). + */ +#if __GNU_MP_VERSION < 5 + +#define MPN_LOGIC_OP_WRAPPER(MPN_WRAPPER, MPZ_OP) \ +void \ +MPN_WRAPPER(mp_limb_t *rp, const mp_limb_t *s1p, \ + const mp_limb_t *s2p, mp_size_t n) \ +{ \ + assert(n > 0); \ + \ + const mpz_t s1 = CONST_MPZ_INIT(s1p, n); \ + const mpz_t s2 = CONST_MPZ_INIT(s2p, n); \ + \ + mpz_t r; \ + mpz_init (r); \ + MPZ_OP (r, s1, s2); \ + \ + const mp_size_t rn = r[0]._mp_size; \ + memset (rp, 0, n*sizeof(mp_limb_t)); \ + memcpy (rp, r[0]._mp_d, mp_size_minabs(rn,n)*sizeof(mp_limb_t)); \ + \ + mpz_clear (r); \ +} + +static void +__mpz_andn(mpz_t r, const mpz_t s1, const mpz_t s2) +{ + mpz_t s2c; + mpz_init (s2c); + mpz_com (s2c, s2); + mpz_and (r, s1, s2c); + mpz_clear (s2c); +} + +MPN_LOGIC_OP_WRAPPER(integer_gmp_mpn_and_n, mpz_and) +MPN_LOGIC_OP_WRAPPER(integer_gmp_mpn_andn_n, __mpz_andn) +MPN_LOGIC_OP_WRAPPER(integer_gmp_mpn_ior_n, mpz_ior) +MPN_LOGIC_OP_WRAPPER(integer_gmp_mpn_xor_n, mpz_xor) + +#else /* __GNU_MP_VERSION >= 5 */ +void +integer_gmp_mpn_and_n(mp_limb_t *rp, const mp_limb_t *s1p, + const mp_limb_t *s2p, mp_size_t n) +{ + mpn_and_n(rp, s1p, s2p, n); +} + +void +integer_gmp_mpn_andn_n(mp_limb_t *rp, const mp_limb_t *s1p, + const mp_limb_t *s2p, mp_size_t n) +{ + mpn_andn_n(rp, s1p, s2p, n); +} + +void +integer_gmp_mpn_ior_n(mp_limb_t *rp, const mp_limb_t *s1p, + const mp_limb_t *s2p, mp_size_t n) +{ + mpn_ior_n(rp, s1p, s2p, n); +} + +void +integer_gmp_mpn_xor_n(mp_limb_t *rp, const mp_limb_t *s1p, + const mp_limb_t *s2p, mp_size_t n) +{ + mpn_xor_n(rp, s1p, s2p, n); +} +#endif diff --git a/libraries/integer-gmp/changelog.md b/libraries/integer-gmp/changelog.md index 28e662bcea..cb55b80e95 100644 --- a/libraries/integer-gmp/changelog.md +++ b/libraries/integer-gmp/changelog.md @@ -1,5 +1,12 @@ # Changelog for [`integer-gmp` package](http://hackage.haskell.org/package/integer-gmp) +## 1.0.0.0 *Mar 2015* + + * Bundled with GHC 7.10.1 + + * Complete rewrite of `integer-gmp`. For more details, see + https://ghc.haskell.org/trac/ghc/wiki/Design/IntegerGmp2 + ## 0.5.1.0 *Feb 2014* * Bundled with GHC 7.8.1 diff --git a/libraries/integer-gmp/configure.ac b/libraries/integer-gmp/configure.ac index d5eb3b23d3..0bd91887b8 100644 --- a/libraries/integer-gmp/configure.ac +++ b/libraries/integer-gmp/configure.ac @@ -1,7 +1,8 @@ -AC_INIT([Haskell integer (GMP)], [0.1], [libraries@haskell.org], [integer]) +AC_INIT([Haskell integer (GMP)], [1.0], [libraries@haskell.org], [integer]) +AC_PREREQ(2.52) # Safety check: Ensure that we are in the correct source directory. -AC_CONFIG_SRCDIR([cbits/gmp-wrappers.cmm]) +AC_CONFIG_SRCDIR([cbits/wrappers.c]) AC_CANONICAL_TARGET @@ -60,11 +61,36 @@ then LOOK_FOR_GMP_FRAMEWORK fi fi + +AC_MSG_CHECKING([whether to use in-tree GMP]) if test "$HaveFrameworkGMP" = "YES" || test "$HaveLibGmp" = "YES" then + AC_MSG_RESULT([no]) + UseIntreeGmp=0 AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Cannot find gmp.h])]) + + AC_MSG_CHECKING([GMP version]) + AC_COMPUTE_INT(GhcGmpVerMj, __GNU_MP_VERSION, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION])) + AC_COMPUTE_INT(GhcGmpVerMi, __GNU_MP_VERSION_MINOR, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_MINOR])) + AC_COMPUTE_INT(GhcGmpVerPl, __GNU_MP_VERSION_PATCHLEVEL, [#include <gmp.h>], + AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_PATCHLEVEL])) + AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) + +else + AC_MSG_RESULT([yes]) + UseIntreeGmp=1 + HaveSecurePowm=1 + + AC_MSG_CHECKING([GMP version]) + GhcGmpVerMj=5 + GhcGmpVerMi=0 + GhcGmpVerPl=4 + AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) fi + dnl-------------------------------------------------------------------- dnl * Make sure we got some form of gmp dnl-------------------------------------------------------------------- @@ -76,11 +102,15 @@ AC_SUBST(GMP_FRAMEWORK) AC_SUBST(HaveLibGmp) AC_SUBST(HaveFrameworkGMP) AC_SUBST(HaveSecurePowm) +AC_SUBST(UseIntreeGmp) +AC_SUBST(GhcGmpVerMj) +AC_SUBST(GhcGmpVerMi) +AC_SUBST(GhcGmpVerPl) AC_CONFIG_FILES([integer-gmp.buildinfo gmp/config.mk include/HsIntegerGmp.h]) dnl-------------------------------------------------------------------- -dnl * Generate the header cbits/GmpDerivedConstants.h +dnl * Generate output files dnl-------------------------------------------------------------------- AC_OUTPUT diff --git a/libraries/integer-gmp/gmp/ghc-gmp.h b/libraries/integer-gmp/gmp/ghc-gmp.h new file mode 100644 index 0000000000..3fdb398670 --- /dev/null +++ b/libraries/integer-gmp/gmp/ghc-gmp.h @@ -0,0 +1 @@ +#include <gmp.h> diff --git a/libraries/integer-gmp/gmp/ghc.mk b/libraries/integer-gmp/gmp/ghc.mk index 139ae93515..78a7cf03c7 100644 --- a/libraries/integer-gmp/gmp/ghc.mk +++ b/libraries/integer-gmp/gmp/ghc.mk @@ -20,6 +20,7 @@ GMP_DIR := $(patsubst libraries/integer-gmp/gmp/tarball/%-nodoc-patched.tar.bz2, ifneq "$(NO_CLEAN_GMP)" "YES" $(eval $(call clean-target,gmp,,\ + libraries/integer-gmp/include/ghc-gmp.h \ libraries/integer-gmp/gmp/config.mk \ libraries/integer-gmp/gmp/libgmp.a \ libraries/integer-gmp/gmp/gmp.h \ @@ -49,9 +50,6 @@ ifeq "$(findstring clean,$(MAKECMDGOALS))" "" include libraries/integer-gmp/gmp/config.mk endif -libraries/integer-gmp_dist-install_EXTRA_CC_OPTS += -Ilibraries/integer-gmp/mkGmpDerivedConstants/dist -libraries/integer-gmp_dist-install_EXTRA_HC_OPTS += -Ilibraries/integer-gmp/mkGmpDerivedConstants/dist - gmp_CC_OPTS += $(addprefix -I,$(GMP_INCLUDE_DIRS)) gmp_CC_OPTS += $(addprefix -L,$(GMP_LIB_DIRS)) @@ -78,27 +76,27 @@ HaveFrameworkGMP = NO endif endif -$(libraries/integer-gmp_dist-install_depfile_c_asm): $$(GmpDerivedConstants_HEADER) - +UseIntreeGmp = NO ifneq "$(HaveLibGmp)" "YES" ifneq "$(HaveFrameworkGMP)" "YES" -$(libraries/integer-gmp_dist-install_depfile_c_asm): libraries/integer-gmp/gmp/gmp.h +UseIntreeGmp = YES +endif +endif + +ifeq "$(UseIntreeGmp)" "YES" +$(libraries/integer-gmp_dist-install_depfile_c_asm): libraries/integer-gmp/gmp/gmp.h libraries/integer-gmp/include/ghc-gmp.h + +libraries/integer-gmp/include/ghc-gmp.h: libraries/integer-gmp/gmp/gmp.h + $(CP) $< $@ gmp_CC_OPTS += -Ilibraries/integer-gmp/gmp -gmp_CC_OPTS += -Ilibraries/integer-gmp/mkGmpDerivedConstants/dist libraries/integer-gmp_dist-install_EXTRA_OBJS += libraries/integer-gmp/gmp/objs/*.o +else +$(libraries/integer-gmp_dist-install_depfile_c_asm): libraries/integer-gmp/include/ghc-gmp.h -#INSTALL_LIBS += libraries/integer-gmp/gmp/libgmp.a -#INSTALL_HEADERS += libraries/integer-gmp/gmp/gmp.h -# -#$(eval $(call all-target,gmp_dynamic,libraries/integer-gmp/gmp/libgmp.a)) -# -#ifeq "$(BUILD_SHARED)" "yes" -#$(eval $(call all-target,gmp_dynamic,libraries/integer-gmp/gmp/libgmp.dll.a libraries/integer-gmp/gmp/libgmp-3.dll)) -#endif - -endif +libraries/integer-gmp/include/ghc-gmp.h: libraries/integer-gmp/gmp/ghc-gmp.h + $(CP) $< $@ endif libraries/integer-gmp_dist-install_EXTRA_CC_OPTS += $(gmp_CC_OPTS) @@ -111,30 +109,12 @@ else CCX = $(CC_STAGE1) endif -# 2007-09-26 -# set -o igncr -# is not a valid command on non-Cygwin-systems. -# Let it fail silently instead of aborting the build. -# -# 2007-07-05 -# We do -# set -o igncr; export SHELLOPTS -# here as otherwise checking the size of limbs -# makes the build fall over on Cygwin. See the thread -# http://www.cygwin.com/ml/cygwin/2006-12/msg00011.html -# for more details. - -# 2007-07-05 -# Passing -# as_ln_s='cp -p' -# isn't sufficient to stop cygwin using symlinks the mingw gcc can't -# follow, as it isn't used consistently. Instead we put an ln.bat in -# path that always fails. - libraries/integer-gmp/gmp/libgmp.a libraries/integer-gmp/gmp/gmp.h: $(RM) -rf libraries/integer-gmp/gmp/$(GMP_DIR) libraries/integer-gmp/gmp/gmpbuild libraries/integer-gmp/gmp/objs cat $(GMP_TARBALL) | $(BZIP2_CMD) -d | { cd libraries/integer-gmp/gmp && $(TAR_CMD) -xf - ; } mv libraries/integer-gmp/gmp/$(GMP_DIR) libraries/integer-gmp/gmp/gmpbuild + cd libraries/integer-gmp/gmp && $(PATCH_CMD) -p0 < gmpsrc.patch + cat libraries/integer-gmp/gmp/tarball/gmp-5.0.4.patch | { cd libraries/integer-gmp/gmp/gmpbuild && $(PATCH_CMD) -p1 ; } chmod +x libraries/integer-gmp/gmp/ln # Their cmd invocation only works on msys. On cygwin it starts @@ -156,42 +136,4 @@ libraries/integer-gmp/gmp/libgmp.a libraries/integer-gmp/gmp/gmp.h: cd libraries/integer-gmp/gmp/objs && $(AR_STAGE1) x ../libgmp.a $(RANLIB_CMD) libraries/integer-gmp/gmp/libgmp.a -# XXX TODO: -#stamp.gmp.shared: -# $(RM) -rf $(GMP_DIR) gmpbuild-shared -# $(TAR_CMD) -zxf $(GMP_TARBALL) -# mv $(GMP_DIR) gmpbuild-shared -# chmod +x ln -# (set -o igncr 2>/dev/null) && set -o igncr; export SHELLOPTS; \ -# PATH=`pwd`:$$PATH; \ -# export PATH; \ -# cd gmpbuild-shared && \ -# CC=$(CC_STAGE1) $(SHELL) ./configure \ -# --enable-shared=yes --disable-static \ -# --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) -# "$(TOUCH_CMD)" $@ -# -#gmp.h: stamp.gmp.static -# $(CP) gmpbuild/gmp.h . -# -#libgmp.a: stamp.gmp.static -# -#libgmp-3.dll: stamp.gmp.shared -# $(MAKE) -C gmpbuild-shared MAKEFLAGS= -# $(CP) gmpbuild-shared/.libs/libgmp-3.dll . -# -#libgmp.dll.a: libgmp-3.dll -# $(CP) gmpbuild-shared/.libs/libgmp.dll.a . - -## GMP takes a long time to build, but changes rarely. Hence we don't -## bother cleaning it before validating, because that adds a -## significant overhead to validation. -#ifeq "$(Validating)" "NO" -#clean distclean maintainer-clean :: -# $(RM) -f stamp.gmp.static stamp.gmp.shared -# $(RM) -rf gmpbuild -# $(RM) -rf gmpbuild-shared -#endif - endif - diff --git a/libraries/integer-gmp/gmp/gmpsrc.patch b/libraries/integer-gmp/gmp/gmpsrc.patch new file mode 100644 index 0000000000..e3906329ee --- /dev/null +++ b/libraries/integer-gmp/gmp/gmpsrc.patch @@ -0,0 +1,37 @@ +--- gmp-5.0.3/configure 2012-02-03 16:52:49.000000000 +0100 ++++ gmpbuild/configure 2014-11-07 23:46:33.629758238 +0100 +@@ -3937,8 +3937,8 @@ + # + cclist="gcc cc" + +-gcc_cflags="-O2 -pedantic" +-gcc_64_cflags="-O2 -pedantic" ++gcc_cflags="-O2 -pedantic -fPIC" ++gcc_64_cflags="-O2 -pedantic -fPIC" + cc_cflags="-O" + cc_64_cflags="-O" + +--- gmp-5.0.3/memory.c 2012-02-03 16:52:49.000000000 +0100 ++++ gmpbuild/memory.c 2014-11-07 23:54:20.734523242 +0100 +@@ -24,21 +24,10 @@ + #include "gmp-impl.h" + + +-/* Patched for GHC: */ +-void * stgAllocForGMP (size_t size_in_bytes); +-void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size); +-void stgDeallocForGMP (void *ptr, size_t size); +- +-void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = stgAllocForGMP; +-void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) +- = stgReallocForGMP; +-void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = stgDeallocForGMP; +-/* + void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = __gmp_default_allocate; + void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) + = __gmp_default_reallocate; + void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = __gmp_default_free; +-*/ + + + /* Default allocation functions. In case of failure to allocate/reallocate diff --git a/libraries/integer-gmp/include/HsIntegerGmp.h.in b/libraries/integer-gmp/include/HsIntegerGmp.h.in index 11c64677e8..ba0767cae7 100644 --- a/libraries/integer-gmp/include/HsIntegerGmp.h.in +++ b/libraries/integer-gmp/include/HsIntegerGmp.h.in @@ -1,6 +1,14 @@ #ifndef _HS_INTEGER_GMP_H_ #define _HS_INTEGER_GMP_H_ -#define HAVE_SECURE_POWM @HaveSecurePowm@ +/* Whether GMP is embedded into integer-gmp */ +#define GHC_GMP_INTREE @UseIntreeGmp@ + +/* The following values denote the GMP version used during GHC build-time */ +#define GHC_GMP_VERSION_MJ @GhcGmpVerMj@ +#define GHC_GMP_VERSION_MI @GhcGmpVerMi@ +#define GHC_GMP_VERSION_PL @GhcGmpVerPl@ +#define GHC_GMP_VERSION \ + (@GhcGmpVerMj@ * 10000 + @GhcGmpVerMi@ * 100 + @GhcGmpVerPl@) #endif /* _HS_INTEGER_GMP_H_ */ diff --git a/libraries/integer-gmp/integer-gmp.buildinfo.in b/libraries/integer-gmp/integer-gmp.buildinfo.in index 9b2bad99d7..805a425a19 100644 --- a/libraries/integer-gmp/integer-gmp.buildinfo.in +++ b/libraries/integer-gmp/integer-gmp.buildinfo.in @@ -2,4 +2,4 @@ include-dirs: @GMP_INCLUDE_DIRS@ extra-lib-dirs: @GMP_LIB_DIRS@ extra-libraries: @GMP_LIBS@ frameworks: @GMP_FRAMEWORK@ -install-includes: HsIntegerGmp.h
\ No newline at end of file +install-includes: HsIntegerGmp.h ghc-gmp.h diff --git a/libraries/integer-gmp/integer-gmp.cabal b/libraries/integer-gmp/integer-gmp.cabal index 493da28e80..4833704481 100644 --- a/libraries/integer-gmp/integer-gmp.cabal +++ b/libraries/integer-gmp/integer-gmp.cabal @@ -1,41 +1,26 @@ -name: integer-gmp -version: 0.5.1.0 --- GHC 7.6.1 released with 0.5.0.0 -license: BSD3 -license-file: LICENSE -category: Numerical -maintainer: libraries@haskell.org -bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29&keywords=integer-gmp -synopsis: Integer library based on GMP -description: - This package provides the low-level implementation of the standard - 'Integer' type based on the - <http://gmplib.org/ GNU Multiple Precision Arithmetic Library (GMP)>. - . - This package provides access to the internal representation of - 'Integer' as well as primitive operations with no proper error - handling, and should only be used directly with the utmost care. - . - For more details about the design of @integer-gmp@, see - <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer GHC Commentary: Libraries/Integer>. -build-type: Configure -cabal-version: >=1.10 +name: integer-gmp +version: 1.0.0.0 +synopsis: Integer library based on GMP +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +category: Numeric, Algebra +build-type: Configure +cabal-version: >=1.10 extra-source-files: aclocal.m4 - cbits/alloc.c - cbits/float.c - cbits/gmp-wrappers.cmm - cbits/longlong.c + cbits/wrappers.c changelog.md config.guess config.sub configure configure.ac gmp/config.mk.in + include/HsIntegerGmp.h.in install-sh integer-gmp.buildinfo.in - include/HsIntegerGmp.h.in extra-tmp-files: autom4te.cache @@ -45,36 +30,37 @@ extra-tmp-files: integer-gmp.buildinfo include/HsIntegerGmp.h -source-repository head - type: git - location: http://git.haskell.org/ghc.git - subdir: libraries/integer-gmp - -Library - default-language: Haskell2010 - other-extensions: - BangPatterns - CPP - GHCForeignImportPrim - MagicHash - NoImplicitPrelude - UnboxedTuples - UnliftedFFITypes +library + default-language: Haskell2010 + other-extensions: + BangPatterns + CApiFFI + CPP + DeriveDataTypeable + ExplicitForAll + GHCForeignImportPrim + MagicHash + NegativeLiterals + NoImplicitPrelude + RebindableSyntax + StandaloneDeriving + UnboxedTuples + UnliftedFFITypes + build-depends: ghc-prim + hs-source-dirs: src/ + ghc-options: -this-package-key integer-gmp -Wall + cc-options: -std=c99 -Wall - exposed-modules: - GHC.Integer - GHC.Integer.GMP.Internals - GHC.Integer.GMP.Prim - GHC.Integer.Logarithms - GHC.Integer.Logarithms.Internals - other-modules: - GHC.Integer.Type + include-dirs: include + c-sources: + cbits/wrappers.c - c-sources: cbits/cbits.c - include-dirs: include + exposed-modules: + GHC.Integer + GHC.Integer.Logarithms + GHC.Integer.Logarithms.Internals - build-depends: ghc-prim == 0.4.* + GHC.Integer.GMP.Internals - -- We need to set the package key to integer-gmp - -- (without a version number) as it's magic. - ghc-options: -Wall -this-package-key integer-gmp + other-modules: + GHC.Integer.Type diff --git a/libraries/integer-gmp/mkGmpDerivedConstants/Makefile b/libraries/integer-gmp/mkGmpDerivedConstants/Makefile deleted file mode 100644 index ce66e201b4..0000000000 --- a/libraries/integer-gmp/mkGmpDerivedConstants/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture -# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -dir = libraries/integer-gmp/mkGmpDerivedConstants -TOP = ../../.. -include $(TOP)/mk/sub-makefile.mk diff --git a/libraries/integer-gmp/mkGmpDerivedConstants/ghc.mk b/libraries/integer-gmp/mkGmpDerivedConstants/ghc.mk deleted file mode 100644 index fcf19fa4a0..0000000000 --- a/libraries/integer-gmp/mkGmpDerivedConstants/ghc.mk +++ /dev/null @@ -1,39 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture -# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -libraries/integer-gmp/mkGmpDerivedConstants_dist_C_SRCS = mkGmpDerivedConstants.c -libraries/integer-gmp/mkGmpDerivedConstants_dist_PROGNAME = mkGmpDerivedConstants -libraries/integer-gmp/mkGmpDerivedConstants_dist_TOPDIR = YES -libraries/integer-gmp/mkGmpDerivedConstants_dist_INSTALL = YES -libraries/integer-gmp/mkGmpDerivedConstants_dist_INSTALL_INPLACE = YES -libraries/integer-gmp/mkGmpDerivedConstants_dist_EXTRA_CC_OPTS += $(gmp_CC_OPTS) - -$(eval $(call build-prog,libraries/integer-gmp/mkGmpDerivedConstants,dist,1)) - -GmpDerivedConstants_HEADER = libraries/integer-gmp/mkGmpDerivedConstants/dist/GmpDerivedConstants.h - -$(GmpDerivedConstants_HEADER): $(mkGmpDerivedConstants_INPLACE) - $< > $@ - -ifneq "$(HaveLibGmp)" "YES" -ifneq "$(HaveFrameworkGMP)" "YES" -# NOTE: we should really be referring to the depfile generated by the build -# system here, but due to an awkward contortion I can't figure out, the build -# system follows an implied from somewhere else to directly build the C file -# instead (independent of the depfile rules), which doesn't have a built gmp.h -# dependency. This race causes the parallel build to fail. -# -# See #8102 -libraries/integer-gmp/mkGmpDerivedConstants/mkGmpDerivedConstants.c: libraries/integer-gmp/gmp/gmp.h -endif -endif - diff --git a/libraries/integer-gmp/mkGmpDerivedConstants/mkGmpDerivedConstants.c b/libraries/integer-gmp/mkGmpDerivedConstants/mkGmpDerivedConstants.c deleted file mode 100644 index fb7290f682..0000000000 --- a/libraries/integer-gmp/mkGmpDerivedConstants/mkGmpDerivedConstants.c +++ /dev/null @@ -1,75 +0,0 @@ -/* -------------------------------------------------------------------------- - * - * (c) The GHC Team, 1992-2004 - * - * mkDerivedConstants.c - * - * Basically this is a C program that extracts information from the C - * declarations in the header files (primarily struct field offsets) - * and generates a header file that can be #included into non-C source - * containing this information. - * - * ------------------------------------------------------------------------*/ - -#include <stdio.h> -#include "gmp.h" - - -#define str(a,b) #a "_" #b - -#define OFFSET(s_type, field) ((size_t)&(((s_type*)0)->field)) - -/* struct_size(TYPE) - * - */ -#define def_size(str, size) \ - printf("#define SIZEOF_" str " %lu\n", (unsigned long)size); - -#define struct_size(s_type) \ - def_size(#s_type, sizeof(s_type)); - - - -/* struct_field(TYPE, FIELD) - * - */ -#define def_offset(str, offset) \ - printf("#define OFFSET_" str " %d\n", (int)(offset)); - -#define field_offset_(str, s_type, field) \ - def_offset(str, OFFSET(s_type,field)); - -#define field_offset(s_type, field) \ - field_offset_(str(s_type,field),s_type,field); - -#define field_type_(str, s_type, field) \ - printf("#define REP_" str " b"); \ - printf("%lu\n", (unsigned long)sizeof (__typeof__(((((s_type*)0)->field)))) * 8); - -#define field_type(s_type, field) \ - field_type_(str(s_type,field),s_type,field); - -/* An access macro for use in C-- sources. */ -#define struct_field_macro(str) \ - printf("#define " str "(__ptr__) REP_" str "[__ptr__+OFFSET_" str "]\n"); - -/* Outputs the byte offset and MachRep for a field */ -#define struct_field(s_type, field) \ - field_offset(s_type, field); \ - field_type(s_type, field); \ - struct_field_macro(str(s_type,field)) - - -int -main(int argc, char *argv[]) -{ - printf("/* This file is created automatically. Do not edit by hand.*/\n\n"); - - struct_size(MP_INT); - struct_field(MP_INT,_mp_alloc); - struct_field(MP_INT,_mp_size); - struct_field(MP_INT,_mp_d); - def_size("MP_LIMB_T", sizeof(mp_limb_t)); - - return 0; -} diff --git a/libraries/integer-gmp/GHC/Integer.lhs b/libraries/integer-gmp/src/GHC/Integer.hs index 392a94a082..ffd708bb93 100644 --- a/libraries/integer-gmp/GHC/Integer.lhs +++ b/libraries/integer-gmp/src/GHC/Integer.hs @@ -1,25 +1,24 @@ -\begin{code} -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + +#include "MachDeps.h" ------------------------------------------------------------------------------ -- | --- Module : GHC.Integer --- Copyright : (c) The University of Glasgow 1994-2008 --- License : see libraries/integer-gmp/LICENSE +-- Module : GHC.Integer.Type +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 -- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional -- Portability : non-portable (GHC Extensions) -- -- The 'Integer' type. -- -- This module exposes the /portable/ 'Integer' API. See --- "GHC.Integer.GMP.Internals" for the GMP-specific internal +-- "GHC.Integer.GMP.Internals" for the @integer-gmp@-specific internal -- representation of 'Integer' as well as optimized GMP-specific -- operations. ------------------------------------------------------------------------------ - -#include "MachDeps.h" module GHC.Integer ( Integer, @@ -41,26 +40,34 @@ module GHC.Integer ( -- * Arithmetic operations plusInteger, minusInteger, timesInteger, negateInteger, - absInteger, signumInteger, + absInteger, signumInteger, + divModInteger, divInteger, modInteger, quotRemInteger, quotInteger, remInteger, -- * Comparison predicates - eqInteger, neqInteger, - leInteger, gtInteger, ltInteger, geInteger, compareInteger, - eqInteger#, neqInteger#, - leInteger#, gtInteger#, ltInteger#, geInteger#, + eqInteger, neqInteger, leInteger, gtInteger, ltInteger, geInteger, + compareInteger, + + -- ** 'Int#'-boolean valued versions of comparision predicates + -- + -- | These operations return @0#@ and @1#@ instead of 'False' and + -- 'True' respectively. See + -- <https://ghc.haskell.org/trac/ghc/wiki/PrimBool PrimBool wiki-page> + -- for more details + eqInteger#, neqInteger#, leInteger#, gtInteger#, ltInteger#, geInteger#, + -- * Bit-operations - andInteger, orInteger, xorInteger, complementInteger, + andInteger, orInteger, xorInteger, + + complementInteger, shiftLInteger, shiftRInteger, testBitInteger, -- * Hashing hashInteger, - ) where + ) where import GHC.Integer.Type default () -\end{code} - diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs new file mode 100644 index 0000000000..0ad6848974 --- /dev/null +++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} + +#include "MachDeps.h" + +-- | +-- Module : GHC.Integer.GMP.Internals +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- This modules provides access to the 'Integer' constructors and +-- exposes some highly optimized GMP-operations. +-- +-- Note that since @integer-gmp@ does not depend on `base`, error +-- reporting via exceptions, 'error', or 'undefined' is not +-- available. Instead, the low-level functions will crash the runtime +-- if called with invalid arguments. +-- +-- See also +-- <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer GHC Commentary: Libraries/Integer>. + +module GHC.Integer.GMP.Internals + ( -- * The 'Integer' type + Integer(..) + , isValidInteger# + + -- ** Basic 'Integer' operations + + , module GHC.Integer + + -- ** Additional 'Integer' operations + , bitInteger + , popCountInteger + , gcdInteger + , gcdExtInteger + , lcmInteger + , sqrInteger + , powModInteger + , recipModInteger + + -- ** Additional conversion operations to 'Integer' + , wordToNegInteger + , bigNatToInteger + , bigNatToNegInteger + + -- * The 'BigNat' type + , BigNat(..) + + , GmpLimb, GmpLimb# + , GmpSize, GmpSize# + + -- ** + + , isValidBigNat# + , sizeofBigNat# + , zeroBigNat + , oneBigNat + , nullBigNat + + -- ** Conversions to/from 'BigNat' + + , byteArrayToBigNat# + , wordToBigNat + , wordToBigNat2 + , bigNatToInt + , bigNatToWord + , indexBigNat# + + -- ** 'BigNat' arithmetic operations + , plusBigNat + , plusBigNatWord + , minusBigNat + , minusBigNatWord + , timesBigNat + , timesBigNatWord + , sqrBigNat + + , quotRemBigNat + , quotRemBigNatWord + , quotBigNatWord + , quotBigNat + , remBigNat + , remBigNatWord + + , gcdBigNat + , gcdBigNatWord + + , powModBigNat + , powModBigNatWord + + , recipModBigNat + + -- ** 'BigNat' logic operations + , shiftRBigNat + , shiftLBigNat + , testBitBigNat + , andBigNat + , xorBigNat + , popCountBigNat + , orBigNat + , bitBigNat + + -- ** 'BigNat' comparision predicates + , isZeroBigNat + , isNullBigNat# + + , compareBigNatWord + , compareBigNat + , eqBigNatWord + , eqBigNatWord# + , eqBigNat + , eqBigNat# + , gtBigNatWord# + + -- * Miscellaneous GMP-provided operations + , gcdInt + , gcdWord + , powModWord + , recipModWord + + -- * Primality tests + , testPrimeInteger + , testPrimeBigNat + , testPrimeWord# + + , nextPrimeInteger + , nextPrimeBigNat + , nextPrimeWord# + + -- * Import/export functions + -- ** Compute size of serialisation + , sizeInBaseBigNat + , sizeInBaseInteger + , sizeInBaseWord# + + -- ** Export + , exportBigNatToAddr + , exportIntegerToAddr + , exportWordToAddr + + , exportBigNatToMutableByteArray + , exportIntegerToMutableByteArray + , exportWordToMutableByteArray + + -- ** Import + + , importBigNatFromAddr + , importIntegerFromAddr + + , importBigNatFromByteArray + , importIntegerFromByteArray + ) where + +import GHC.Integer.Type +import GHC.Integer +import GHC.Prim +import GHC.Types + +default () + + +-- | Compute number of digits (without sign) in given @/base/@. +-- +-- This function wraps @mpz_sizeinbase()@ which has some +-- implementation pecularities to take into account: +-- +-- * \"@'sizeInBaseInteger' 0 /base/ = 1@\" +-- (see also comment in 'exportIntegerToMutableByteArray'). +-- +-- * This function is only defined if @/base/ >= 2#@ and @/base/ <= 256#@ +-- (Note: the documentation claims that only @/base/ <= 62#@ is +-- supported, however the actual implementation supports up to base 256). +-- +-- * If @/base/@ is a power of 2, the result will be exact. In other +-- cases (e.g. for @/base/ = 10#@), the result /may/ be 1 digit too large +-- sometimes. +-- +-- * \"@'sizeInBaseInteger' /i/ 2#@\" can be used to determine the most +-- significant bit of @/i/@. +-- +-- @since 0.5.1.0 +sizeInBaseInteger :: Integer -> Int# -> Word# +sizeInBaseInteger (S# i#) = sizeInBaseWord# (int2Word# (absI# i#)) +sizeInBaseInteger (Jp# bn) = sizeInBaseBigNat bn +sizeInBaseInteger (Jn# bn) = sizeInBaseBigNat bn + +-- | Version of 'sizeInBaseInteger' operating on 'BigNat' +-- +-- @since 1.0.0.0 +sizeInBaseBigNat :: BigNat -> Int# -> Word# +sizeInBaseBigNat bn@(BN# ba#) = c_mpn_sizeinbase# ba# (sizeofBigNat# bn) + +foreign import ccall unsafe "integer_gmp_mpn_sizeinbase" + c_mpn_sizeinbase# :: ByteArray# -> GmpSize# -> Int# -> Word# + +-- | Version of 'sizeInBaseInteger' operating on 'Word#' +-- +-- @since 1.0.0.0 +foreign import ccall unsafe "integer_gmp_mpn_sizeinbase1" + sizeInBaseWord# :: Word# -> Int# -> Word# + +-- | Dump 'Integer' (without sign) to @/addr/@ in base-256 representation. +-- +-- @'exportIntegerToAddr' /i/ /addr/ /e/@ +-- +-- See description of 'exportIntegerToMutableByteArray' for more details. +-- +-- @since 1.0.0.0 +exportIntegerToAddr :: Integer -> Addr# -> Int# -> IO Word +exportIntegerToAddr (S# i#) = exportWordToAddr (W# (int2Word# (absI# i#))) +exportIntegerToAddr (Jp# bn) = exportBigNatToAddr bn +exportIntegerToAddr (Jn# bn) = exportBigNatToAddr bn + +-- | Version of 'exportIntegerToAddr' operating on 'BigNat's. +exportBigNatToAddr :: BigNat -> Addr# -> Int# -> IO Word +exportBigNatToAddr bn@(BN# ba#) addr e + = c_mpn_exportToAddr# ba# (sizeofBigNat# bn) addr 0# e + +foreign import ccall unsafe "integer_gmp_mpn_export" + c_mpn_exportToAddr# :: ByteArray# -> GmpSize# -> Addr# -> Int# -> Int# + -> IO Word + +-- | Version of 'exportIntegerToAddr' operating on 'Word's. +exportWordToAddr :: Word -> Addr# -> Int# -> IO Word +exportWordToAddr (W# w#) addr + = c_mpn_export1ToAddr# w# addr 0# -- TODO: we don't calling GMP for that + +foreign import ccall unsafe "integer_gmp_mpn_export1" + c_mpn_export1ToAddr# :: GmpLimb# -> Addr# -> Int# -> Int# + -> IO Word + +-- | Dump 'Integer' (without sign) to mutable byte-array in base-256 +-- representation. +-- +-- The call +-- +-- @'exportIntegerToMutableByteArray' /i/ /mba/ /offset/ /msbf/@ +-- +-- writes +-- +-- * the 'Integer' @/i/@ +-- +-- * into the 'MutableByteArray#' @/mba/@ starting at @/offset/@ +-- +-- * with most significant byte first if @msbf@ is @1#@ or least +-- significant byte first if @msbf@ is @0#@, and +-- +-- * returns number of bytes written. +-- +-- Use \"@'sizeInBaseInteger' /i/ 256#@\" to compute the exact number of +-- bytes written in advance for @/i/ /= 0@. In case of @/i/ == 0@, +-- 'exportIntegerToMutableByteArray' will write and report zero bytes +-- written, whereas 'sizeInBaseInteger' report one byte. +-- +-- It's recommended to avoid calling 'exportIntegerToMutableByteArray' for small +-- integers as this function would currently convert those to big +-- integers in msbf to call @mpz_export()@. +-- +-- @since 1.0.0.0 +exportIntegerToMutableByteArray :: Integer -> MutableByteArray# RealWorld + -> Word# -> Int# -> IO Word +exportIntegerToMutableByteArray (S# i#) + = exportWordToMutableByteArray (W# (int2Word# (absI# i#))) +exportIntegerToMutableByteArray (Jp# bn) = exportBigNatToMutableByteArray bn +exportIntegerToMutableByteArray (Jn# bn) = exportBigNatToMutableByteArray bn + +-- | Version of 'exportIntegerToMutableByteArray' operating on 'BigNat's. +-- +-- @since 1.0.0.0 +exportBigNatToMutableByteArray :: BigNat -> MutableByteArray# RealWorld -> Word# + -> Int# -> IO Word +exportBigNatToMutableByteArray bn@(BN# ba#) + = c_mpn_exportToMutableByteArray# ba# (sizeofBigNat# bn) + +foreign import ccall unsafe "integer_gmp_mpn_export" + c_mpn_exportToMutableByteArray# :: ByteArray# -> GmpSize# + -> MutableByteArray# RealWorld -> Word# + -> Int# -> IO Word + +-- | Version of 'exportIntegerToMutableByteArray' operating on 'Word's. +-- +-- @since 1.0.0.0 +exportWordToMutableByteArray :: Word -> MutableByteArray# RealWorld -> Word# + -> Int# -> IO Word +exportWordToMutableByteArray (W# w#) = c_mpn_export1ToMutableByteArray# w# + +foreign import ccall unsafe "integer_gmp_mpn_export1" + c_mpn_export1ToMutableByteArray# :: GmpLimb# -> MutableByteArray# RealWorld + -> Word# -> Int# -> IO Word + + +-- | Probalistic Miller-Rabin primality test. +-- +-- \"@'testPrimeInteger' /n/ /k/@\" determines whether @/n/@ is prime +-- and returns one of the following results: +-- +-- * @2#@ is returned if @/n/@ is definitely prime, +-- +-- * @1#@ if @/n/@ is a /probable prime/, or +-- +-- * @0#@ if @/n/@ is definitely not a prime. +-- +-- The @/k/@ argument controls how many test rounds are performed for +-- determining a /probable prime/. For more details, see +-- <http://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fprobab_005fprime_005fp-360 GMP documentation for `mpz_probab_prime_p()`>. +-- +-- @since 0.5.1.0 +{-# NOINLINE testPrimeInteger #-} +testPrimeInteger :: Integer -> Int# -> Int# +testPrimeInteger (S# i#) = testPrimeWord# (int2Word# (absI# i#)) +testPrimeInteger (Jp# n) = testPrimeBigNat n +testPrimeInteger (Jn# n) = testPrimeBigNat n + +-- | Version of 'testPrimeInteger' operating on 'BigNat's +-- +-- @since 1.0.0.0 +testPrimeBigNat :: BigNat -> Int# -> Int# +testPrimeBigNat bn@(BN# ba#) = c_integer_gmp_test_prime# ba# (sizeofBigNat# bn) + +foreign import ccall unsafe "integer_gmp_test_prime" + c_integer_gmp_test_prime# :: ByteArray# -> GmpSize# -> Int# -> Int# + +-- | Version of 'testPrimeInteger' operating on 'Word#'s +-- +-- @since 1.0.0.0 +foreign import ccall unsafe "integer_gmp_test_prime1" + testPrimeWord# :: GmpLimb# -> Int# -> Int# + + +-- | Compute next prime greater than @/n/@ probalistically. +-- +-- According to the GMP documentation, the underlying function +-- @mpz_nextprime()@ \"uses a probabilistic algorithm to identify +-- primes. For practical purposes it's adequate, the chance of a +-- composite passing will be extremely small.\" +-- +-- @since 0.5.1.0 +{-# NOINLINE nextPrimeInteger #-} +nextPrimeInteger :: Integer -> Integer +nextPrimeInteger (S# i#) + | isTrue# (i# ># 1#) = wordToInteger (nextPrimeWord# (int2Word# i#)) + | True = S# 2# +nextPrimeInteger (Jp# bn) = Jp# (nextPrimeBigNat bn) +nextPrimeInteger (Jn# _) = S# 2# + +-- | Version of 'nextPrimeInteger' operating on 'Word#'s +-- +-- @since 1.0.0.0 +foreign import ccall unsafe "integer_gmp_next_prime1" + nextPrimeWord# :: GmpLimb# -> GmpLimb# diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs new file mode 100644 index 0000000000..cbcc860002 --- /dev/null +++ b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE CPP #-} + +module GHC.Integer.Logarithms + ( wordLog2# + , integerLog2# + , integerLogBase# + ) where + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +# define LD_WORD_SIZE_IN_BITS 5 +#elif WORD_SIZE_IN_BITS == 64 +# define LD_WORD_SIZE_IN_BITS 6 +#else +# error unsupported WORD_SIZE_IN_BITS +#endif + +import GHC.Integer.Type + +import GHC.Prim + +default () + +-- | Calculate the integer logarithm for an arbitrary base. +-- +-- The base must be greater than @1@, the second argument, the number +-- whose logarithm is sought, shall be positive, otherwise the +-- result is meaningless. +-- +-- The following property holds +-- +-- @base ^ 'integerLogBase#' base m <= m < base ^('integerLogBase#' base m + 1)@ +-- +-- for @base > 1@ and @m > 0@. +-- +-- Note: Internally uses 'integerLog2#' for base 2 +integerLogBase# :: Integer -> Integer -> Int# +integerLogBase# (S# 2#) m = integerLog2# m +integerLogBase# b m = e' + where + (# _, e' #) = go b + + go pw | m `ltInteger` pw = (# m, 0# #) + go pw = case go (sqrInteger pw) of + (# q, e #) | q `ltInteger` pw -> (# q, 2# *# e #) + (# q, e #) -> (# 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# (S# i#) = wordLog2# (int2Word# i#) +integerLog2# (Jn# _) = -1# +integerLog2# (Jp# bn) = go (s -# 1#) + where + s = sizeofBigNat# bn + go i = case indexBigNat# bn i of + 0## -> go (i -# 1#) + w -> wordLog2# w +# (uncheckedIShiftL# i LD_WORD_SIZE_IN_BITS#) + +-- | Compute base-2 log of 'Word#' +-- +-- This is internally implemented as count-leading-zeros machine instruction. +wordLog2# :: Word# -> Int# +wordLog2# w# = (WORD_SIZE_IN_BITS# -# 1#) -# (word2Int# (clz# w#)) diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs new file mode 100644 index 0000000000..7ac3645c74 --- /dev/null +++ b/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +{-# OPTIONS_HADDOCK hide #-} + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +# define WSHIFT 5 +# define MMASK 31 +#elif WORD_SIZE_IN_BITS == 64 +# define WSHIFT 6 +# define MMASK 63 +#else +# error unsupported WORD_SIZE_IN_BITS +#endif + +-- | 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. +-- +-- See https://ghc.haskell.org/trac/ghc/ticket/5122 +-- for the origin of the code in this module +module GHC.Integer.Logarithms.Internals + ( wordLog2# + , integerLog2IsPowerOf2# + , integerLog2# + , roundingMode# + ) where + +import GHC.Integer.Type +import GHC.Integer.Logarithms + +import GHC.Types +import GHC.Prim + +default () + +-- | Extended version of 'integerLog2#' +-- +-- Assumption: Integer is strictly positive +-- +-- First component of result is @log2 n@, second is @0#@ iff /n/ is a +-- power of two. +integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) +-- The power of 2 test is n&(n-1) == 0, thus powers of 2 +-- are indicated bythe second component being zero. +integerLog2IsPowerOf2# (S# i#) = case int2Word# i# of + w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #) +integerLog2IsPowerOf2# (Jn# _) = (# -1#, -1# #) +-- Find the log2 as above, test whether that word is a power +-- of 2, if so, check whether only zero bits follow. +integerLog2IsPowerOf2# (Jp# bn) = check (s -# 1#) + where + s = sizeofBigNat# bn + check :: Int# -> (# Int#, Int# #) + check i = case indexBigNat# bn i of + 0## -> check (i -# 1#) + w -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + , case w `and#` (w `minusWord#` 1##) of + 0## -> test (i -# 1#) + _ -> 1# #) + test :: Int# -> Int# + test i = if isTrue# (i <# 0#) + then 0# + else case indexBigNat# bn i of + 0## -> test (i -# 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) +roundingMode# :: Integer -> Int# -> Int# +roundingMode# (S# i#) t = + case int2Word# i# `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of + k -> case uncheckedShiftL# 1## t of + c -> if isTrue# (c `gtWord#` k) + then 0# + else if isTrue# (c `ltWord#` k) + then 2# + else 1# + +roundingMode# (Jn# bn) t = roundingMode# (Jp# bn) t -- dummy +roundingMode# (Jp# bn) t = + case word2Int# (int2Word# t `and#` MMASK##) of + j -> -- index of relevant bit in word + case uncheckedIShiftRA# t WSHIFT# of + k -> -- index of relevant word + case indexBigNat# bn k `and#` + ((uncheckedShiftL# 2## j) `minusWord#` 1##) of + r -> + case uncheckedShiftL# 1## j of + c -> if isTrue# (c `gtWord#` r) + then 0# + else if isTrue# (c `ltWord#` r) + + + then 2# + else test (k -# 1#) + where + test i = if isTrue# (i <# 0#) + then 1# + else case indexBigNat# bn i of + 0## -> test (i -# 1#) + _ -> 2# diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs new file mode 100644 index 0000000000..5670bb459f --- /dev/null +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -0,0 +1,2002 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ExplicitForAll #-} + +-- | +-- Module : GHC.Integer.Type +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- GHC needs this module to be named "GHC.Integer.Type" and provide +-- all the low-level 'Integer' operations. + +module GHC.Integer.Type where + +#include "MachDeps.h" + +-- Sanity check as CPP defines are implicitly 0-valued when undefined +#if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \ + && defined(WORD_SIZE_IN_BITS)) +# error missing defines +#endif + +import GHC.Classes +import GHC.Magic +import GHC.Prim +import GHC.Types +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +default () + +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Integer`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusInteger #-} +-- +-- which is simply expaned into a +-- +-- {-# NOINLINE plusInteger #-} +-- +#define CONSTANT_FOLDED NOINLINE + +---------------------------------------------------------------------------- +-- type definitions + +-- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS +-- The C99 code in cbits/wrappers.c will fail to compile if this doesn't hold + +-- | Type representing a GMP Limb +type GmpLimb = Word -- actually, 'CULong' +type GmpLimb# = Word# + +-- | Count of 'GmpLimb's, must be positive (unless specified otherwise). +type GmpSize = Int -- actually, a 'CLong' +type GmpSize# = Int# + +narrowGmpSize# :: Int# -> Int# +#if SIZEOF_LONG == SIZEOF_HSWORD +narrowGmpSize# x = x +#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) +-- On IL32P64 (i.e. Win64), we have to be careful with CLong not being +-- 64bit. This is mostly an issue on values returned from C functions +-- due to sign-extension. +narrowGmpSize# = narrow32Int# +#endif + + +type GmpBitCnt = Word -- actually, 'CULong' +type GmpBitCnt# = Word# -- actually, 'CULong' + +-- Pseudo FFI CType +type CInt = Int +type CInt# = Int# + +narrowCInt# :: Int# -> Int# +narrowCInt# = narrow32Int# + +-- | Bits in a 'GmpLimb'. Same as @WORD_SIZE_IN_BITS@. +gmpLimbBits :: Word -- 8 `shiftL` gmpLimbShift +gmpLimbBits = W# WORD_SIZE_IN_BITS## + +#if WORD_SIZE_IN_BITS == 64 +# define GMP_LIMB_SHIFT 3 +# define GMP_LIMB_BYTES 8 +# define GMP_LIMB_BITS 64 +# define INT_MINBOUND -0x8000000000000000 +# define INT_MAXBOUND 0x7fffffffffffffff +# define ABS_INT_MINBOUND 0x8000000000000000 +# define SQRT_INT_MAXBOUND 0xb504f333 +#elif WORD_SIZE_IN_BITS == 32 +# define GMP_LIMB_SHIFT 2 +# define GMP_LIMB_BYTES 4 +# define GMP_LIMB_BITS 32 +# define INT_MINBOUND -0x80000000 +# define INT_MAXBOUND 0x7fffffff +# define ABS_INT_MINBOUND 0x80000000 +# define SQRT_INT_MAXBOUND 0xb504 +#else +# error unsupported WORD_SIZE_IN_BITS config +#endif + +-- | Type representing /raw/ arbitrary-precision Naturals +-- +-- This is common type used by 'Natural' and 'Integer'. As this type +-- consists of a single constructor wrapping a 'ByteArray#' it can be +-- unpacked. +-- +-- Essential invariants: +-- +-- - 'ByteArray#' size is an exact multiple of 'Word#' size +-- - limbs are stored in least-significant-limb-first order, +-- - the most-significant limb must be non-zero, except for +-- - @0@ which is represented as a 1-limb. +data BigNat = BN# ByteArray# + +instance Eq BigNat where + (==) = eqBigNat + +instance Ord BigNat where + compare = compareBigNat + +-- | Invariant: 'Jn#' and 'Jp#' are used iff value doesn't fit in 'S#' +-- +-- Useful properties resulting from the invariants: +-- +-- - @abs ('S#' _) <= abs ('Jp#' _)@ +-- - @abs ('S#' _) < abs ('Jn#' _)@ +-- +data Integer = S# !Int# + -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range + | Jp# {-# UNPACK #-} !BigNat + -- ^ iff value in @]maxBound::'Int', +inf[@ range + | Jn# {-# UNPACK #-} !BigNat + -- ^ iff value in @]-inf, minBound::'Int'[@ range + +-- TODO: experiment with different constructor-ordering + +instance Eq Integer where + (==) = eqInteger + (/=) = neqInteger + +instance Ord Integer where + compare = compareInteger + (>) = gtInteger + (>=) = geInteger + (<) = ltInteger + (<=) = leInteger + +---------------------------------------------------------------------------- + +-- | Construct 'Integer' value from list of 'Int's. +-- +-- This function is used by GHC for constructing 'Integer' literals. +mkInteger :: Bool -- ^ sign of integer ('True' if non-negative) + -> [Int] -- ^ absolute value expressed in 31 bit chunks, least + -- significant first (ideally these would be machine-word + -- 'Word's rather than 31-bit truncated 'Int's) + -> Integer +mkInteger nonNegative is + | nonNegative = f is + | True = negateInteger (f is) + where + f [] = S# 0# + f (I# i : is') = smallInteger (i `andI#` 0x7fffffff#) `orInteger` + shiftLInteger (f is') 31# +{-# CONSTANT_FOLDED mkInteger #-} + +-- | Test whether all internal invariants are satisfied by 'Integer' value +-- +-- Returns @1#@ if valid, @0#@ otherwise. +-- +-- This operation is mostly useful for test-suites and/or code which +-- constructs 'Integer' values directly. +isValidInteger# :: Integer -> Int# +isValidInteger# (S# _) = 1# +isValidInteger# (Jp# bn) + = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` INT_MAXBOUND##) +isValidInteger# (Jn# bn) + = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` ABS_INT_MINBOUND##) + +-- | Should rather be called @intToInteger@ +smallInteger :: Int# -> Integer +smallInteger i# = S# i# +{-# CONSTANT_FOLDED smallInteger #-} + +---------------------------------------------------------------------------- +-- Int64/Word64 specific primitives + +#if WORD_SIZE_IN_BITS < 64 +int64ToInteger :: Int64# -> Integer +int64ToInteger i + | isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#) + , isTrue# (i `geInt64#` intToInt64# -0x80000000#) + = S# (int64ToInt# i) + | isTrue# (i `geInt64#` intToInt64# 0#) + = Jp# (word64ToBigNat (int64ToWord64# i)) + | True + = Jn# (word64ToBigNat (int64ToWord64# (negateInt64# i))) +{-# CONSTANT_FOLDED int64ToInteger #-} + +word64ToInteger :: Word64# -> Integer +word64ToInteger w + | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##) + = S# (int64ToInt# (word64ToInt64# w)) + | True + = Jp# (word64ToBigNat w) +{-# CONSTANT_FOLDED word64ToInteger #-} + +integerToInt64 :: Integer -> Int64# +integerToInt64 (S# i#) = intToInt64# i# +integerToInt64 (Jp# bn) = word64ToInt64# (bigNatToWord64 bn) +integerToInt64 (Jn# bn) = negateInt64# (word64ToInt64# (bigNatToWord64 bn)) +{-# CONSTANT_FOLDED integerToInt64 #-} + +integerToWord64 :: Integer -> Word64# +integerToWord64 (S# i#) = int64ToWord64# (intToInt64# i#) +integerToWord64 (Jp# bn) = bigNatToWord64 bn +integerToWord64 (Jn# bn) + = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64 bn))) +{-# CONSTANT_FOLDED integerToWord64 #-} + +#if GMP_LIMB_BITS == 32 +word64ToBigNat :: Word64# -> BigNat +word64ToBigNat w64 = wordToBigNat2 wh# wl# + where + wh# = word64ToWord# (uncheckedShiftRL64# w64 32#) + wl# = word64ToWord# w64 + +bigNatToWord64 :: BigNat -> Word64# +bigNatToWord64 bn + | isTrue# (sizeofBigNat# bn ># 1#) + = let wh# = wordToWord64# (indexBigNat# bn 1#) + in uncheckedShiftL64# wh# 32# `or64#` wl# + | True = wl# + where + wl# = wordToWord64# (bigNatToWord bn) +#endif +#endif + +-- End of Int64/Word64 specific primitives +---------------------------------------------------------------------------- + +-- | Truncates 'Integer' to least-significant 'Int#' +integerToInt :: Integer -> Int# +integerToInt (S# i#) = i# +integerToInt (Jp# bn) = bigNatToInt bn +integerToInt (Jn# bn) = negateInt# (bigNatToInt bn) +{-# CONSTANT_FOLDED integerToInt #-} + +hashInteger :: Integer -> Int# +hashInteger = integerToInt -- emulating what integer-{simple,gmp} already do + +integerToWord :: Integer -> Word# +integerToWord (S# i#) = int2Word# i# +integerToWord (Jp# bn) = bigNatToWord bn +integerToWord (Jn# bn) = int2Word# (negateInt# (bigNatToInt bn)) +{-# CONSTANT_FOLDED integerToWord #-} + +wordToInteger :: Word# -> Integer +wordToInteger w# + | isTrue# (i# >=# 0#) = S# i# + | True = Jp# (wordToBigNat w#) + where + i# = word2Int# w# +{-# CONSTANT_FOLDED wordToInteger #-} + +wordToNegInteger :: Word# -> Integer +wordToNegInteger w# + | isTrue# (i# <=# 0#) = S# i# + | True = Jn# (wordToBigNat w#) + where + i# = negateInt# (word2Int# w#) + +-- we could almost auto-derive Ord if it wasn't for the Jn#-Jn# case +compareInteger :: Integer -> Integer -> Ordering +compareInteger (Jn# x) (Jn# y) = compareBigNat y x +compareInteger (S# x) (S# y) = compareInt# x y +compareInteger (Jp# x) (Jp# y) = compareBigNat x y +compareInteger (Jn# _) _ = LT +compareInteger (S# _) (Jp# _) = LT +compareInteger (S# _) (Jn# _) = GT +compareInteger (Jp# _) _ = GT +{-# CONSTANT_FOLDED compareInteger #-} + +isNegInteger# :: Integer -> Int# +isNegInteger# (S# i#) = i# <# 0# +isNegInteger# (Jp# _) = 0# +isNegInteger# (Jn# _) = 1# + +-- | Not-equal predicate. +neqInteger :: Integer -> Integer -> Bool +neqInteger x y = isTrue# (neqInteger# x y) + +eqInteger, leInteger, ltInteger, gtInteger, geInteger + :: Integer -> Integer -> Bool +eqInteger x y = isTrue# (eqInteger# x y) +leInteger x y = isTrue# (leInteger# x y) +ltInteger x y = isTrue# (ltInteger# x y) +gtInteger x y = isTrue# (gtInteger# x y) +geInteger x y = isTrue# (geInteger# x y) + +eqInteger#, neqInteger#, leInteger#, ltInteger#, gtInteger#, geInteger# + :: Integer -> Integer -> Int# +eqInteger# (S# x#) (S# y#) = x# ==# y# +eqInteger# (Jn# x) (Jn# y) = eqBigNat# x y +eqInteger# (Jp# x) (Jp# y) = eqBigNat# x y +eqInteger# _ _ = 0# +{-# CONSTANT_FOLDED eqInteger# #-} + +neqInteger# (S# x#) (S# y#) = x# /=# y# +neqInteger# (Jn# x) (Jn# y) = neqBigNat# x y +neqInteger# (Jp# x) (Jp# y) = neqBigNat# x y +neqInteger# _ _ = 1# +{-# CONSTANT_FOLDED neqInteger# #-} + + +gtInteger# (S# x#) (S# y#) = x# ># y# +gtInteger# x y | inline compareInteger x y == GT = 1# +gtInteger# _ _ = 0# +{-# CONSTANT_FOLDED gtInteger# #-} + +leInteger# (S# x#) (S# y#) = x# <=# y# +leInteger# x y | inline compareInteger x y /= GT = 1# +leInteger# _ _ = 0# +{-# CONSTANT_FOLDED leInteger# #-} + +ltInteger# (S# x#) (S# y#) = x# <# y# +ltInteger# x y | inline compareInteger x y == LT = 1# +ltInteger# _ _ = 0# +{-# CONSTANT_FOLDED ltInteger# #-} + +geInteger# (S# x#) (S# y#) = x# >=# y# +geInteger# x y | inline compareInteger x y /= LT = 1# +geInteger# _ _ = 0# +{-# CONSTANT_FOLDED geInteger# #-} + +-- | Compute absolute value of an 'Integer' +absInteger :: Integer -> Integer +absInteger (Jn# n) = Jp# n +absInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) +absInteger (S# i#) | isTrue# (i# <# 0#) = S# (negateInt# i#) +absInteger i@(S# _) = i +absInteger i@(Jp# _) = i +{-# CONSTANT_FOLDED absInteger #-} + +-- | Return @-1@, @0@, and @1@ depending on whether argument is +-- negative, zero, or positive, respectively +signumInteger :: Integer -> Integer +signumInteger j = S# (signumInteger# j) +{-# CONSTANT_FOLDED signumInteger #-} + +-- | Return @-1#@, @0#@, and @1#@ depending on whether argument is +-- negative, zero, or positive, respectively +signumInteger# :: Integer -> Int# +signumInteger# (Jn# _) = -1# +signumInteger# (S# i#) = sgnI# i# +signumInteger# (Jp# _ ) = 1# + +-- | Negate 'Integer' +negateInteger :: Integer -> Integer +negateInteger (Jn# n) = Jp# n +negateInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) +negateInteger (S# i#) = S# (negateInt# i#) +negateInteger (Jp# bn) + | isTrue# (eqBigNatWord# bn ABS_INT_MINBOUND##) = S# INT_MINBOUND# + | True = Jn# bn +{-# CONSTANT_FOLDED negateInteger #-} + +-- one edge-case issue to take into account is that Int's range is not +-- symmetric around 0. I.e. @minBound+maxBound = -1@ +-- +-- Jp# is used iff n > maxBound::Int +-- Jn# is used iff n < minBound::Int + +-- | Add two 'Integer's +plusInteger :: Integer -> Integer -> Integer +plusInteger x (S# 0#) = x +plusInteger (S# 0#) y = y +plusInteger (S# x#) (S# y#) + = case addIntC# x# y# of + (# z#, 0# #) -> S# z# + (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) -- 2*minBound::Int + (# z#, _ #) + | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) + | True -> Jp# (wordToBigNat ( (int2Word# z#))) +plusInteger y@(S# _) x = plusInteger x y +-- no S# as first arg from here on +plusInteger (Jp# x) (Jp# y) = Jp# (plusBigNat x y) +plusInteger (Jn# x) (Jn# y) = Jn# (plusBigNat x y) +plusInteger (Jp# x) (S# y#) -- edge-case: @(maxBound+1) + minBound == 0@ + | isTrue# (y# >=# 0#) = Jp# (plusBigNatWord x (int2Word# y#)) + | True = bigNatToInteger (minusBigNatWord x (int2Word# + (negateInt# y#))) +plusInteger (Jn# x) (S# y#) -- edge-case: @(minBound-1) + maxBound == -2@ + | isTrue# (y# >=# 0#) = bigNatToNegInteger (minusBigNatWord x (int2Word# y#)) + | True = Jn# (plusBigNatWord x (int2Word# (negateInt# y#))) +plusInteger y@(Jn# _) x@(Jp# _) = plusInteger x y +plusInteger (Jp# x) (Jn# y) + = case compareBigNat x y of + LT -> bigNatToNegInteger (minusBigNat y x) + EQ -> S# 0# + GT -> bigNatToInteger (minusBigNat x y) +{-# CONSTANT_FOLDED plusInteger #-} + +-- TODO +-- | Subtract two 'Integer's from each other. +minusInteger :: Integer -> Integer -> Integer +minusInteger x y = inline plusInteger x (inline negateInteger y) +{-# CONSTANT_FOLDED minusInteger #-} + +-- | Multiply two 'Integer's +timesInteger :: Integer -> Integer -> Integer +timesInteger _ (S# 0#) = S# 0# +timesInteger (S# 0#) _ = S# 0# +timesInteger x (S# 1#) = x +timesInteger (S# 1#) y = y +timesInteger x (S# -1#) = negateInteger x +timesInteger (S# -1#) y = negateInteger y +timesInteger (S# x#) (S# y#) + = case mulIntMayOflo# x# y# of + 0# -> S# (x# *# y#) + _ -> timesInt2Integer x# y# +timesInteger x@(S# _) y = timesInteger y x +-- no S# as first arg from here on +timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y) +timesInteger (Jp# x) (Jn# y) = Jn# (timesBigNat x y) +timesInteger (Jp# x) (S# y#) + | isTrue# (y# >=# 0#) = Jp# (timesBigNatWord x (int2Word# y#)) + | True = Jn# (timesBigNatWord x (int2Word# (negateInt# y#))) +timesInteger (Jn# x) (Jn# y) = Jp# (timesBigNat x y) +timesInteger (Jn# x) (Jp# y) = Jn# (timesBigNat x y) +timesInteger (Jn# x) (S# y#) + | isTrue# (y# >=# 0#) = Jn# (timesBigNatWord x (int2Word# y#)) + | True = Jp# (timesBigNatWord x (int2Word# (negateInt# y#))) +{-# CONSTANT_FOLDED timesInteger #-} + +-- | Square 'Integer' +sqrInteger :: Integer -> Integer +sqrInteger (S# INT_MINBOUND#) = timesInt2Integer INT_MINBOUND# INT_MINBOUND# +sqrInteger (S# j#) | isTrue# (absI# j# <=# SQRT_INT_MAXBOUND#) = S# (j# *# j#) +sqrInteger (S# j#) = timesInt2Integer j# j# +sqrInteger (Jp# bn) = Jp# (sqrBigNat bn) +sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) + +-- | Construct 'Integer' from the product of two 'Int#'s +timesInt2Integer :: Int# -> Int# -> Integer +timesInt2Integer x# y# = case (# x# >=# 0#, y# >=# 0# #) of + (# 0#, 0# #) -> case timesWord2# (int2Word# (negateInt# x#)) + (int2Word# (negateInt# y#)) of + (# 0##,l #) -> inline wordToInteger l + (# h ,l #) -> Jp# (wordToBigNat2 h l) + + (# _, 0# #) -> case timesWord2# (int2Word# x#) + (int2Word# (negateInt# y#)) of + (# 0##,l #) -> wordToNegInteger l + (# h ,l #) -> Jn# (wordToBigNat2 h l) + + (# 0#, _ #) -> case timesWord2# (int2Word# (negateInt# x#)) + (int2Word# y#) of + (# 0##,l #) -> wordToNegInteger l + (# h ,l #) -> Jn# (wordToBigNat2 h l) + + (# _, _ #) -> case timesWord2# (int2Word# x#) + (int2Word# y#) of + (# 0##,l #) -> inline wordToInteger l + (# h ,l #) -> Jp# (wordToBigNat2 h l) + +bigNatToInteger :: BigNat -> Integer +bigNatToInteger bn + | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# >=# 0#)) = S# i# + | True = Jp# bn + where + i# = word2Int# (bigNatToWord bn) + +bigNatToNegInteger :: BigNat -> Integer +bigNatToNegInteger bn + | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# <=# 0#)) = S# i# + | True = Jn# bn + where + i# = negateInt# (word2Int# (bigNatToWord bn)) + +-- | Count number of set bits. For negative arguments returns negative +-- population count of negated argument. +popCountInteger :: Integer -> Int# +popCountInteger (S# i#) + | isTrue# (i# >=# 0#) = popCntI# i# + | True = negateInt# (popCntI# (negateInt# i#)) +popCountInteger (Jp# bn) = popCountBigNat bn +popCountInteger (Jn# bn) = negateInt# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountInteger #-} + +-- | 'Integer' for which only /n/-th bit is set. Undefined behaviour +-- for negative /n/ values. +bitInteger :: Int# -> Integer +bitInteger i# + | isTrue# (i# <# (GMP_LIMB_BITS# -# 1#)) = S# (uncheckedIShiftL# 1# i#) + | True = Jp# (bitBigNat i#) +{-# CONSTANT_FOLDED bitInteger #-} + +-- | Test if /n/-th bit is set. +testBitInteger :: Integer -> Int# -> Bool +testBitInteger _ n# | isTrue# (n# <# 0#) = False +testBitInteger (S# i#) n# + | isTrue# (n# <# GMP_LIMB_BITS#) = isTrue# (((uncheckedIShiftL# 1# n#) + `andI#` i#) /=# 0#) + | True = isTrue# (i# <# 0#) +testBitInteger (Jp# bn) n = testBitBigNat bn n +testBitInteger (Jn# bn) n = testBitNegBigNat bn n +{-# CONSTANT_FOLDED testBitInteger #-} + +-- | Bitwise @NOT@ operation +complementInteger :: Integer -> Integer +complementInteger (S# i#) = S# (notI# i#) +complementInteger (Jp# bn) = Jn# (plusBigNatWord bn 1##) +complementInteger (Jn# bn) = Jp# (minusBigNatWord bn 1##) +{-# CONSTANT_FOLDED complementInteger #-} + +-- | Arithmetic shift-right operation +-- +-- Even though the shift-amount is expressed as `Int#`, the result is +-- undefined for negative shift-amounts. +shiftRInteger :: Integer -> Int# -> Integer +shiftRInteger x 0# = x +shiftRInteger (S# i#) n# = S# (iShiftRA# i# n#) + where + iShiftRA# a b + | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#) + | True = a `uncheckedIShiftRA#` b +shiftRInteger (Jp# bn) n# = bigNatToInteger (shiftRBigNat bn n#) +shiftRInteger (Jn# bn) n# + = case bigNatToNegInteger (shiftRNegBigNat bn n#) of + S# 0# -> S# -1# + r -> r +{-# CONSTANT_FOLDED shiftRInteger #-} + +-- | Shift-left operation +-- +-- Even though the shift-amount is expressed as `Int#`, the result is +-- undefined for negative shift-amounts. +shiftLInteger :: Integer -> Int# -> Integer +shiftLInteger x 0# = x +shiftLInteger (S# 0#) _ = S# 0# +shiftLInteger (S# 1#) n# = bitInteger n# +shiftLInteger (S# i#) n# + | isTrue# (i# >=# 0#) = bigNatToInteger (shiftLBigNat + (wordToBigNat (int2Word# i#)) n#) + | True = bigNatToNegInteger (shiftLBigNat + (wordToBigNat (int2Word# + (negateInt# i#))) n#) +shiftLInteger (Jp# bn) n# = Jp# (shiftLBigNat bn n#) +shiftLInteger (Jn# bn) n# = Jn# (shiftLBigNat bn n#) +{-# CONSTANT_FOLDED shiftLInteger #-} + +-- | Bitwise OR operation +orInteger :: Integer -> Integer -> Integer +-- short-cuts +orInteger (S# 0#) y = y +orInteger x (S# 0#) = x +orInteger (S# -1#) _ = S# -1# +orInteger _ (S# -1#) = S# -1# +-- base-cases +orInteger (S# x#) (S# y#) = S# (orI# x# y#) +orInteger (Jp# x) (Jp# y) = Jp# (orBigNat x y) +orInteger (Jn# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (andBigNat + (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) 1##) +orInteger x@(Jn# _) y@(Jp# _) = orInteger y x -- retry with swapped args +orInteger (Jp# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (andnBigNat (minusBigNatWord y 1##) x) + 1##) +-- TODO/FIXpromotion-hack +orInteger x@(S# _) y = orInteger (unsafePromote x) y +orInteger x y {- S# -}= orInteger x (unsafePromote y) +{-# CONSTANT_FOLDED orInteger #-} + +-- | Bitwise XOR operation +xorInteger :: Integer -> Integer -> Integer +-- short-cuts +xorInteger (S# 0#) y = y +xorInteger x (S# 0#) = x +-- TODO: (S# -1) cases +-- base-cases +xorInteger (S# x#) (S# y#) = S# (xorI# x# y#) +xorInteger (Jp# x) (Jp# y) = bigNatToInteger (xorBigNat x y) +xorInteger (Jn# x) (Jn# y) + = bigNatToInteger (xorBigNat (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) +xorInteger x@(Jn# _) y@(Jp# _) = xorInteger y x -- retry with swapped args +xorInteger (Jp# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (xorBigNat x (minusBigNatWord y 1##)) + 1##) +-- TODO/FIXME promotion-hack +xorInteger x@(S# _) y = xorInteger (unsafePromote x) y +xorInteger x y {- S# -} = xorInteger x (unsafePromote y) +{-# CONSTANT_FOLDED xorInteger #-} + +-- | Bitwise AND operation +andInteger :: Integer -> Integer -> Integer +-- short-cuts +andInteger (S# 0#) _ = S# 0# +andInteger _ (S# 0#) = S# 0# +andInteger (S# -1#) y = y +andInteger x (S# -1#) = x +-- base-cases +andInteger (S# x#) (S# y#) = S# (andI# x# y#) +andInteger (Jp# x) (Jp# y) = bigNatToInteger (andBigNat x y) +andInteger (Jn# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (orBigNat (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) 1##) +andInteger x@(Jn# _) y@(Jp# _) = andInteger y x +andInteger (Jp# x) (Jn# y) + = bigNatToInteger (andnBigNat x (minusBigNatWord y 1##)) +-- TODO/FIXME promotion-hack +andInteger x@(S# _) y = andInteger (unsafePromote x) y +andInteger x y {- S# -}= andInteger x (unsafePromote y) +{-# CONSTANT_FOLDED andInteger #-} + +-- HACK warning! breaks invariant on purpose +unsafePromote :: Integer -> Integer +unsafePromote (S# x#) + | isTrue# (x# >=# 0#) = Jp# (wordToBigNat (int2Word# x#)) + | True = Jn# (wordToBigNat (int2Word# (negateInt# x#))) +unsafePromote x = x + +-- | Simultaneous 'quotInteger' and 'remInteger'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) +quotRemInteger n (S# 1#) = (# n, S# 0# #) +quotRemInteger n (S# -1#) = let !q = negateInteger n in (# q, (S# 0#) #) +quotRemInteger _ (S# 0#) = (# S# (quotInt# 0# 0#),S# (remInt# 0# 0#) #) +quotRemInteger (S# 0#) _ = (# S# 0#, S# 0# #) +quotRemInteger (S# n#) (S# d#) = case quotRemInt# n# d# of + (# q#, r# #) -> (# S# q#, S# r# #) +quotRemInteger (Jp# n) (Jp# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToInteger q, bigNatToInteger r #) +quotRemInteger (Jp# n) (Jn# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToNegInteger q, bigNatToInteger r #) +quotRemInteger (Jn# n) (Jn# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToInteger q, bigNatToNegInteger r #) +quotRemInteger (Jn# n) (Jp# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToNegInteger q, bigNatToNegInteger r #) +quotRemInteger (Jp# n) (S# d#) + | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of + (# q, r# #) -> (# bigNatToInteger q, inline wordToInteger r# #) + | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# bigNatToNegInteger q, inline wordToInteger r# #) +quotRemInteger (Jn# n) (S# d#) + | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of + (# q, r# #) -> (# bigNatToNegInteger q, wordToNegInteger r# #) + | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# bigNatToInteger q, wordToNegInteger r# #) +quotRemInteger n@(S# _) (Jn# _) = (# S# 0#, n #) -- since @n < d@ +quotRemInteger n@(S# n#) (Jp# d) -- need to account for (S# minBound) + | isTrue# (n# ># 0#) = (# S# 0#, n #) + | isTrue# (gtBigNatWord# d (int2Word# (negateInt# n#))) = (# S# 0#, n #) + | True {- abs(n) == d -} = (# S# -1#, S# 0# #) +{-# CONSTANT_FOLDED quotRemInteger #-} + + +quotInteger :: Integer -> Integer -> Integer +quotInteger n (S# 1#) = n +quotInteger n (S# -1#) = negateInteger n +quotInteger _ (S# 0#) = S# (quotInt# 0# 0#) +quotInteger (S# 0#) _ = S# 0# +quotInteger (S# n#) (S# d#) = S# (quotInt# n# d#) +quotInteger (Jp# n) (S# d#) + | isTrue# (d# >=# 0#) = bigNatToInteger (quotBigNatWord n (int2Word# d#)) + | True = bigNatToNegInteger (quotBigNatWord n + (int2Word# (negateInt# d#))) +quotInteger (Jn# n) (S# d#) + | isTrue# (d# >=# 0#) = bigNatToNegInteger (quotBigNatWord n (int2Word# d#)) + | True = bigNatToInteger (quotBigNatWord n + (int2Word# (negateInt# d#))) +quotInteger (Jp# n) (Jp# d) = bigNatToInteger (quotBigNat n d) +quotInteger (Jp# n) (Jn# d) = bigNatToNegInteger (quotBigNat n d) +quotInteger (Jn# n) (Jp# d) = bigNatToNegInteger (quotBigNat n d) +quotInteger (Jn# n) (Jn# d) = bigNatToInteger (quotBigNat n d) +-- handle remaining non-allocating cases +quotInteger n d = case inline quotRemInteger n d of (# q, _ #) -> q +{-# CONSTANT_FOLDED quotInteger #-} + +remInteger :: Integer -> Integer -> Integer +remInteger _ (S# 1#) = S# 0# +remInteger _ (S# -1#) = S# 0# +remInteger _ (S# 0#) = S# (remInt# 0# 0#) +remInteger (S# 0#) _ = S# 0# +remInteger (S# n#) (S# d#) = S# (remInt# n# d#) +remInteger (Jp# n) (S# d#) + = wordToInteger (remBigNatWord n (int2Word# (absI# d#))) +remInteger (Jn# n) (S# d#) + = wordToNegInteger (remBigNatWord n (int2Word# (absI# d#))) +remInteger (Jp# n) (Jp# d) = bigNatToInteger (remBigNat n d) +remInteger (Jp# n) (Jn# d) = bigNatToInteger (remBigNat n d) +remInteger (Jn# n) (Jp# d) = bigNatToNegInteger (remBigNat n d) +remInteger (Jn# n) (Jn# d) = bigNatToNegInteger (remBigNat n d) +-- handle remaining non-allocating cases +remInteger n d = case inline quotRemInteger n d of (# _, r #) -> r +{-# CONSTANT_FOLDED remInteger #-} + +-- | Simultaneous 'divInteger' and 'modInteger'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +divModInteger :: Integer -> Integer -> (# Integer, Integer #) +divModInteger n d + | isTrue# (signumInteger# r ==# negateInt# (signumInteger# d)) + = let !q' = plusInteger q (S# -1#) -- TODO: optimize + !r' = plusInteger r d + in (# q', r' #) + | True = qr + where + qr@(# q, r #) = quotRemInteger n d +{-# CONSTANT_FOLDED divModInteger #-} + +divInteger :: Integer -> Integer -> Integer +-- same-sign ops can be handled by more efficient 'quotInteger' +divInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = quotInteger n d +divInteger n d = case inline divModInteger n d of (# q, _ #) -> q +{-# CONSTANT_FOLDED divInteger #-} + +modInteger :: Integer -> Integer -> Integer +-- same-sign ops can be handled by more efficient 'remInteger' +modInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = remInteger n d +modInteger n d = case inline divModInteger n d of (# _, r #) -> r +{-# CONSTANT_FOLDED modInteger #-} + +-- | Compute greatest common divisor. +gcdInteger :: Integer -> Integer -> Integer +gcdInteger (S# 0#) b = absInteger b +gcdInteger a (S# 0#) = absInteger a +gcdInteger (S# 1#) _ = S# 1# +gcdInteger (S# -1#) _ = S# 1# +gcdInteger _ (S# 1#) = S# 1# +gcdInteger _ (S# -1#) = S# 1# +gcdInteger (S# a#) (S# b#) + = wordToInteger (gcdWord# (int2Word# (absI# a#)) (int2Word# (absI# b#))) +gcdInteger a@(S# _) b = gcdInteger b a +gcdInteger (Jn# a) b = gcdInteger (Jp# a) b +gcdInteger (Jp# a) (Jp# b) = bigNatToInteger (gcdBigNat a b) +gcdInteger (Jp# a) (Jn# b) = bigNatToInteger (gcdBigNat a b) +gcdInteger (Jp# a) (S# b#) + = wordToInteger (gcdBigNatWord a (int2Word# (absI# b#))) +{-# CONSTANT_FOLDED gcdInteger #-} + +-- | Compute least common multiple. +lcmInteger :: Integer -> Integer -> Integer +lcmInteger (S# 0#) _ = S# 0# +lcmInteger (S# 1#) b = absInteger b +lcmInteger (S# -1#) b = absInteger b +lcmInteger _ (S# 0#) = S# 0# +lcmInteger a (S# 1#) = absInteger a +lcmInteger a (S# -1#) = absInteger a +lcmInteger a b = (aa `quotInteger` (aa `gcdInteger` ab)) `timesInteger` ab + where + aa = absInteger a + ab = absInteger b +{-# CONSTANT_FOLDED lcmInteger #-} + +-- | Compute greatest common divisor. +-- +-- __Warning__: result may become negative if (at least) one argument +-- is 'minBound' +gcdInt :: Int# -> Int# -> Int# +gcdInt x# y# + = word2Int# (gcdWord# (int2Word# (absI# x#)) (int2Word# (absI# y#))) + +-- | Compute greatest common divisor. +-- +-- @since 1.0.0.0 +gcdWord :: Word# -> Word# -> Word# +gcdWord = gcdWord# + +---------------------------------------------------------------------------- +-- BigNat operations + +compareBigNat :: BigNat -> BigNat -> Ordering +compareBigNat x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) + = compareInt# (narrowCInt# (c_mpn_cmp x# y# nx#)) 0# + | isTrue# (nx# <# ny#) = LT + | True = GT + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +compareBigNatWord :: BigNat -> GmpLimb# -> Ordering +compareBigNatWord bn w# + | isTrue# (sizeofBigNat# bn ==# 1#) = cmpW# (bigNatToWord bn) w# + | True = GT + +gtBigNatWord# :: BigNat -> GmpLimb# -> Int# +gtBigNatWord# bn w# + = (sizeofBigNat# bn ># 1#) `orI#` (bigNatToWord bn `gtWord#` w#) + +eqBigNat :: BigNat -> BigNat -> Bool +eqBigNat x y = isTrue# (eqBigNat# x y) + +eqBigNat# :: BigNat -> BigNat -> Int# +eqBigNat# x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# ==# 0# + | True = 0# + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +neqBigNat# :: BigNat -> BigNat -> Int# +neqBigNat# x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# /=# 0# + | True = 1# + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +eqBigNatWord :: BigNat -> GmpLimb# -> Bool +eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#) + +eqBigNatWord# :: BigNat -> GmpLimb# -> Int# +eqBigNatWord# bn w# + = sizeofBigNat# bn ==# 1# `andI#` (bigNatToWord bn `eqWord#` w#) + + +-- | Same as @'indexBigNat#' bn 0\#@ +bigNatToWord :: BigNat -> Word# +bigNatToWord bn = indexBigNat# bn 0# + +-- | Equivalent to @'word2Int#' . 'bigNatToWord'@ +bigNatToInt :: BigNat -> Int# +bigNatToInt (BN# ba#) = indexIntArray# ba# 0# + +-- | CAF representing the value @0 :: BigNat@ +zeroBigNat :: BigNat +zeroBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# 0##) + unsafeFreezeBigNat# mbn +{-# NOINLINE zeroBigNat #-} + +-- | Test if 'BigNat' value is equal to zero. +isZeroBigNat :: BigNat -> Bool +isZeroBigNat bn = eqBigNatWord bn 0## + +-- | CAF representing the value @1 :: BigNat@ +oneBigNat :: BigNat +oneBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# 1##) + unsafeFreezeBigNat# mbn +{-# NOINLINE oneBigNat #-} + +czeroBigNat :: BigNat +czeroBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# (not# 0##)) + unsafeFreezeBigNat# mbn +{-# NOINLINE czeroBigNat #-} + +-- | Special 0-sized bigNat returned in case of arithmetic underflow +-- +-- This is currently only returned by the following operations: +-- +-- - 'minusBigNat' +-- - 'minusBigNatWord' +-- +-- Other operations such as 'quotBigNat' may return 'nullBigNat' as +-- well as a dummy/place-holder value instead of 'undefined' since we +-- can't throw exceptions. But that behaviour should not be relied +-- upon. +-- +-- NB: @isValidBigNat# nullBigNat@ is false +nullBigNat :: BigNat +nullBigNat = runS (newBigNat# 0# >>= unsafeFreezeBigNat#) +{-# NOINLINE nullBigNat #-} + +-- | Test for special 0-sized 'BigNat' representing underflows. +isNullBigNat# :: BigNat -> Int# +isNullBigNat# (BN# ba#) = sizeofByteArray# ba# ==# 0# + +-- | Construct 1-limb 'BigNat' from 'Word#' +wordToBigNat :: Word# -> BigNat +wordToBigNat 0## = zeroBigNat +wordToBigNat 1## = oneBigNat +wordToBigNat w# + | isTrue# (not# w# `eqWord#` 0##) = czeroBigNat + | True = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# w#) + unsafeFreezeBigNat# mbn + +-- | Construct BigNat from 2 limbs. +-- The first argument is the most-significant limb. +wordToBigNat2 :: Word# -> Word# -> BigNat +wordToBigNat2 0## lw# = wordToBigNat lw# +wordToBigNat2 hw# lw# = runS $ do + mbn <- newBigNat# 2# + _ <- svoid (writeBigNat# mbn 0# lw#) + _ <- svoid (writeBigNat# mbn 1# hw#) + unsafeFreezeBigNat# mbn + +plusBigNat :: BigNat -> BigNat -> BigNat +plusBigNat x y + | isTrue# (eqBigNatWord# x 0##) = y + | isTrue# (eqBigNatWord# y 0##) = x + | isTrue# (nx# >=# ny#) = go x nx# y ny# + | True = go y ny# x nx# + where + go (BN# a#) na# (BN# b#) nb# = runS $ do + mbn@(MBN# mba#) <- newBigNat# na# + (W# c#) <- liftIO (c_mpn_add mba# a# na# b# nb#) + case c# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn c# + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +plusBigNatWord :: BigNat -> GmpLimb# -> BigNat +plusBigNatWord x 0## = x +plusBigNatWord x@(BN# x#) y# = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# c#) <- liftIO (c_mpn_add_1 mba# x# nx# y#) + case c# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn c# + where + nx# = sizeofBigNat# x + +-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow +minusBigNat :: BigNat -> BigNat -> BigNat +minusBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# b#) <- liftIO (c_mpn_sub mba# x# nx# y# ny#) + case b# of + 0## -> unsafeRenormFreezeBigNat# mbn + _ -> return nullBigNat + + | True = nullBigNat + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow +minusBigNatWord :: BigNat -> GmpLimb# -> BigNat +minusBigNatWord x 0## = x +minusBigNatWord x@(BN# x#) y# = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# b#) <- liftIO $ c_mpn_sub_1 mba# x# nx# y# + case b# of + 0## -> unsafeRenormFreezeBigNat# mbn + _ -> return nullBigNat + where + nx# = sizeofBigNat# x + + +timesBigNat :: BigNat -> BigNat -> BigNat +timesBigNat x y + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = zeroBigNat + | isTrue# (nx# >=# ny#) = go x nx# y ny# + | True = go y ny# x nx# + where + go (BN# a#) na# (BN# b#) nb# = runS $ do + let n# = nx# +# ny# + mbn@(MBN# mba#) <- newBigNat# n# + (W# msl#) <- liftIO (c_mpn_mul mba# a# na# b# nb#) + case msl# of + 0## -> unsafeShrinkFreezeBigNat# mbn (n# -# 1#) + _ -> unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | Square 'BigNat' +sqrBigNat :: BigNat -> BigNat +sqrBigNat x + | isZeroBigNat x = zeroBigNat + -- TODO: 1-limb BigNats below sqrt(maxBound::GmpLimb) +sqrBigNat x = timesBigNat x x -- TODO: mpn_sqr + +timesBigNatWord :: BigNat -> GmpLimb# -> BigNat +timesBigNatWord _ 0## = zeroBigNat +timesBigNatWord x 1## = x +timesBigNatWord x@(BN# x#) y# + | isTrue# (nx# ==# 1#) = + let (# !h#, !l# #) = timesWord2# (bigNatToWord x) y# + in wordToBigNat2 h# l# + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# msl#) <- liftIO (c_mpn_mul_1 mba# x# nx# y#) + case msl# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn msl# + + where + nx# = sizeofBigNat# x + +bitBigNat :: Int# -> BigNat +bitBigNat i# = shiftLBigNat (wordToBigNat 1##) i# -- FIXME + +testBitBigNat :: BigNat -> Int# -> Bool +testBitBigNat bn i# + | isTrue# (i# <# 0#) = False + | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#) + | True = False + where + (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + nx# = sizeofBigNat# bn + +testBitNegBigNat :: BigNat -> Int# -> Bool +testBitNegBigNat bn i# + | isTrue# (i# <# 0#) = False + | isTrue# (li# >=# nx#) = True + | allZ li# = isTrue# ((testBitWord# + (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#) + | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#) + where + (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + nx# = sizeofBigNat# bn + + allZ 0# = True + allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#) + | True = False + +popCountBigNat :: BigNat -> Int# +popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn)) + + +shiftLBigNat :: BigNat -> Int# -> BigNat +shiftLBigNat x 0# = x +shiftLBigNat x _ | isZeroBigNat x = zeroBigNat +shiftLBigNat x@(BN# xba#) n# = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_lshift ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeShrinkFreezeBigNat# ymbn (yn# -# 1#) + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# +# nlimbs# +# (nbits# /=# 0#) + (# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# + + + +shiftRBigNat :: BigNat -> Int# -> BigNat +shiftRBigNat x 0# = x +shiftRBigNat x _ | isZeroBigNat x = zeroBigNat +shiftRBigNat x@(BN# xba#) n# + | isTrue# (nlimbs# >=# xn#) = zeroBigNat + | True = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_rshift ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# -# nlimbs# + nlimbs# = quotInt# n# GMP_LIMB_BITS# + +shiftRNegBigNat :: BigNat -> Int# -> BigNat +shiftRNegBigNat x 0# = x +shiftRNegBigNat x _ | isZeroBigNat x = zeroBigNat +shiftRNegBigNat x@(BN# xba#) n# + | isTrue# (nlimbs# >=# xn#) = zeroBigNat + | True = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_rshift_2c ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# -# nlimbs# + nlimbs# = quotInt# n# GMP_LIMB_BITS# + + +orBigNat :: BigNat -> BigNat -> BigNat +orBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (ior' x# nx# y# ny#) + | True = runS (ior' y# ny# x# nx#) + where + ior' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# na# + _ <- liftIO (c_mpn_ior_n mba# a# b# nb#) + _ <- case na# ==# nb# of + 0# -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + _ -> return () + unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + + +xorBigNat :: BigNat -> BigNat -> BigNat +xorBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (xor' x# nx# y# ny#) + | True = runS (xor' y# ny# x# nx#) + where + xor' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# na# + _ <- liftIO (c_mpn_xor_n mba# a# b# nb#) + case na# ==# nb# of + 0# -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + unsafeFreezeBigNat# mbn + _ -> unsafeRenormFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | aka @\x y -> x .&. (complement y)@ +andnBigNat :: BigNat -> BigNat -> BigNat +andnBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = x + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + _ <- liftIO (c_mpn_andn_n mba# x# y# n#) + _ <- case nx# ==# n# of + 0# -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) + _ -> return () + unsafeRenormFreezeBigNat# mbn + where + n# | isTrue# (nx# <# ny#) = nx# + | True = ny# + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + + +andBigNat :: BigNat -> BigNat -> BigNat +andBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = zeroBigNat + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# n# + _ <- liftIO (c_mpn_and_n mba# x# y# n#) + unsafeRenormFreezeBigNat# mbn + where + n# | isTrue# (nx# <# ny#) = nx# + | True = ny# + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | If divisor is zero, @(\# 'nullBigNat', 'nullBigNat' \#)@ is returned +quotRemBigNat :: BigNat -> BigNat -> (# BigNat,BigNat #) +quotRemBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = (# nullBigNat, nullBigNat #) + | eqBigNatWord d 1## = (# n, zeroBigNat #) + | n < d = (# zeroBigNat, n #) + | True = case runS go of (!q,!r) -> (# q, r #) + where + nn# = sizeofBigNat# n + dn# = sizeofBigNat# d + qn# = 1# +# nn# -# dn# + rn# = dn# + + go = do + qmbn@(MBN# qmba#) <- newBigNat# qn# + rmbn@(MBN# rmba#) <- newBigNat# rn# + + _ <- liftIO (c_mpn_tdiv_qr qmba# rmba# 0# nba# nn# dba# dn#) + + q <- unsafeRenormFreezeBigNat# qmbn + r <- unsafeRenormFreezeBigNat# rmbn + return (q, r) + +quotBigNat :: BigNat -> BigNat -> BigNat +quotBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = nullBigNat + | eqBigNatWord d 1## = n + | n < d = zeroBigNat + | True = runS $ do + let nn# = sizeofBigNat# n + let dn# = sizeofBigNat# d + let qn# = 1# +# nn# -# dn# + qmbn@(MBN# qmba#) <- newBigNat# qn# + _ <- liftIO (c_mpn_tdiv_q qmba# nba# nn# dba# dn#) + unsafeRenormFreezeBigNat# qmbn + +remBigNat :: BigNat -> BigNat -> BigNat +remBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = nullBigNat + | eqBigNatWord d 1## = zeroBigNat + | n < d = n + | True = runS $ do + let nn# = sizeofBigNat# n + let dn# = sizeofBigNat# d + rmbn@(MBN# rmba#) <- newBigNat# dn# + _ <- liftIO (c_mpn_tdiv_r rmba# nba# nn# dba# dn#) + unsafeRenormFreezeBigNat# rmbn + +-- | Note: Result of div/0 undefined +quotRemBigNatWord :: BigNat -> GmpLimb# -> (# BigNat, GmpLimb# #) +quotRemBigNatWord _ 0## = (# nullBigNat, 0## #) +quotRemBigNatWord n 1## = (# n, 0## #) +quotRemBigNatWord n@(BN# nba#) d# = case compareBigNatWord n d# of + LT -> (# zeroBigNat, bigNatToWord n #) + EQ -> (# oneBigNat, 0## #) + GT -> case runS go of (!q,!(W# r#)) -> (# q, r# #) -- TODO: handle word/word + where + go = do + let nn# = sizeofBigNat# n + qmbn@(MBN# qmba#) <- newBigNat# nn# + r <- liftIO (c_mpn_divrem_1 qmba# 0# nba# nn# d#) + q <- unsafeRenormFreezeBigNat# qmbn + return (q,r) + +quotBigNatWord :: BigNat -> GmpLimb# -> BigNat +quotBigNatWord n d# = case inline quotRemBigNatWord n d# of (# q, _ #) -> q + +-- | div/0 not checked +remBigNatWord :: BigNat -> GmpLimb# -> Word# +remBigNatWord n@(BN# nba#) d# = c_mpn_mod_1 nba# (sizeofBigNat# n) d# + +gcdBigNatWord :: BigNat -> Word# -> Word# +gcdBigNatWord bn@(BN# ba#) = c_mpn_gcd_1# ba# (sizeofBigNat# bn) + +gcdBigNat :: BigNat -> BigNat -> BigNat +gcdBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (gcd' x# nx# y# ny#) + | True = runS (gcd' y# ny# x# nx#) + where + gcd' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# nb# + I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#) + let rn# = narrowGmpSize# rn'# + case rn# ==# nb# of + 0# -> unsafeShrinkFreezeBigNat# mbn rn# + _ -> unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | Extended euclidean algorithm. +-- +-- For @/a/@ and @/b/@, compute their greatest common divisor @/g/@ +-- and the coefficient @/s/@ satisfying @/a//s/ + /b//t/ = /g/@. +-- +-- @since 0.5.1.0 +{-# NOINLINE gcdExtInteger #-} +gcdExtInteger :: Integer -> Integer -> (# Integer, Integer #) +gcdExtInteger a b = case gcdExtSBigNat a' b' of + (# g, s #) -> let !g' = bigNatToInteger g + !s' = sBigNatToInteger s + in (# g', s' #) + where + a' = integerToSBigNat a + b' = integerToSBigNat b + +-- internal helper +gcdExtSBigNat :: SBigNat -> SBigNat -> (# BigNat, SBigNat #) +gcdExtSBigNat x y = case runS go of (g,s) -> (# g, s #) + where + go = do + g@(MBN# g#) <- newBigNat# gn0# + s@(MBN# s#) <- newBigNat# (absI# xn#) + I# ssn_# <- liftIO (integer_gmp_gcdext# s# g# x# xn# y# yn#) + let ssn# = narrowGmpSize# ssn_# + sn# = absI# ssn# + s' <- unsafeShrinkFreezeBigNat# s sn# + g' <- unsafeRenormFreezeBigNat# g + case ssn# >=# 0# of + 0# -> return ( g', NegBN s' ) + _ -> return ( g', PosBN s' ) + + !(BN# x#) = absSBigNat x + !(BN# y#) = absSBigNat y + xn# = ssizeofSBigNat# x + yn# = ssizeofSBigNat# y + + gn0# = minI# (absI# xn#) (absI# yn#) + +---------------------------------------------------------------------------- +-- modular exponentiation + +-- | \"@'powModInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @abs(/m/)@. +-- +-- Negative exponents are supported if an inverse modulo @/m/@ +-- exists. +-- +-- __Warning__: It's advised to avoid calling this primitive with +-- negative exponents unless it is guaranteed the inverse exists, as +-- failure to do so will likely cause program abortion due to a +-- divide-by-zero fault. See also 'recipModInteger'. +-- +-- Future versions of @integer_gmp@ may not support negative @/e/@ +-- values anymore. +-- +-- @since 0.5.1.0 +{-# NOINLINE powModInteger #-} +powModInteger :: Integer -> Integer -> Integer -> Integer +powModInteger (S# b#) (S# e#) (S# m#) + | isTrue# (b# >=# 0#), isTrue# (e# >=# 0#) + = wordToInteger (powModWord (int2Word# b#) (int2Word# e#) + (int2Word# (absI# m#))) +powModInteger b e m = case m of + (S# m#) -> wordToInteger (powModSBigNatWord b' e' (int2Word# (absI# m#))) + (Jp# m') -> bigNatToInteger (powModSBigNat b' e' m') + (Jn# m') -> bigNatToInteger (powModSBigNat b' e' m') + where + b' = integerToSBigNat b + e' = integerToSBigNat e + +-- | Version of 'powModInteger' operating on 'BigNat's +-- +-- @since 1.0.0.0 +powModBigNat :: BigNat -> BigNat -> BigNat -> BigNat +powModBigNat b e m = inline powModSBigNat (PosBN b) (PosBN e) m + +-- | Version of 'powModInteger' for 'Word#'-sized moduli +-- +-- @since 1.0.0.0 +powModBigNatWord :: BigNat -> BigNat -> GmpLimb# -> GmpLimb# +powModBigNatWord b e m# = inline powModSBigNatWord (PosBN b) (PosBN e) m# + +-- | Version of 'powModInteger' operating on 'Word#'s +-- +-- @since 1.0.0.0 +foreign import ccall unsafe "integer_gmp_powm_word" + powModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# + +-- internal non-exported helper +powModSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat +powModSBigNat b e m@(BN# m#) = runS $ do + r@(MBN# r#) <- newBigNat# mn# + I# rn_# <- liftIO (integer_gmp_powm# r# b# bn# e# en# m# mn#) + let rn# = narrowGmpSize# rn_# + case rn# ==# mn# of + 0# -> unsafeShrinkFreezeBigNat# r rn# + _ -> unsafeFreezeBigNat# r + where + !(BN# b#) = absSBigNat b + !(BN# e#) = absSBigNat e + bn# = ssizeofSBigNat# b + en# = ssizeofSBigNat# e + mn# = sizeofBigNat# m + +foreign import ccall unsafe "integer_gmp_powm" + integer_gmp_powm# :: MutableByteArray# RealWorld + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +-- internal non-exported helper +powModSBigNatWord :: SBigNat -> SBigNat -> GmpLimb# -> GmpLimb# +powModSBigNatWord b e m# = integer_gmp_powm1# b# bn# e# en# m# + where + !(BN# b#) = absSBigNat b + !(BN# e#) = absSBigNat e + bn# = ssizeofSBigNat# b + en# = ssizeofSBigNat# e + +foreign import ccall unsafe "integer_gmp_powm1" + integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> GmpLimb# + + +-- | \"@'recipModInteger' /x/ /m/@\" computes the inverse of @/x/@ modulo @/m/@. If +-- the inverse exists, the return value @/y/@ will satisfy @0 < /y/ < +-- abs(/m/)@, otherwise the result is @0@. +-- +-- @since 0.5.1.0 +{-# NOINLINE recipModInteger #-} +recipModInteger :: Integer -> Integer -> Integer +recipModInteger (S# x#) (S# m#) + | isTrue# (x# >=# 0#) + = wordToInteger (recipModWord (int2Word# x#) (int2Word# (absI# m#))) +recipModInteger x m = bigNatToInteger (recipModSBigNat x' m') + where + x' = integerToSBigNat x + m' = absSBigNat (integerToSBigNat m) + +-- | Version of 'recipModInteger' operating on 'BigNat's +-- +-- @since 1.0.0.0 +recipModBigNat :: BigNat -> BigNat -> BigNat +recipModBigNat x m = inline recipModSBigNat (PosBN x) m + +-- | Version of 'recipModInteger' operating on 'Word#'s +-- +-- @since 1.0.0.0 +foreign import ccall unsafe "integer_gmp_invert_word" + recipModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# + +-- internal non-exported helper +recipModSBigNat :: SBigNat -> BigNat -> BigNat +recipModSBigNat x m@(BN# m#) = runS $ do + r@(MBN# r#) <- newBigNat# mn# + I# rn_# <- liftIO (integer_gmp_invert# r# x# xn# m# mn#) + let rn# = narrowGmpSize# rn_# + case rn# ==# mn# of + 0# -> unsafeShrinkFreezeBigNat# r rn# + _ -> unsafeFreezeBigNat# r + where + !(BN# x#) = absSBigNat x + xn# = ssizeofSBigNat# x + mn# = sizeofBigNat# m + +foreign import ccall unsafe "integer_gmp_invert" + integer_gmp_invert# :: MutableByteArray# RealWorld + -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +---------------------------------------------------------------------------- +-- Conversions to/from floating point + +decodeDoubleInteger :: Double# -> (# Integer, Int# #) +-- decodeDoubleInteger 0.0## = (# S# 0#, 0# #) +#if WORD_SIZE_IN_BITS == 64 +decodeDoubleInteger x = case decodeDouble_Int64# x of + (# m#, e# #) -> (# S# m#, e# #) +#elif WORD_SIZE_IN_BITS == 32 +decodeDoubleInteger x = case decodeDouble_Int64# x of + (# m#, e# #) -> (# int64ToInteger m#, e# #) +#endif +{-# CONSTANT_FOLDED decodeDoubleInteger #-} + +-- provided by GHC's RTS +foreign import ccall unsafe "__int_encodeDouble" + int_encodeDouble# :: Int# -> Int# -> Double# + +encodeDoubleInteger :: Integer -> Int# -> Double# +encodeDoubleInteger (S# m#) 0# = int2Double# m# +encodeDoubleInteger (S# m#) e# = int_encodeDouble# m# e# +encodeDoubleInteger (Jp# bn@(BN# bn#)) e# + = c_mpn_get_d bn# (sizeofBigNat# bn) e# +encodeDoubleInteger (Jn# bn@(BN# bn#)) e# + = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) e# +{-# CONSTANT_FOLDED encodeDoubleInteger #-} + +-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) +foreign import ccall unsafe "integer_gmp_mpn_get_d" + c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# + +doubleFromInteger :: Integer -> Double# +doubleFromInteger (S# m#) = int2Double# m# +doubleFromInteger (Jp# bn@(BN# bn#)) + = c_mpn_get_d bn# (sizeofBigNat# bn) 0# +doubleFromInteger (Jn# bn@(BN# bn#)) + = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) 0# +{-# CONSTANT_FOLDED doubleFromInteger #-} + +-- TODO: Not sure if it's worth to write 'Float' optimized versions here +floatFromInteger :: Integer -> Float# +floatFromInteger i = double2Float# (doubleFromInteger i) + +encodeFloatInteger :: Integer -> Int# -> Float# +encodeFloatInteger m e = double2Float# (encodeDoubleInteger m e) + +---------------------------------------------------------------------------- +-- FFI ccall imports + +foreign import ccall unsafe "integer_gmp_gcd_word" + gcdWord# :: GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd_1" + c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd" + c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +foreign import ccall unsafe "integer_gmp_gcdext" + integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s + -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +-- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_add_1" + c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_sub_1" + c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mul_1" + c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_add" + c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_sub" + c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_mul" + c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_cmp" + c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> CInt# + +-- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, +-- const mp_limb_t *np, mp_size_t nn, +-- const mp_limb_t *dp, mp_size_t dn) +foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" + c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" + c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" + c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +-- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, +-- mp_size_t s2n, mp_limb_t s3limb) +foreign import ccall unsafe "gmp.h __gmpn_divrem_1" + c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> IO GmpLimb + +-- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mod_1" + c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift" + c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" + c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_lshift" + c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_and_n" + c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_andn_n" + c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_ior_n" + c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_xor_n" + c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_popcount" + c_mpn_popcount :: ByteArray# -> GmpSize# -> GmpBitCnt# + +---------------------------------------------------------------------------- +-- BigNat-wrapped ByteArray#-primops + +-- | Return number of limbs contained in 'BigNat'. +sizeofBigNat# :: BigNat -> GmpSize# +sizeofBigNat# (BN# x#) + = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + +data MutBigNat s = MBN# !(MutableByteArray# s) + +sizeofMutBigNat# :: MutBigNat s -> GmpSize# +sizeofMutBigNat# (MBN# x#) + = sizeofMutableByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + +newBigNat# :: GmpSize# -> S s (MutBigNat s) +newBigNat# limbs# s = + case newByteArray# (limbs# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) s of + (# s', mba# #) -> (# s', MBN# mba# #) + +writeBigNat# :: MutBigNat s -> GmpSize# -> GmpLimb# -> State# s -> State# s +writeBigNat# (MBN# mba#) = writeWordArray# mba# + +-- | Extract /n/-th (0-based) limb in 'BigNat'. +-- /n/ must be less than size as reported by 'sizeofBigNat#'. +indexBigNat# :: BigNat -> GmpSize# -> GmpLimb# +indexBigNat# (BN# ba#) = indexWordArray# ba# + +unsafeFreezeBigNat# :: MutBigNat s -> S s BigNat +unsafeFreezeBigNat# (MBN# mba#) s = case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', BN# ba# #) + +resizeMutBigNat# :: MutBigNat s -> GmpSize# -> S s (MutBigNat s) +resizeMutBigNat# (MBN# mba0#) nsz# s + | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = (# s, MBN# mba0# #) + | True = case resizeMutableByteArray# mba0# bsz# s of + (# s', mba# #) -> (# s' , MBN# mba# #) + where + bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# + +shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s +shrinkMutBigNat# (MBN# mba0#) nsz# + | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = \s -> s -- no-op + | True = shrinkMutableByteArray# mba0# bsz# + where + bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# + +unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat +unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# = do + -- (MBN# mba#) <- newBigNat# (n# +# 1#) + -- _ <- svoid (copyMutableByteArray# mba0# 0# mba# 0# nb0#) + (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) + _ <- svoid (writeWordArray# mba# n# limb#) + unsafeFreezeBigNat# (MBN# mba#) + where + n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + nb0# = sizeofMutableByteArray# mba0# + +-- | May shrink underlyng 'ByteArray#' if needed to satisfy BigNat invariant +unsafeRenormFreezeBigNat# :: MutBigNat s -> S s BigNat +unsafeRenormFreezeBigNat# mbn s + | isTrue# (n0# ==# 0#) = (# s', nullBigNat #) + | isTrue# (n# ==# 0#) = (# s', zeroBigNat #) + | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s' + | True = (unsafeShrinkFreezeBigNat# mbn n#) s' + where + (# s', n# #) = normSizeofMutBigNat'# mbn n0# s + n0# = sizeofMutBigNat# mbn + +-- | Shrink MBN +unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat +unsafeShrinkFreezeBigNat# x@(MBN# xmba) 1# + = \s -> case readWordArray# xmba 0# s of + (# s', w# #) -> freezeOneLimb w# s' + where + freezeOneLimb 0## = return zeroBigNat + freezeOneLimb 1## = return oneBigNat + freezeOneLimb w# | isTrue# (not# w# `eqWord#` 0##) = return czeroBigNat + freezeOneLimb _ = do + _ <- svoid (shrinkMutBigNat# x 1#) + unsafeFreezeBigNat# x +unsafeShrinkFreezeBigNat# x y# = do + _ <- svoid (shrinkMutBigNat# x y#) + unsafeFreezeBigNat# x + + +copyWordArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# + -> State# s -> State# s +copyWordArray# src src_ofs dst dst_ofs len + = copyByteArray# src (src_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + +-- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#' +normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) +normSizeofMutBigNat# mbn@(MBN# mba) = normSizeofMutBigNat'# mbn sz# + where + sz# = sizeofMutableByteArray# mba `uncheckedIShiftRA#` GMP_LIMB_SHIFT# + +-- | Find most-significant non-zero limb and return its index-position +-- plus one. Start scanning downward from the initial limb-size +-- (i.e. start-index plus one) given as second argument. +-- +-- NB: The 'normSizeofMutBigNat' of 'zeroBigNat' would be @0#@ +normSizeofMutBigNat'# :: MutBigNat s -> GmpSize# + -> State# s -> (# State# s, GmpSize# #) +normSizeofMutBigNat'# (MBN# mba) = go + where + go 0# s = (# s, 0# #) + go i0# s = case readWordArray# mba (i0# -# 1#) s of + (# s', 0## #) -> go (i0# -# 1#) s' + (# s', _ #) -> (# s', i0# #) + +-- | Construct 'BigNat' from existing 'ByteArray#' containing /n/ +-- 'GmpLimb's in least-significant-first order. +-- +-- If possible 'ByteArray#', will be used directly (i.e. shared +-- /without/ cloning the 'ByteArray#' into a newly allocated one) +-- +-- Note: size parameter (times @sizeof(GmpLimb)@) must be less or +-- equal to its 'sizeofByteArray#'. +byteArrayToBigNat# :: ByteArray# -> GmpSize# -> BigNat +byteArrayToBigNat# ba# n0# + | isTrue# (n# ==# 0#) = zeroBigNat + | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size + , isTrue# (baszq# ==# n#) = (BN# ba#) + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# n# + _ <- svoid (copyByteArray# ba# 0# mba# 0# (sizeofMutableByteArray# mba#)) + unsafeFreezeBigNat# mbn + where + (# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# + + n# = fmssl (n0# -# 1#) + + -- find most signifcant set limb, return normalized size + fmssl i# + | isTrue# (i# <# 0#) = 0# + | isTrue# (neWord# (indexWordArray# ba# i#) 0##) = i# +# 1# + | True = fmssl (i# -# 1#) + +-- | Read 'Integer' (without sign) from memory location at @/addr/@ in +-- base-256 representation. +-- +-- @'importIntegerFromAddr' /addr/ /size/ /msbf/@ +-- +-- See description of 'importIntegerFromByteArray' for more details. +-- +-- @since 1.0.0.0 +importIntegerFromAddr :: Addr# -> Word# -> Int# -> IO Integer +importIntegerFromAddr addr len msbf = IO $ do + bn <- liftIO (importBigNatFromAddr addr len msbf) + return (bigNatToInteger bn) + +-- | Version of 'importIntegerFromAddr' constructing a 'BigNat' +importBigNatFromAddr :: Addr# -> Word# -> Int# -> IO BigNat +importBigNatFromAddr _ 0## _ = IO (\s -> (# s, zeroBigNat #)) +importBigNatFromAddr addr len0 1# = IO $ do -- MSBF + W# ofs <- liftIO (c_scan_nzbyte_addr addr 0## len0) + let len = len0 `minusWord#` ofs + addr' = addr `plusAddr#` (word2Int# ofs) + importBigNatFromAddr# addr' len 1# +importBigNatFromAddr addr len0 _ = IO $ do -- LSBF + W# len <- liftIO (c_rscan_nzbyte_addr addr 0## len0) + importBigNatFromAddr# addr len 0# + +foreign import ccall unsafe "integer_gmp_scan_nzbyte" + c_scan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word + +foreign import ccall unsafe "integer_gmp_rscan_nzbyte" + c_rscan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word + +-- | Helper for 'importBigNatFromAddr' +importBigNatFromAddr# :: Addr# -> Word# -> Int# -> S RealWorld BigNat +importBigNatFromAddr# _ 0## _ = return zeroBigNat +importBigNatFromAddr# addr len msbf = do + mbn@(MBN# mba#) <- newBigNat# n# + () <- liftIO (c_mpn_import_addr mba# addr 0## len msbf) + unsafeFreezeBigNat# mbn + where + -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required + n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# + +foreign import ccall unsafe "integer_gmp_mpn_import" + c_mpn_import_addr :: MutableByteArray# RealWorld -> Addr# -> Word# -> Word# + -> Int# -> IO () + +-- | Read 'Integer' (without sign) from byte-array in base-256 representation. +-- +-- The call +-- +-- @'importIntegerFromByteArray' /ba/ /offset/ /size/ /msbf/@ +-- +-- reads +-- +-- * @/size/@ bytes from the 'ByteArray#' @/ba/@ starting at @/offset/@ +-- +-- * with most significant byte first if @/msbf/@ is @1#@ or least +-- significant byte first if @/msbf/@ is @0#@, and +-- +-- * returns a new 'Integer' +-- +-- @since 1.0.0.0 +importIntegerFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> Integer +importIntegerFromByteArray ba ofs len msbf + = bigNatToInteger (importBigNatFromByteArray ba ofs len msbf) + +-- | Version of 'importIntegerFromByteArray' constructing a 'BigNat' +importBigNatFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> BigNat +importBigNatFromByteArray _ _ 0## _ = zeroBigNat +importBigNatFromByteArray ba ofs0 len0 1# = runS $ do -- MSBF + W# ofs <- liftIO (c_scan_nzbyte_bytearray ba ofs0 len0) + let len = (len0 `plusWord#` ofs0) `minusWord#` ofs + importBigNatFromByteArray# ba ofs len 1# +importBigNatFromByteArray ba ofs len0 _ = runS $ do -- LSBF + W# len <- liftIO (c_rscan_nzbyte_bytearray ba ofs len0) + importBigNatFromByteArray# ba ofs len 0# + +foreign import ccall unsafe "integer_gmp_scan_nzbyte" + c_scan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word + +foreign import ccall unsafe "integer_gmp_rscan_nzbyte" + c_rscan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word + +-- | Helper for 'importBigNatFromByteArray' +importBigNatFromByteArray# :: ByteArray# -> Word# -> Word# -> Int# + -> S RealWorld BigNat +importBigNatFromByteArray# _ _ 0## _ = return zeroBigNat +importBigNatFromByteArray# ba ofs len msbf = do + mbn@(MBN# mba#) <- newBigNat# n# + () <- liftIO (c_mpn_import_bytearray mba# ba ofs len msbf) + unsafeFreezeBigNat# mbn + where + -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required + n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# + +foreign import ccall unsafe "integer_gmp_mpn_import" + c_mpn_import_bytearray :: MutableByteArray# RealWorld -> ByteArray# -> Word# + -> Word# -> Int# -> IO () + +-- | Test whether all internal invariants are satisfied by 'BigNat' value +-- +-- Returns @1#@ if valid, @0#@ otherwise. +-- +-- This operation is mostly useful for test-suites and/or code which +-- constructs 'Integer' values directly. +isValidBigNat# :: BigNat -> Int# +isValidBigNat# (BN# ba#) + = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm# + where + isNorm# = case szq# ># 1# of + 1# -> (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## + _ -> 1# + + sz# = sizeofByteArray# ba# + + (# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# + +-- | Version of 'nextPrimeInteger' operating on 'BigNat's +-- +-- @since 1.0.0.0 +nextPrimeBigNat :: BigNat -> BigNat +nextPrimeBigNat bn@(BN# ba#) = runS $ do + mbn@(MBN# mba#) <- newBigNat# n# + (W# c#) <- liftIO (nextPrime# mba# ba# n#) + case c# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn c# + where + n# = sizeofBigNat# bn + +foreign import ccall unsafe "integer_gmp_next_prime" + nextPrime# :: MutableByteArray# RealWorld -> ByteArray# -> GmpSize# + -> IO GmpLimb + +---------------------------------------------------------------------------- +-- monadic combinators for low-level state threading + +type S s a = State# s -> (# State# s, a #) + +infixl 1 >>= +infixl 1 >> +infixr 0 $ + +{-# INLINE ($) #-} +($) :: (a -> b) -> a -> b +f $ x = f x + +{-# INLINE (>>=) #-} +(>>=) :: S s a -> (a -> S s b) -> S s b +(>>=) m k = \s -> case m s of (# s', a #) -> k a s' + +{-# INLINE (>>) #-} +(>>) :: S s a -> S s b -> S s b +(>>) m k = \s -> case m s of (# s', _ #) -> k s' + +{-# INLINE svoid #-} +svoid :: (State# s -> State# s) -> S s () +svoid m0 = \s -> case m0 s of s' -> (# s', () #) + +{-# INLINE return #-} +return :: a -> S s a +return a = \s -> (# s, a #) + +{-# INLINE liftIO #-} +liftIO :: IO a -> S RealWorld a +liftIO (IO m) = m + +-- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there +runS :: S RealWorld a -> a +runS m = lazy (case m realWorld# of (# _, r #) -> r) +{-# NOINLINE runS #-} + +-- stupid hack +fail :: [Char] -> S s a +fail s = return (raise# s) + +---------------------------------------------------------------------------- + +-- | Internal helper type for "signed" 'BigNat's +-- +-- This is a useful abstraction for operations which support negative +-- mp_size_t arguments. +data SBigNat = NegBN !BigNat | PosBN !BigNat + +-- | Absolute value of 'SBigNat' +absSBigNat :: SBigNat -> BigNat +absSBigNat (NegBN bn) = bn +absSBigNat (PosBN bn) = bn + +-- | /Signed/ limb count. Negative sizes denote negative integers +ssizeofSBigNat# :: SBigNat -> GmpSize# +ssizeofSBigNat# (NegBN bn) = negateInt# (sizeofBigNat# bn) +ssizeofSBigNat# (PosBN bn) = sizeofBigNat# bn + +-- | Construct 'SBigNat' from 'Int#' value +intToSBigNat# :: Int# -> SBigNat +intToSBigNat# 0# = PosBN zeroBigNat +intToSBigNat# 1# = PosBN oneBigNat +intToSBigNat# (-1#) = NegBN oneBigNat +intToSBigNat# i# | isTrue# (i# ># 0#) = PosBN (wordToBigNat (int2Word# i#)) + | True = PosBN (wordToBigNat (int2Word# (negateInt# i#))) + +-- | Convert 'Integer' into 'SBigNat' +integerToSBigNat :: Integer -> SBigNat +integerToSBigNat (S# i#) = intToSBigNat# i# +integerToSBigNat (Jp# bn) = PosBN bn +integerToSBigNat (Jn# bn) = NegBN bn + +-- | Convert 'SBigNat' into 'Integer' +sBigNatToInteger :: SBigNat -> Integer +sBigNatToInteger (NegBN bn) = bigNatToNegInteger bn +sBigNatToInteger (PosBN bn) = bigNatToInteger bn + +---------------------------------------------------------------------------- +-- misc helpers, some of these should rather be primitives exported by ghc-prim + +cmpW# :: Word# -> Word# -> Ordering +cmpW# x# y# + | isTrue# (x# `ltWord#` y#) = LT + | isTrue# (x# `eqWord#` y#) = EQ + | True = GT +{-# INLINE cmpW# #-} + +subWordC# :: Word# -> Word# -> (# Word#, Int# #) +subWordC# x# y# = (# d#, c# #) + where + d# = x# `minusWord#` y# + c# = d# `gtWord#` x# +{-# INLINE subWordC# #-} + +bitWord# :: Int# -> Word# +bitWord# = uncheckedShiftL# 1## +{-# INLINE bitWord# #-} + +testBitWord# :: Word# -> Int# -> Int# +testBitWord# w# i# = (bitWord# i# `and#` w#) `neWord#` 0## +{-# INLINE testBitWord# #-} + +popCntI# :: Int# -> Int# +popCntI# i# = word2Int# (popCnt# (int2Word# i#)) +{-# INLINE popCntI# #-} + +-- branchless version +absI# :: Int# -> Int# +absI# i# = (i# `xorI#` nsign) -# nsign + where + -- nsign = negateInt# (i# <# 0#) + nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#) + +-- branchless version +sgnI# :: Int# -> Int# +sgnI# x# = (x# ># 0#) -# (x# <# 0#) + +cmpI# :: Int# -> Int# -> Int# +cmpI# x# y# = (x# ># y#) -# (x# <# y#) + +minI# :: Int# -> Int# -> Int# +minI# x# y# | isTrue# (x# <=# y#) = x# + | True = y# |