diff options
Diffstat (limited to 'libraries/integer-gmp/src')
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer.hs | 75 | ||||
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs | 358 | ||||
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/Logarithms.hs | 74 | ||||
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs | 118 | ||||
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/Type.hs | 2202 |
5 files changed, 54 insertions, 2773 deletions
diff --git a/libraries/integer-gmp/src/GHC/Integer.hs b/libraries/integer-gmp/src/GHC/Integer.hs deleted file mode 100644 index 6a0d16d553..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} - -#include "MachDeps.h" - --- | --- Module : GHC.Integer.Type --- Copyright : (c) Herbert Valerio Riedel 2014 --- License : BSD3 --- --- 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 @integer-gmp@-specific internal --- representation of 'Integer' as well as optimized GMP-specific --- operations. - -module GHC.Integer ( - Integer, - - -- * Construct 'Integer's - mkInteger, smallInteger, wordToInteger, -#if WORD_SIZE_IN_BITS < 64 - word64ToInteger, int64ToInteger, -#endif - -- * Conversion to other integral types - integerToWord, integerToInt, -#if WORD_SIZE_IN_BITS < 64 - integerToWord64, integerToInt64, -#endif - - -- * Helpers for 'RealFloat' type-class operations - encodeFloatInteger, floatFromInteger, - encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger, - - -- * Arithmetic operations - plusInteger, minusInteger, timesInteger, negateInteger, - absInteger, signumInteger, - - divModInteger, divInteger, modInteger, - quotRemInteger, quotInteger, remInteger, - - -- * Comparison predicates - eqInteger, neqInteger, leInteger, gtInteger, ltInteger, geInteger, - compareInteger, - - -- ** 'Int#'-boolean valued versions of comparison predicates - -- - -- | These operations return @0#@ and @1#@ instead of 'False' and - -- 'True' respectively. See - -- <https://gitlab.haskell.org/ghc/ghc/wikis/prim-bool PrimBool wiki-page> - -- for more details - eqInteger#, neqInteger#, leInteger#, gtInteger#, ltInteger#, geInteger#, - - - -- * Bit-operations - andInteger, orInteger, xorInteger, - - complementInteger, - shiftLInteger, shiftRInteger, testBitInteger, - - popCountInteger, bitInteger, - - -- * Hashing - hashInteger, - ) where - -import GHC.Integer.Type - -default () diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs index 6eb88bd943..3af21e7e74 100644 --- a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs +++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs @@ -1,13 +1,10 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CApiFFI #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} #include "MachDeps.h" @@ -20,20 +17,9 @@ -- 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://gitlab.haskell.org/ghc/ghc/wikis/commentary/libraries/integer GHC Commentary: Libraries/Integer>. - module GHC.Integer.GMP.Internals ( -- * The 'Integer' type - Integer(..) + Integer (S#,Jn#,Jp#) , isValidInteger# -- ** Basic 'Integer' operations @@ -42,12 +28,8 @@ module GHC.Integer.GMP.Internals -- ** Additional 'Integer' operations , gcdInteger - , gcdExtInteger , lcmInteger , sqrInteger - , powModInteger - , powModSecInteger - , recipModInteger -- ** Additional conversion operations to 'Integer' , wordToNegInteger @@ -60,305 +42,73 @@ module GHC.Integer.GMP.Internals , 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 - , clearBitBigNat - , complementBitBigNat - , setBitBigNat - , andBigNat - , xorBigNat - , popCountBigNat - , orBigNat - , bitBigNat - - -- ** 'BigNat' comparison 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.Natural +import GHC.Num.Integer (Integer(..)) +import qualified GHC.Num.Integer as I import GHC.Types +import GHC.Prim -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 +{-# COMPLETE S#, Jp#, Jn# #-} -foreign import ccall unsafe "integer_gmp_mpn_export1" - c_mpn_export1ToAddr# :: GmpLimb# -> Addr# -> Int# -> Int# - -> IO Word +{-# DEPRECATED S# "Use IS constructor instead" #-} +pattern S# :: Int# -> Integer +pattern S# i = IS i --- | 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 +fromBN# :: BigNat -> ByteArray# +fromBN# (BN# x) = x --- | 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) +fromIP :: Integer -> (# () | BigNat #) +fromIP (IP x) = (# | BN# x #) +fromIP _ = (# () | #) -foreign import ccall unsafe "integer_gmp_mpn_export" - c_mpn_exportToMutableByteArray# :: ByteArray# -> GmpSize# - -> MutableByteArray# RealWorld -> Word# - -> Int# -> IO Word +fromIN :: Integer -> (# () | BigNat #) +fromIN (IN x) = (# | BN# x #) +fromIN _ = (# () | #) --- | 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# +{-# DEPRECATED Jp# "Use IP constructor instead" #-} +pattern Jp# :: BigNat -> Integer +pattern Jp# i <- (fromIP -> (# | i #)) + where + Jp# i = IP (fromBN# i) -foreign import ccall unsafe "integer_gmp_mpn_export1" - c_mpn_export1ToMutableByteArray# :: GmpLimb# -> MutableByteArray# RealWorld - -> Word# -> Int# -> IO Word +{-# DEPRECATED Jn# "Use IN constructor instead" #-} +pattern Jn# :: BigNat -> Integer +pattern Jn# i <- (fromIN -> (# | i #)) + where + Jn# i = IN (fromBN# i) +{-# DEPRECATED isValidInteger# "Use integerCheck# instead" #-} +isValidInteger# :: Integer -> Int# +isValidInteger# = I.integerCheck# --- | 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 +{-# DEPRECATED gcdInteger "Use integerGcd instead" #-} +gcdInteger :: Integer -> Integer -> Integer +gcdInteger = I.integerGcd --- | 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) +{-# DEPRECATED lcmInteger "Use integerLcm instead" #-} +lcmInteger :: Integer -> Integer -> Integer +lcmInteger = I.integerLcm -foreign import ccall unsafe "integer_gmp_test_prime" - c_integer_gmp_test_prime# :: ByteArray# -> GmpSize# -> Int# -> Int# +{-# DEPRECATED sqrInteger "Use integerSqr instead" #-} +sqrInteger :: Integer -> Integer +sqrInteger = I.integerSqr --- | Version of 'testPrimeInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_test_prime1" - testPrimeWord# :: GmpLimb# -> Int# -> Int# +{-# DEPRECATED wordToNegInteger "Use integerFromWordNeg# instead" #-} +wordToNegInteger :: Word# -> Integer +wordToNegInteger = I.integerFromWordNeg# +{-# DEPRECATED bigNatToInteger "Use integerFromBigNat instead" #-} +bigNatToInteger :: BigNat -> Integer +bigNatToInteger (BN# i) = I.integerFromBigNat i --- | 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# +{-# DEPRECATED bigNatToNegInteger "Use integerFromBigNatNeg instead" #-} +bigNatToNegInteger :: BigNat -> Integer +bigNatToNegInteger (BN# i) = I.integerFromBigNatNeg i --- | Version of 'nextPrimeInteger' operating on 'Word#'s --- --- @since 1.0.0.0 -foreign import ccall unsafe "integer_gmp_next_prime1" - nextPrimeWord# :: GmpLimb# -> GmpLimb# +type GmpLimb = Word +type GmpLimb# = Word# +type GmpSize = Int +type GmpSize# = Int# diff --git a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs b/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs deleted file mode 100644 index 76467e18a7..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Logarithms.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - -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 deleted file mode 100644 index 5f50c79e41..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Logarithms/Internals.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_HADDOCK not-home #-} - -#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://gitlab.haskell.org/ghc/ghc/issues/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 deleted file mode 100644 index cc94089828..0000000000 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ /dev/null @@ -1,2202 +0,0 @@ -{-# 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" -#include "HsIntegerGmp.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 expanded 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 - --- [Implementation notes] --- --- 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#' _)@ - --- | Arbitrary precision integers. In contrast with fixed-size integral types --- such as 'Int', the 'Integer' type represents the entire infinite range of --- integers. --- --- For more information about this type's representation, see the comments in --- its implementation. -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 - --- NOTE: the above representation is baked into the GHCi debugger in --- GHC.Runtime.Heap.Inspect. If you change it here, fixes --- will be required over there too. Tests for this are in --- testsuite/tests/ghci.debugger. - --- 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 #-} - --- | Subtract one 'Integer' from another. -minusInteger :: Integer -> Integer -> Integer -minusInteger x (S# 0#) = x -minusInteger (S# x#) (S# y#) - = case subIntC# x# y# of - (# z#, 0# #) -> S# z# - (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) - (# z#, _ #) - | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) - | True -> Jp# (wordToBigNat ( (int2Word# z#))) -minusInteger (S# x#) (Jp# y) - | isTrue# (x# >=# 0#) = bigNatToNegInteger (minusBigNatWord y (int2Word# x#)) - | True = Jn# (plusBigNatWord y (int2Word# (negateInt# x#))) -minusInteger (S# x#) (Jn# y) - | isTrue# (x# >=# 0#) = Jp# (plusBigNatWord y (int2Word# x#)) - | True = bigNatToInteger (minusBigNatWord y (int2Word# - (negateInt# x#))) -minusInteger (Jp# x) (Jp# y) - = case compareBigNat x y of - LT -> bigNatToNegInteger (minusBigNat y x) - EQ -> S# 0# - GT -> bigNatToInteger (minusBigNat x y) -minusInteger (Jp# x) (Jn# y) = Jp# (plusBigNat x y) -minusInteger (Jn# x) (Jp# y) = Jn# (plusBigNat x y) -minusInteger (Jn# x) (Jn# y) - = case compareBigNat x y of - LT -> bigNatToInteger (minusBigNat y x) - EQ -> S# 0# - GT -> bigNatToNegInteger (minusBigNat x y) -minusInteger (Jp# x) (S# y#) - | isTrue# (y# >=# 0#) = bigNatToInteger (minusBigNatWord x (int2Word# y#)) - | True = Jp# (plusBigNatWord x (int2Word# (negateInt# y#))) -minusInteger (Jn# x) (S# y#) - | isTrue# (y# >=# 0#) = Jn# (plusBigNatWord x (int2Word# y#)) - | True = bigNatToNegInteger (minusBigNatWord x - (int2Word# (negateInt# 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 timesInt2# x# y# of - (# 0#, _h, l #) -> S# l - (# _ , h, l #) -> int2ToInteger h l -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) - --- | Convert two Int# (resp. high and low bits of a double-word Int#) into an --- Integer --- --- Warning: currently it doesn't handle the case where high=minBound and low=0 --- (i.e. high:low = 100......00 = minBound for a double-word Int) -int2ToInteger :: Int# -> Int# -> Integer -int2ToInteger h l - | isTrue# (h <# 0#) = - case addWordC# (not# (int2Word# l)) 1## of -- two's complement... - (# lw,c #) -> Jn# (wordToBigNat2 - -- add the carry to the high word - (int2Word# c `plusWord#` not# (int2Word# h)) - lw - ) - | True = Jp# (wordToBigNat2 (int2Word# h) (int2Word# l)) - --- | Construct 'Integer' from the product of two 'Int#'s -timesInt2Integer :: Int# -> Int# -> Integer -timesInt2Integer x# y# = case (# isTrue# (x# >=# 0#), isTrue# (y# >=# 0#) #) of - (# False, False #) -> case timesWord2# (int2Word# (negateInt# x#)) - (int2Word# (negateInt# y#)) of - (# 0##,l #) -> inline wordToInteger l - (# h ,l #) -> Jp# (wordToBigNat2 h l) - - (# True, False #) -> case timesWord2# (int2Word# x#) - (int2Word# (negateInt# y#)) of - (# 0##,l #) -> wordToNegInteger l - (# h ,l #) -> Jn# (wordToBigNat2 h l) - - (# False, True #) -> case timesWord2# (int2Word# (negateInt# x#)) - (int2Word# y#) of - (# 0##,l #) -> wordToNegInteger l - (# h ,l #) -> Jn# (wordToBigNat2 h l) - - (# True, True #) -> 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 - --- | Specialised version of --- --- > bitBigNat = shiftLBigNat (wordToBigNat 1##) --- --- avoiding a few redundant allocations -bitBigNat :: Int# -> BigNat -bitBigNat i# - | isTrue# (i# <# 0#) = zeroBigNat -- or maybe 'nullBigNat'? - | isTrue# (i# ==# 0#) = oneBigNat - | True = runS $ do - mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) - -- FIXME: do we really need to zero-init MBAs returned by 'newByteArray#'? - -- clear all limbs (except for the most-significant limb) - _ <- svoid (clearWordArray# mba# 0# li#) - -- set single bit in most-significant limb - _ <- svoid (writeBigNat# mbn li# (uncheckedShiftL# 1## bi#)) - unsafeFreezeBigNat# mbn - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - -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 - - -clearBitBigNat :: BigNat -> Int# -> BigNat -clearBitBigNat bn i# - | not (inline testBitBigNat bn i#) = bn - | isTrue# (nx# ==# 1#) = wordToBigNat (bigNatToWord bn `xor#` bitWord# bi#) - | isTrue# (li# +# 1# ==# nx#) = -- special case, operating on most-sig limb - case indexBigNat# bn li# `xor#` bitWord# bi# of - 0## -> do -- most-sig limb became zero -> result has less limbs - case fmssl bn (li# -# 1#) of - 0# -> zeroBigNat - n# -> runS $ do - mbn <- newBigNat# n# - _ <- copyWordArray bn 0# mbn 0# n# - unsafeFreezeBigNat# mbn - newlimb# -> runS $ do -- no shrinking - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# li# - _ <- svoid (writeBigNat# mbn li# newlimb#) - unsafeFreezeBigNat# mbn - - | True = runS $ do - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# nx# - let newlimb# = indexBigNat# bn li# `xor#` bitWord# bi# - _ <- svoid (writeBigNat# mbn li# newlimb#) - unsafeFreezeBigNat# mbn - - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - - - -setBitBigNat :: BigNat -> Int# -> BigNat -setBitBigNat bn i# - | inline testBitBigNat bn i# = bn - | isTrue# (d# ># 0#) = runS $ do -- result BigNat will have more limbs - mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) - _ <- copyWordArray bn 0# mbn 0# nx# - _ <- svoid (clearWordArray# mba# nx# (d# -# 1#)) - _ <- svoid (writeBigNat# mbn li# (bitWord# bi#)) - unsafeFreezeBigNat# mbn - - | True = runS $ do - mbn <- newBigNat# nx# - _ <- copyWordArray bn 0# mbn 0# nx# - _ <- svoid (writeBigNat# mbn li# (indexBigNat# bn li# - `or#` bitWord# bi#)) - unsafeFreezeBigNat# mbn - - where - !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# - nx# = sizeofBigNat# bn - d# = li# +# 1# -# nx# - - -complementBitBigNat :: BigNat -> Int# -> BigNat -complementBitBigNat bn i# - | testBitBigNat bn i# = clearBitBigNat bn i# - | True = setBitBigNat bn i# - -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# -# 1#) 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 isTrue# (na# ==# nb#) of - False -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - True -> 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 isTrue# (na# ==# nb#) of - False -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) - unsafeFreezeBigNat# mbn - True -> 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 isTrue# (nx# ==# n#) of - False -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) - True -> 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 isTrue# (rn# ==# nb#) of - False -> unsafeShrinkFreezeBigNat# mbn rn# - True -> 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# - -- According to https://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fgcdext - -- abs(s) < abs(y) / (2 g) - s@(MBN# s#) <- newBigNat# (absI# yn#) - 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 isTrue# (ssn# >=# 0#) of - False -> return ( g', NegBN s' ) - True -> 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 - --- | \"@'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 1.0.2.0 -{-# NOINLINE powModSecInteger #-} -powModSecInteger :: Integer -> Integer -> Integer -> Integer -powModSecInteger b e m = bigNatToInteger (powModSecSBigNat b' e' m') - where - b' = integerToSBigNat b - e' = integerToSBigNat e - m' = absSBigNat (integerToSBigNat 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 - --- | 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 isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> 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# - --- internal non-exported helper -powModSecSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat -powModSecSBigNat b e m@(BN# m#) = runS $ do - r@(MBN# r#) <- newBigNat# mn# - I# rn_# <- liftIO (integer_gmp_powm_sec# r# b# bn# e# en# m# mn#) - let rn# = narrowGmpSize# rn_# - case isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> 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_sec" - integer_gmp_powm_sec# :: MutableByteArray# RealWorld - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - - --- | \"@'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 isTrue# (rn# ==# mn#) of - False -> unsafeShrinkFreezeBigNat# r rn# - True -> 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'. --- --- The result is always @>= 1@ since even zero is encoded with 1 limb. -sizeofBigNat# :: BigNat -> GmpSize# -sizeofBigNat# (BN# x#) - = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# - -data MutBigNat s = MBN# !(MutableByteArray# s) - -getSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, GmpSize# #) ---getSizeofMutBigNat# :: MutBigNat s -> S s GmpSize# -getSizeofMutBigNat# (MBN# x#) s = - case getSizeofMutableByteArray# x# s of - (# s', n# #) -> (# s', n# `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# ==# n#) = (# s', MBN# mba0# #) - | True = - case resizeMutableByteArray# mba0# bsz# s' of - (# s'', mba# #) -> (# s'', MBN# mba# #) - where - bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - !(# s', n# #) = getSizeofMutableByteArray# mba0# s - -shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s -shrinkMutBigNat# (MBN# mba0#) nsz# s - | isTrue# (bsz# ==# n#) = s' -- no-op - | True = shrinkMutableByteArray# mba0# bsz# s' - where - bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# - !(# s', n# #) = getSizeofMutableByteArray# mba0# s - -unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat -unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# s = go s' - where - n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# - !(# s', nb0# #) = getSizeofMutableByteArray# mba0# s - go = do - (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) - _ <- svoid (writeWordArray# mba# n# limb#) - unsafeFreezeBigNat# (MBN# mba#) - --- | May shrink underlying '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', n0# #) = getSizeofMutBigNat# mbn s - !(# s'', n# #) = normSizeofMutBigNat'# mbn n0# s' - --- | 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#) - -copyWordArray :: BigNat -> Int# -> MutBigNat s -> Int# -> Int# -> S s () -copyWordArray (BN# ba#) ofs_ba# (MBN# mba#) ofs_mba# len# - = svoid (copyWordArray# ba# ofs_ba# mba# ofs_mba# len#) - -clearWordArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s -clearWordArray# mba ofs len - = setByteArray# mba (ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) - (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 0# - --- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#' -normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) -normSizeofMutBigNat# mbn@(MBN# mba) s = normSizeofMutBigNat'# mbn sz# s' - where - !(# s', n# #) = getSizeofMutableByteArray# mba s - sz# = n# `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 $ \s -> - let !(# s', mbn@(MBN# mba#) #) = newBigNat# n# s - !(# s'', ba_sz# #) = getSizeofMutableByteArray# mba# s' - go = do _ <- svoid (copyByteArray# ba# 0# mba# 0# ba_sz# ) - unsafeFreezeBigNat# mbn - in go s'' - where - !(# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# - - n# = fmssl (BN# ba#) (n0# -# 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# - | isTrue# (szq# ># 1#) = (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## - | True = 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 = case runRW# m of (# _, a #) -> a - --- 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 = NegBN (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# #-} - -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# - --- find most-sig set limb, starting at given index -fmssl :: BigNat -> Int# -> Int# -fmssl !bn i0# = go i0# - where - go i# | isTrue# (i# <# 0#) = 0# - | isTrue# (neWord# (indexBigNat# bn i#) 0##) = i# +# 1# - | True = go (i# -# 1#) |