1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE BangPatterns #-} 3{-# LANGUAGE CPP #-} 4{-# LANGUAGE DeriveDataTypeable #-} 5{-# LANGUAGE GHCForeignImportPrim #-} 6{-# LANGUAGE MagicHash #-} 7{-# LANGUAGE UnboxedTuples #-} 8{-# LANGUAGE UnliftedFFITypes #-} 9{-# LANGUAGE RebindableSyntax #-} 10{-# LANGUAGE NegativeLiterals #-} 11{-# LANGUAGE ExplicitForAll #-} 12 13-- | 14-- Module : GHC.Integer.Type 15-- Copyright : (c) Herbert Valerio Riedel 2014 16-- License : BSD3 17-- 18-- Maintainer : ghc-devs@haskell.org 19-- Stability : provisional 20-- Portability : non-portable (GHC Extensions) 21-- 22-- GHC needs this module to be named "GHC.Integer.Type" and provide 23-- all the low-level 'Integer' operations. 24 25module GHC.Integer.Type where 26 27#include "MachDeps.h" 28#include "HsIntegerGmp.h" 29 30-- Sanity check as CPP defines are implicitly 0-valued when undefined 31#if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \ 32 && defined(WORD_SIZE_IN_BITS)) 33# error missing defines 34#endif 35 36import GHC.Classes 37import GHC.Magic 38import GHC.Prim 39import GHC.Types 40#if WORD_SIZE_IN_BITS < 64 41import GHC.IntWord64 42#endif 43 44default () 45 46-- Most high-level operations need to be marked `NOINLINE` as 47-- otherwise GHC doesn't recognize them and fails to apply constant 48-- folding to `Integer`-typed expression. 49-- 50-- To this end, the CPP hack below allows to write the pseudo-pragma 51-- 52-- {-# CONSTANT_FOLDED plusInteger #-} 53-- 54-- which is simply expaned into a 55-- 56-- {-# NOINLINE plusInteger #-} 57-- 58#define CONSTANT_FOLDED NOINLINE 59 60---------------------------------------------------------------------------- 61-- type definitions 62 63-- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS 64-- The C99 code in cbits/wrappers.c will fail to compile if this doesn't hold 65 66-- | Type representing a GMP Limb 67type GmpLimb = Word -- actually, 'CULong' 68type GmpLimb# = Word# 69 70-- | Count of 'GmpLimb's, must be positive (unless specified otherwise). 71type GmpSize = Int -- actually, a 'CLong' 72type GmpSize# = Int# 73 74narrowGmpSize# :: Int# -> Int# 75#if SIZEOF_LONG == SIZEOF_HSWORD 76narrowGmpSize# x = x 77#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) 78-- On IL32P64 (i.e. Win64), we have to be careful with CLong not being 79-- 64bit. This is mostly an issue on values returned from C functions 80-- due to sign-extension. 81narrowGmpSize# = narrow32Int# 82#endif 83 84 85type GmpBitCnt = Word -- actually, 'CULong' 86type GmpBitCnt# = Word# -- actually, 'CULong' 87 88-- Pseudo FFI CType 89type CInt = Int 90type CInt# = Int# 91 92narrowCInt# :: Int# -> Int# 93narrowCInt# = narrow32Int# 94 95-- | Bits in a 'GmpLimb'. Same as @WORD_SIZE_IN_BITS@. 96gmpLimbBits :: Word -- 8 `shiftL` gmpLimbShift 97gmpLimbBits = W# WORD_SIZE_IN_BITS## 98 99#if WORD_SIZE_IN_BITS == 64 100# define GMP_LIMB_SHIFT 3 101# define GMP_LIMB_BYTES 8 102# define GMP_LIMB_BITS 64 103# define INT_MINBOUND -0x8000000000000000 104# define INT_MAXBOUND 0x7fffffffffffffff 105# define ABS_INT_MINBOUND 0x8000000000000000 106# define SQRT_INT_MAXBOUND 0xb504f333 107#elif WORD_SIZE_IN_BITS == 32 108# define GMP_LIMB_SHIFT 2 109# define GMP_LIMB_BYTES 4 110# define GMP_LIMB_BITS 32 111# define INT_MINBOUND -0x80000000 112# define INT_MAXBOUND 0x7fffffff 113# define ABS_INT_MINBOUND 0x80000000 114# define SQRT_INT_MAXBOUND 0xb504 115#else 116# error unsupported WORD_SIZE_IN_BITS config 117#endif 118 119-- | Type representing /raw/ arbitrary-precision Naturals 120-- 121-- This is common type used by 'Natural' and 'Integer'. As this type 122-- consists of a single constructor wrapping a 'ByteArray#' it can be 123-- unpacked. 124-- 125-- Essential invariants: 126-- 127-- - 'ByteArray#' size is an exact multiple of 'Word#' size 128-- - limbs are stored in least-significant-limb-first order, 129-- - the most-significant limb must be non-zero, except for 130-- - @0@ which is represented as a 1-limb. 131data BigNat = BN# ByteArray# 132 133instance Eq BigNat where 134 (==) = eqBigNat 135 136instance Ord BigNat where 137 compare = compareBigNat 138 139-- [Implementation notes] 140-- 141-- Invariant: 'Jn#' and 'Jp#' are used iff value doesn't fit in 'S#' 142-- 143-- Useful properties resulting from the invariants: 144-- 145-- - @abs ('S#' _) <= abs ('Jp#' _)@ 146-- - @abs ('S#' _) < abs ('Jn#' _)@ 147 148-- | Arbitrary precision integers. In contrast with fixed-size integral types 149-- such as 'Int', the 'Integer' type represents the entire infinite range of 150-- integers. 151-- 152-- For more information about this type's representation, see the comments in 153-- its implementation. 154data Integer = S# !Int# 155 -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range 156 | Jp# {-# UNPACK #-} !BigNat 157 -- ^ iff value in @]maxBound::'Int', +inf[@ range 158 | Jn# {-# UNPACK #-} !BigNat 159 -- ^ iff value in @]-inf, minBound::'Int'[@ range 160 161-- NOTE: the above representation is baked into the GHCi debugger in 162-- compiler/ghci/RtClosureInspect.hs. If you change it here, fixes 163-- will be required over there too. Tests for this are in 164-- testsuite/tests/ghci.debugger. 165 166-- TODO: experiment with different constructor-ordering 167 168instance Eq Integer where 169 (==) = eqInteger 170 (/=) = neqInteger 171 172instance Ord Integer where 173 compare = compareInteger 174 (>) = gtInteger 175 (>=) = geInteger 176 (<) = ltInteger 177 (<=) = leInteger 178 179---------------------------------------------------------------------------- 180 181-- | Construct 'Integer' value from list of 'Int's. 182-- 183-- This function is used by GHC for constructing 'Integer' literals. 184mkInteger :: Bool -- ^ sign of integer ('True' if non-negative) 185 -> [Int] -- ^ absolute value expressed in 31 bit chunks, least 186 -- significant first (ideally these would be machine-word 187 -- 'Word's rather than 31-bit truncated 'Int's) 188 -> Integer 189mkInteger nonNegative is 190 | nonNegative = f is 191 | True = negateInteger (f is) 192 where 193 f [] = S# 0# 194 f (I# i : is') = smallInteger (i `andI#` 0x7fffffff#) `orInteger` 195 shiftLInteger (f is') 31# 196{-# CONSTANT_FOLDED mkInteger #-} 197 198-- | Test whether all internal invariants are satisfied by 'Integer' value 199-- 200-- Returns @1#@ if valid, @0#@ otherwise. 201-- 202-- This operation is mostly useful for test-suites and/or code which 203-- constructs 'Integer' values directly. 204isValidInteger# :: Integer -> Int# 205isValidInteger# (S# _) = 1# 206isValidInteger# (Jp# bn) 207 = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` INT_MAXBOUND##) 208isValidInteger# (Jn# bn) 209 = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` ABS_INT_MINBOUND##) 210 211-- | Should rather be called @intToInteger@ 212smallInteger :: Int# -> Integer 213smallInteger i# = S# i# 214{-# CONSTANT_FOLDED smallInteger #-} 215 216---------------------------------------------------------------------------- 217-- Int64/Word64 specific primitives 218 219#if WORD_SIZE_IN_BITS < 64 220int64ToInteger :: Int64# -> Integer 221int64ToInteger i 222 | isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#) 223 , isTrue# (i `geInt64#` intToInt64# -0x80000000#) 224 = S# (int64ToInt# i) 225 | isTrue# (i `geInt64#` intToInt64# 0#) 226 = Jp# (word64ToBigNat (int64ToWord64# i)) 227 | True 228 = Jn# (word64ToBigNat (int64ToWord64# (negateInt64# i))) 229{-# CONSTANT_FOLDED int64ToInteger #-} 230 231word64ToInteger :: Word64# -> Integer 232word64ToInteger w 233 | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##) 234 = S# (int64ToInt# (word64ToInt64# w)) 235 | True 236 = Jp# (word64ToBigNat w) 237{-# CONSTANT_FOLDED word64ToInteger #-} 238 239integerToInt64 :: Integer -> Int64# 240integerToInt64 (S# i#) = intToInt64# i# 241integerToInt64 (Jp# bn) = word64ToInt64# (bigNatToWord64 bn) 242integerToInt64 (Jn# bn) = negateInt64# (word64ToInt64# (bigNatToWord64 bn)) 243{-# CONSTANT_FOLDED integerToInt64 #-} 244 245integerToWord64 :: Integer -> Word64# 246integerToWord64 (S# i#) = int64ToWord64# (intToInt64# i#) 247integerToWord64 (Jp# bn) = bigNatToWord64 bn 248integerToWord64 (Jn# bn) 249 = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64 bn))) 250{-# CONSTANT_FOLDED integerToWord64 #-} 251 252#if GMP_LIMB_BITS == 32 253word64ToBigNat :: Word64# -> BigNat 254word64ToBigNat w64 = wordToBigNat2 wh# wl# 255 where 256 wh# = word64ToWord# (uncheckedShiftRL64# w64 32#) 257 wl# = word64ToWord# w64 258 259bigNatToWord64 :: BigNat -> Word64# 260bigNatToWord64 bn 261 | isTrue# (sizeofBigNat# bn ># 1#) 262 = let wh# = wordToWord64# (indexBigNat# bn 1#) 263 in uncheckedShiftL64# wh# 32# `or64#` wl# 264 | True = wl# 265 where 266 wl# = wordToWord64# (bigNatToWord bn) 267#endif 268#endif 269 270-- End of Int64/Word64 specific primitives 271---------------------------------------------------------------------------- 272 273-- | Truncates 'Integer' to least-significant 'Int#' 274integerToInt :: Integer -> Int# 275integerToInt (S# i#) = i# 276integerToInt (Jp# bn) = bigNatToInt bn 277integerToInt (Jn# bn) = negateInt# (bigNatToInt bn) 278{-# CONSTANT_FOLDED integerToInt #-} 279 280hashInteger :: Integer -> Int# 281hashInteger = integerToInt -- emulating what integer-{simple,gmp} already do 282 283integerToWord :: Integer -> Word# 284integerToWord (S# i#) = int2Word# i# 285integerToWord (Jp# bn) = bigNatToWord bn 286integerToWord (Jn# bn) = int2Word# (negateInt# (bigNatToInt bn)) 287{-# CONSTANT_FOLDED integerToWord #-} 288 289wordToInteger :: Word# -> Integer 290wordToInteger w# 291 | isTrue# (i# >=# 0#) = S# i# 292 | True = Jp# (wordToBigNat w#) 293 where 294 i# = word2Int# w# 295{-# CONSTANT_FOLDED wordToInteger #-} 296 297wordToNegInteger :: Word# -> Integer 298wordToNegInteger w# 299 | isTrue# (i# <=# 0#) = S# i# 300 | True = Jn# (wordToBigNat w#) 301 where 302 i# = negateInt# (word2Int# w#) 303 304-- we could almost auto-derive Ord if it wasn't for the Jn#-Jn# case 305compareInteger :: Integer -> Integer -> Ordering 306compareInteger (Jn# x) (Jn# y) = compareBigNat y x 307compareInteger (S# x) (S# y) = compareInt# x y 308compareInteger (Jp# x) (Jp# y) = compareBigNat x y 309compareInteger (Jn# _) _ = LT 310compareInteger (S# _) (Jp# _) = LT 311compareInteger (S# _) (Jn# _) = GT 312compareInteger (Jp# _) _ = GT 313{-# CONSTANT_FOLDED compareInteger #-} 314 315isNegInteger# :: Integer -> Int# 316isNegInteger# (S# i#) = i# <# 0# 317isNegInteger# (Jp# _) = 0# 318isNegInteger# (Jn# _) = 1# 319 320-- | Not-equal predicate. 321neqInteger :: Integer -> Integer -> Bool 322neqInteger x y = isTrue# (neqInteger# x y) 323 324eqInteger, leInteger, ltInteger, gtInteger, geInteger 325 :: Integer -> Integer -> Bool 326eqInteger x y = isTrue# (eqInteger# x y) 327leInteger x y = isTrue# (leInteger# x y) 328ltInteger x y = isTrue# (ltInteger# x y) 329gtInteger x y = isTrue# (gtInteger# x y) 330geInteger x y = isTrue# (geInteger# x y) 331 332eqInteger#, neqInteger#, leInteger#, ltInteger#, gtInteger#, geInteger# 333 :: Integer -> Integer -> Int# 334eqInteger# (S# x#) (S# y#) = x# ==# y# 335eqInteger# (Jn# x) (Jn# y) = eqBigNat# x y 336eqInteger# (Jp# x) (Jp# y) = eqBigNat# x y 337eqInteger# _ _ = 0# 338{-# CONSTANT_FOLDED eqInteger# #-} 339 340neqInteger# (S# x#) (S# y#) = x# /=# y# 341neqInteger# (Jn# x) (Jn# y) = neqBigNat# x y 342neqInteger# (Jp# x) (Jp# y) = neqBigNat# x y 343neqInteger# _ _ = 1# 344{-# CONSTANT_FOLDED neqInteger# #-} 345 346 347gtInteger# (S# x#) (S# y#) = x# ># y# 348gtInteger# x y | inline compareInteger x y == GT = 1# 349gtInteger# _ _ = 0# 350{-# CONSTANT_FOLDED gtInteger# #-} 351 352leInteger# (S# x#) (S# y#) = x# <=# y# 353leInteger# x y | inline compareInteger x y /= GT = 1# 354leInteger# _ _ = 0# 355{-# CONSTANT_FOLDED leInteger# #-} 356 357ltInteger# (S# x#) (S# y#) = x# <# y# 358ltInteger# x y | inline compareInteger x y == LT = 1# 359ltInteger# _ _ = 0# 360{-# CONSTANT_FOLDED ltInteger# #-} 361 362geInteger# (S# x#) (S# y#) = x# >=# y# 363geInteger# x y | inline compareInteger x y /= LT = 1# 364geInteger# _ _ = 0# 365{-# CONSTANT_FOLDED geInteger# #-} 366 367-- | Compute absolute value of an 'Integer' 368absInteger :: Integer -> Integer 369absInteger (Jn# n) = Jp# n 370absInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) 371absInteger (S# i#) | isTrue# (i# <# 0#) = S# (negateInt# i#) 372absInteger i@(S# _) = i 373absInteger i@(Jp# _) = i 374{-# CONSTANT_FOLDED absInteger #-} 375 376-- | Return @-1@, @0@, and @1@ depending on whether argument is 377-- negative, zero, or positive, respectively 378signumInteger :: Integer -> Integer 379signumInteger j = S# (signumInteger# j) 380{-# CONSTANT_FOLDED signumInteger #-} 381 382-- | Return @-1#@, @0#@, and @1#@ depending on whether argument is 383-- negative, zero, or positive, respectively 384signumInteger# :: Integer -> Int# 385signumInteger# (Jn# _) = -1# 386signumInteger# (S# i#) = sgnI# i# 387signumInteger# (Jp# _ ) = 1# 388 389-- | Negate 'Integer' 390negateInteger :: Integer -> Integer 391negateInteger (Jn# n) = Jp# n 392negateInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) 393negateInteger (S# i#) = S# (negateInt# i#) 394negateInteger (Jp# bn) 395 | isTrue# (eqBigNatWord# bn ABS_INT_MINBOUND##) = S# INT_MINBOUND# 396 | True = Jn# bn 397{-# CONSTANT_FOLDED negateInteger #-} 398 399-- one edge-case issue to take into account is that Int's range is not 400-- symmetric around 0. I.e. @minBound+maxBound = -1@ 401-- 402-- Jp# is used iff n > maxBound::Int 403-- Jn# is used iff n < minBound::Int 404 405-- | Add two 'Integer's 406plusInteger :: Integer -> Integer -> Integer 407plusInteger x (S# 0#) = x 408plusInteger (S# 0#) y = y 409plusInteger (S# x#) (S# y#) 410 = case addIntC# x# y# of 411 (# z#, 0# #) -> S# z# 412 (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) -- 2*minBound::Int 413 (# z#, _ #) 414 | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) 415 | True -> Jp# (wordToBigNat ( (int2Word# z#))) 416plusInteger y@(S# _) x = plusInteger x y 417-- no S# as first arg from here on 418plusInteger (Jp# x) (Jp# y) = Jp# (plusBigNat x y) 419plusInteger (Jn# x) (Jn# y) = Jn# (plusBigNat x y) 420plusInteger (Jp# x) (S# y#) -- edge-case: @(maxBound+1) + minBound == 0@ 421 | isTrue# (y# >=# 0#) = Jp# (plusBigNatWord x (int2Word# y#)) 422 | True = bigNatToInteger (minusBigNatWord x (int2Word# 423 (negateInt# y#))) 424plusInteger (Jn# x) (S# y#) -- edge-case: @(minBound-1) + maxBound == -2@ 425 | isTrue# (y# >=# 0#) = bigNatToNegInteger (minusBigNatWord x (int2Word# y#)) 426 | True = Jn# (plusBigNatWord x (int2Word# (negateInt# y#))) 427plusInteger y@(Jn# _) x@(Jp# _) = plusInteger x y 428plusInteger (Jp# x) (Jn# y) 429 = case compareBigNat x y of 430 LT -> bigNatToNegInteger (minusBigNat y x) 431 EQ -> S# 0# 432 GT -> bigNatToInteger (minusBigNat x y) 433{-# CONSTANT_FOLDED plusInteger #-} 434 435-- | Subtract one 'Integer' from another. 436minusInteger :: Integer -> Integer -> Integer 437minusInteger x (S# 0#) = x 438minusInteger (S# x#) (S# y#) 439 = case subIntC# x# y# of 440 (# z#, 0# #) -> S# z# 441 (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) 442 (# z#, _ #) 443 | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) 444 | True -> Jp# (wordToBigNat ( (int2Word# z#))) 445minusInteger (S# x#) (Jp# y) 446 | isTrue# (x# >=# 0#) = bigNatToNegInteger (minusBigNatWord y (int2Word# x#)) 447 | True = Jn# (plusBigNatWord y (int2Word# (negateInt# x#))) 448minusInteger (S# x#) (Jn# y) 449 | isTrue# (x# >=# 0#) = Jp# (plusBigNatWord y (int2Word# x#)) 450 | True = bigNatToInteger (minusBigNatWord y (int2Word# 451 (negateInt# x#))) 452minusInteger (Jp# x) (Jp# y) 453 = case compareBigNat x y of 454 LT -> bigNatToNegInteger (minusBigNat y x) 455 EQ -> S# 0# 456 GT -> bigNatToInteger (minusBigNat x y) 457minusInteger (Jp# x) (Jn# y) = Jp# (plusBigNat x y) 458minusInteger (Jn# x) (Jp# y) = Jn# (plusBigNat x y) 459minusInteger (Jn# x) (Jn# y) 460 = case compareBigNat x y of 461 LT -> bigNatToInteger (minusBigNat y x) 462 EQ -> S# 0# 463 GT -> bigNatToNegInteger (minusBigNat x y) 464minusInteger (Jp# x) (S# y#) 465 | isTrue# (y# >=# 0#) = bigNatToInteger (minusBigNatWord x (int2Word# y#)) 466 | True = Jp# (plusBigNatWord x (int2Word# (negateInt# y#))) 467minusInteger (Jn# x) (S# y#) 468 | isTrue# (y# >=# 0#) = Jn# (plusBigNatWord x (int2Word# y#)) 469 | True = bigNatToNegInteger (minusBigNatWord x 470 (int2Word# (negateInt# y#))) 471{-# CONSTANT_FOLDED minusInteger #-} 472 473-- | Multiply two 'Integer's 474timesInteger :: Integer -> Integer -> Integer 475timesInteger !_ (S# 0#) = S# 0# 476timesInteger (S# 0#) _ = S# 0# 477timesInteger x (S# 1#) = x 478timesInteger (S# 1#) y = y 479timesInteger x (S# -1#) = negateInteger x 480timesInteger (S# -1#) y = negateInteger y 481timesInteger (S# x#) (S# y#) 482 = case mulIntMayOflo# x# y# of 483 0# -> S# (x# *# y#) 484 _ -> timesInt2Integer x# y# 485timesInteger x@(S# _) y = timesInteger y x 486-- no S# as first arg from here on 487timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y) 488timesInteger (Jp# x) (Jn# y) = Jn# (timesBigNat x y) 489timesInteger (Jp# x) (S# y#) 490 | isTrue# (y# >=# 0#) = Jp# (timesBigNatWord x (int2Word# y#)) 491 | True = Jn# (timesBigNatWord x (int2Word# (negateInt# y#))) 492timesInteger (Jn# x) (Jn# y) = Jp# (timesBigNat x y) 493timesInteger (Jn# x) (Jp# y) = Jn# (timesBigNat x y) 494timesInteger (Jn# x) (S# y#) 495 | isTrue# (y# >=# 0#) = Jn# (timesBigNatWord x (int2Word# y#)) 496 | True = Jp# (timesBigNatWord x (int2Word# (negateInt# y#))) 497{-# CONSTANT_FOLDED timesInteger #-} 498 499-- | Square 'Integer' 500sqrInteger :: Integer -> Integer 501sqrInteger (S# INT_MINBOUND#) = timesInt2Integer INT_MINBOUND# INT_MINBOUND# 502sqrInteger (S# j#) | isTrue# (absI# j# <=# SQRT_INT_MAXBOUND#) = S# (j# *# j#) 503sqrInteger (S# j#) = timesInt2Integer j# j# 504sqrInteger (Jp# bn) = Jp# (sqrBigNat bn) 505sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) 506 507-- | Construct 'Integer' from the product of two 'Int#'s 508timesInt2Integer :: Int# -> Int# -> Integer 509timesInt2Integer x# y# = case (# isTrue# (x# >=# 0#), isTrue# (y# >=# 0#) #) of 510 (# False, False #) -> case timesWord2# (int2Word# (negateInt# x#)) 511 (int2Word# (negateInt# y#)) of 512 (# 0##,l #) -> inline wordToInteger l 513 (# h ,l #) -> Jp# (wordToBigNat2 h l) 514 515 (# True, False #) -> case timesWord2# (int2Word# x#) 516 (int2Word# (negateInt# y#)) of 517 (# 0##,l #) -> wordToNegInteger l 518 (# h ,l #) -> Jn# (wordToBigNat2 h l) 519 520 (# False, True #) -> case timesWord2# (int2Word# (negateInt# x#)) 521 (int2Word# y#) of 522 (# 0##,l #) -> wordToNegInteger l 523 (# h ,l #) -> Jn# (wordToBigNat2 h l) 524 525 (# True, True #) -> case timesWord2# (int2Word# x#) 526 (int2Word# y#) of 527 (# 0##,l #) -> inline wordToInteger l 528 (# h ,l #) -> Jp# (wordToBigNat2 h l) 529 530bigNatToInteger :: BigNat -> Integer 531bigNatToInteger bn 532 | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# >=# 0#)) = S# i# 533 | True = Jp# bn 534 where 535 i# = word2Int# (bigNatToWord bn) 536 537bigNatToNegInteger :: BigNat -> Integer 538bigNatToNegInteger bn 539 | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# <=# 0#)) = S# i# 540 | True = Jn# bn 541 where 542 i# = negateInt# (word2Int# (bigNatToWord bn)) 543 544-- | Count number of set bits. For negative arguments returns negative 545-- population count of negated argument. 546popCountInteger :: Integer -> Int# 547popCountInteger (S# i#) 548 | isTrue# (i# >=# 0#) = popCntI# i# 549 | True = negateInt# (popCntI# (negateInt# i#)) 550popCountInteger (Jp# bn) = popCountBigNat bn 551popCountInteger (Jn# bn) = negateInt# (popCountBigNat bn) 552{-# CONSTANT_FOLDED popCountInteger #-} 553 554-- | 'Integer' for which only /n/-th bit is set. Undefined behaviour 555-- for negative /n/ values. 556bitInteger :: Int# -> Integer 557bitInteger i# 558 | isTrue# (i# <# (GMP_LIMB_BITS# -# 1#)) = S# (uncheckedIShiftL# 1# i#) 559 | True = Jp# (bitBigNat i#) 560{-# CONSTANT_FOLDED bitInteger #-} 561 562-- | Test if /n/-th bit is set. 563testBitInteger :: Integer -> Int# -> Bool 564testBitInteger !_ n# | isTrue# (n# <# 0#) = False 565testBitInteger (S# i#) n# 566 | isTrue# (n# <# GMP_LIMB_BITS#) = isTrue# (((uncheckedIShiftL# 1# n#) 567 `andI#` i#) /=# 0#) 568 | True = isTrue# (i# <# 0#) 569testBitInteger (Jp# bn) n = testBitBigNat bn n 570testBitInteger (Jn# bn) n = testBitNegBigNat bn n 571{-# CONSTANT_FOLDED testBitInteger #-} 572 573-- | Bitwise @NOT@ operation 574complementInteger :: Integer -> Integer 575complementInteger (S# i#) = S# (notI# i#) 576complementInteger (Jp# bn) = Jn# (plusBigNatWord bn 1##) 577complementInteger (Jn# bn) = Jp# (minusBigNatWord bn 1##) 578{-# CONSTANT_FOLDED complementInteger #-} 579 580-- | Arithmetic shift-right operation 581-- 582-- Even though the shift-amount is expressed as `Int#`, the result is 583-- undefined for negative shift-amounts. 584shiftRInteger :: Integer -> Int# -> Integer 585shiftRInteger x 0# = x 586shiftRInteger (S# i#) n# = S# (iShiftRA# i# n#) 587 where 588 iShiftRA# a b 589 | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#) 590 | True = a `uncheckedIShiftRA#` b 591shiftRInteger (Jp# bn) n# = bigNatToInteger (shiftRBigNat bn n#) 592shiftRInteger (Jn# bn) n# 593 = case bigNatToNegInteger (shiftRNegBigNat bn n#) of 594 S# 0# -> S# -1# 595 r -> r 596{-# CONSTANT_FOLDED shiftRInteger #-} 597 598-- | Shift-left operation 599-- 600-- Even though the shift-amount is expressed as `Int#`, the result is 601-- undefined for negative shift-amounts. 602shiftLInteger :: Integer -> Int# -> Integer 603shiftLInteger x 0# = x 604shiftLInteger (S# 0#) _ = S# 0# 605shiftLInteger (S# 1#) n# = bitInteger n# 606shiftLInteger (S# i#) n# 607 | isTrue# (i# >=# 0#) = bigNatToInteger (shiftLBigNat 608 (wordToBigNat (int2Word# i#)) n#) 609 | True = bigNatToNegInteger (shiftLBigNat 610 (wordToBigNat (int2Word# 611 (negateInt# i#))) n#) 612shiftLInteger (Jp# bn) n# = Jp# (shiftLBigNat bn n#) 613shiftLInteger (Jn# bn) n# = Jn# (shiftLBigNat bn n#) 614{-# CONSTANT_FOLDED shiftLInteger #-} 615 616-- | Bitwise OR operation 617orInteger :: Integer -> Integer -> Integer 618-- short-cuts 619orInteger (S# 0#) y = y 620orInteger x (S# 0#) = x 621orInteger (S# -1#) _ = S# -1# 622orInteger _ (S# -1#) = S# -1# 623-- base-cases 624orInteger (S# x#) (S# y#) = S# (orI# x# y#) 625orInteger (Jp# x) (Jp# y) = Jp# (orBigNat x y) 626orInteger (Jn# x) (Jn# y) 627 = bigNatToNegInteger (plusBigNatWord (andBigNat 628 (minusBigNatWord x 1##) 629 (minusBigNatWord y 1##)) 1##) 630orInteger x@(Jn# _) y@(Jp# _) = orInteger y x -- retry with swapped args 631orInteger (Jp# x) (Jn# y) 632 = bigNatToNegInteger (plusBigNatWord (andnBigNat (minusBigNatWord y 1##) x) 633 1##) 634-- TODO/FIXpromotion-hack 635orInteger x@(S# _) y = orInteger (unsafePromote x) y 636orInteger x y {- S# -}= orInteger x (unsafePromote y) 637{-# CONSTANT_FOLDED orInteger #-} 638 639-- | Bitwise XOR operation 640xorInteger :: Integer -> Integer -> Integer 641-- short-cuts 642xorInteger (S# 0#) y = y 643xorInteger x (S# 0#) = x 644-- TODO: (S# -1) cases 645-- base-cases 646xorInteger (S# x#) (S# y#) = S# (xorI# x# y#) 647xorInteger (Jp# x) (Jp# y) = bigNatToInteger (xorBigNat x y) 648xorInteger (Jn# x) (Jn# y) 649 = bigNatToInteger (xorBigNat (minusBigNatWord x 1##) 650 (minusBigNatWord y 1##)) 651xorInteger x@(Jn# _) y@(Jp# _) = xorInteger y x -- retry with swapped args 652xorInteger (Jp# x) (Jn# y) 653 = bigNatToNegInteger (plusBigNatWord (xorBigNat x (minusBigNatWord y 1##)) 654 1##) 655-- TODO/FIXME promotion-hack 656xorInteger x@(S# _) y = xorInteger (unsafePromote x) y 657xorInteger x y {- S# -} = xorInteger x (unsafePromote y) 658{-# CONSTANT_FOLDED xorInteger #-} 659 660-- | Bitwise AND operation 661andInteger :: Integer -> Integer -> Integer 662-- short-cuts 663andInteger (S# 0#) !_ = S# 0# 664andInteger _ (S# 0#) = S# 0# 665andInteger (S# -1#) y = y 666andInteger x (S# -1#) = x 667-- base-cases 668andInteger (S# x#) (S# y#) = S# (andI# x# y#) 669andInteger (Jp# x) (Jp# y) = bigNatToInteger (andBigNat x y) 670andInteger (Jn# x) (Jn# y) 671 = bigNatToNegInteger (plusBigNatWord (orBigNat (minusBigNatWord x 1##) 672 (minusBigNatWord y 1##)) 1##) 673andInteger x@(Jn# _) y@(Jp# _) = andInteger y x 674andInteger (Jp# x) (Jn# y) 675 = bigNatToInteger (andnBigNat x (minusBigNatWord y 1##)) 676-- TODO/FIXME promotion-hack 677andInteger x@(S# _) y = andInteger (unsafePromote x) y 678andInteger x y {- S# -}= andInteger x (unsafePromote y) 679{-# CONSTANT_FOLDED andInteger #-} 680 681-- HACK warning! breaks invariant on purpose 682unsafePromote :: Integer -> Integer 683unsafePromote (S# x#) 684 | isTrue# (x# >=# 0#) = Jp# (wordToBigNat (int2Word# x#)) 685 | True = Jn# (wordToBigNat (int2Word# (negateInt# x#))) 686unsafePromote x = x 687 688-- | Simultaneous 'quotInteger' and 'remInteger'. 689-- 690-- Divisor must be non-zero otherwise the GHC runtime will terminate 691-- with a division-by-zero fault. 692quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) 693quotRemInteger n (S# 1#) = (# n, S# 0# #) 694quotRemInteger n (S# -1#) = let !q = negateInteger n in (# q, (S# 0#) #) 695quotRemInteger !_ (S# 0#) = (# S# (quotInt# 0# 0#),S# (remInt# 0# 0#) #) 696quotRemInteger (S# 0#) _ = (# S# 0#, S# 0# #) 697quotRemInteger (S# n#) (S# d#) = case quotRemInt# n# d# of 698 (# q#, r# #) -> (# S# q#, S# r# #) 699quotRemInteger (Jp# n) (Jp# d) = case quotRemBigNat n d of 700 (# q, r #) -> (# bigNatToInteger q, bigNatToInteger r #) 701quotRemInteger (Jp# n) (Jn# d) = case quotRemBigNat n d of 702 (# q, r #) -> (# bigNatToNegInteger q, bigNatToInteger r #) 703quotRemInteger (Jn# n) (Jn# d) = case quotRemBigNat n d of 704 (# q, r #) -> (# bigNatToInteger q, bigNatToNegInteger r #) 705quotRemInteger (Jn# n) (Jp# d) = case quotRemBigNat n d of 706 (# q, r #) -> (# bigNatToNegInteger q, bigNatToNegInteger r #) 707quotRemInteger (Jp# n) (S# d#) 708 | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of 709 (# q, r# #) -> (# bigNatToInteger q, inline wordToInteger r# #) 710 | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of 711 (# q, r# #) -> (# bigNatToNegInteger q, inline wordToInteger r# #) 712quotRemInteger (Jn# n) (S# d#) 713 | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of 714 (# q, r# #) -> (# bigNatToNegInteger q, wordToNegInteger r# #) 715 | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of 716 (# q, r# #) -> (# bigNatToInteger q, wordToNegInteger r# #) 717quotRemInteger n@(S# _) (Jn# _) = (# S# 0#, n #) -- since @n < d@ 718quotRemInteger n@(S# n#) (Jp# d) -- need to account for (S# minBound) 719 | isTrue# (n# ># 0#) = (# S# 0#, n #) 720 | isTrue# (gtBigNatWord# d (int2Word# (negateInt# n#))) = (# S# 0#, n #) 721 | True {- abs(n) == d -} = (# S# -1#, S# 0# #) 722{-# CONSTANT_FOLDED quotRemInteger #-} 723 724 725quotInteger :: Integer -> Integer -> Integer 726quotInteger n (S# 1#) = n 727quotInteger n (S# -1#) = negateInteger n 728quotInteger !_ (S# 0#) = S# (quotInt# 0# 0#) 729quotInteger (S# 0#) _ = S# 0# 730quotInteger (S# n#) (S# d#) = S# (quotInt# n# d#) 731quotInteger (Jp# n) (S# d#) 732 | isTrue# (d# >=# 0#) = bigNatToInteger (quotBigNatWord n (int2Word# d#)) 733 | True = bigNatToNegInteger (quotBigNatWord n 734 (int2Word# (negateInt# d#))) 735quotInteger (Jn# n) (S# d#) 736 | isTrue# (d# >=# 0#) = bigNatToNegInteger (quotBigNatWord n (int2Word# d#)) 737 | True = bigNatToInteger (quotBigNatWord n 738 (int2Word# (negateInt# d#))) 739quotInteger (Jp# n) (Jp# d) = bigNatToInteger (quotBigNat n d) 740quotInteger (Jp# n) (Jn# d) = bigNatToNegInteger (quotBigNat n d) 741quotInteger (Jn# n) (Jp# d) = bigNatToNegInteger (quotBigNat n d) 742quotInteger (Jn# n) (Jn# d) = bigNatToInteger (quotBigNat n d) 743-- handle remaining non-allocating cases 744quotInteger n d = case inline quotRemInteger n d of (# q, _ #) -> q 745{-# CONSTANT_FOLDED quotInteger #-} 746 747remInteger :: Integer -> Integer -> Integer 748remInteger !_ (S# 1#) = S# 0# 749remInteger _ (S# -1#) = S# 0# 750remInteger _ (S# 0#) = S# (remInt# 0# 0#) 751remInteger (S# 0#) _ = S# 0# 752remInteger (S# n#) (S# d#) = S# (remInt# n# d#) 753remInteger (Jp# n) (S# d#) 754 = wordToInteger (remBigNatWord n (int2Word# (absI# d#))) 755remInteger (Jn# n) (S# d#) 756 = wordToNegInteger (remBigNatWord n (int2Word# (absI# d#))) 757remInteger (Jp# n) (Jp# d) = bigNatToInteger (remBigNat n d) 758remInteger (Jp# n) (Jn# d) = bigNatToInteger (remBigNat n d) 759remInteger (Jn# n) (Jp# d) = bigNatToNegInteger (remBigNat n d) 760remInteger (Jn# n) (Jn# d) = bigNatToNegInteger (remBigNat n d) 761-- handle remaining non-allocating cases 762remInteger n d = case inline quotRemInteger n d of (# _, r #) -> r 763{-# CONSTANT_FOLDED remInteger #-} 764 765-- | Simultaneous 'divInteger' and 'modInteger'. 766-- 767-- Divisor must be non-zero otherwise the GHC runtime will terminate 768-- with a division-by-zero fault. 769divModInteger :: Integer -> Integer -> (# Integer, Integer #) 770divModInteger n d 771 | isTrue# (signumInteger# r ==# negateInt# (signumInteger# d)) 772 = let !q' = plusInteger q (S# -1#) -- TODO: optimize 773 !r' = plusInteger r d 774 in (# q', r' #) 775 | True = qr 776 where 777 !qr@(# q, r #) = quotRemInteger n d 778{-# CONSTANT_FOLDED divModInteger #-} 779 780divInteger :: Integer -> Integer -> Integer 781-- same-sign ops can be handled by more efficient 'quotInteger' 782divInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = quotInteger n d 783divInteger n d = case inline divModInteger n d of (# q, _ #) -> q 784{-# CONSTANT_FOLDED divInteger #-} 785 786modInteger :: Integer -> Integer -> Integer 787-- same-sign ops can be handled by more efficient 'remInteger' 788modInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = remInteger n d 789modInteger n d = case inline divModInteger n d of (# _, r #) -> r 790{-# CONSTANT_FOLDED modInteger #-} 791 792-- | Compute greatest common divisor. 793gcdInteger :: Integer -> Integer -> Integer 794gcdInteger (S# 0#) b = absInteger b 795gcdInteger a (S# 0#) = absInteger a 796gcdInteger (S# 1#) _ = S# 1# 797gcdInteger (S# -1#) _ = S# 1# 798gcdInteger _ (S# 1#) = S# 1# 799gcdInteger _ (S# -1#) = S# 1# 800gcdInteger (S# a#) (S# b#) 801 = wordToInteger (gcdWord# (int2Word# (absI# a#)) (int2Word# (absI# b#))) 802gcdInteger a@(S# _) b = gcdInteger b a 803gcdInteger (Jn# a) b = gcdInteger (Jp# a) b 804gcdInteger (Jp# a) (Jp# b) = bigNatToInteger (gcdBigNat a b) 805gcdInteger (Jp# a) (Jn# b) = bigNatToInteger (gcdBigNat a b) 806gcdInteger (Jp# a) (S# b#) 807 = wordToInteger (gcdBigNatWord a (int2Word# (absI# b#))) 808{-# CONSTANT_FOLDED gcdInteger #-} 809 810-- | Compute least common multiple. 811lcmInteger :: Integer -> Integer -> Integer 812lcmInteger (S# 0#) !_ = S# 0# 813lcmInteger (S# 1#) b = absInteger b 814lcmInteger (S# -1#) b = absInteger b 815lcmInteger _ (S# 0#) = S# 0# 816lcmInteger a (S# 1#) = absInteger a 817lcmInteger a (S# -1#) = absInteger a 818lcmInteger a b = (aa `quotInteger` (aa `gcdInteger` ab)) `timesInteger` ab 819 where 820 aa = absInteger a 821 ab = absInteger b 822{-# CONSTANT_FOLDED lcmInteger #-} 823 824-- | Compute greatest common divisor. 825-- 826-- __Warning__: result may become negative if (at least) one argument 827-- is 'minBound' 828gcdInt :: Int# -> Int# -> Int# 829gcdInt x# y# 830 = word2Int# (gcdWord# (int2Word# (absI# x#)) (int2Word# (absI# y#))) 831 832-- | Compute greatest common divisor. 833-- 834-- @since 1.0.0.0 835gcdWord :: Word# -> Word# -> Word# 836gcdWord = gcdWord# 837 838---------------------------------------------------------------------------- 839-- BigNat operations 840 841compareBigNat :: BigNat -> BigNat -> Ordering 842compareBigNat x@(BN# x#) y@(BN# y#) 843 | isTrue# (nx# ==# ny#) 844 = compareInt# (narrowCInt# (c_mpn_cmp x# y# nx#)) 0# 845 | isTrue# (nx# <# ny#) = LT 846 | True = GT 847 where 848 nx# = sizeofBigNat# x 849 ny# = sizeofBigNat# y 850 851compareBigNatWord :: BigNat -> GmpLimb# -> Ordering 852compareBigNatWord bn w# 853 | isTrue# (sizeofBigNat# bn ==# 1#) = cmpW# (bigNatToWord bn) w# 854 | True = GT 855 856gtBigNatWord# :: BigNat -> GmpLimb# -> Int# 857gtBigNatWord# bn w# 858 = (sizeofBigNat# bn ># 1#) `orI#` (bigNatToWord bn `gtWord#` w#) 859 860eqBigNat :: BigNat -> BigNat -> Bool 861eqBigNat x y = isTrue# (eqBigNat# x y) 862 863eqBigNat# :: BigNat -> BigNat -> Int# 864eqBigNat# x@(BN# x#) y@(BN# y#) 865 | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# ==# 0# 866 | True = 0# 867 where 868 nx# = sizeofBigNat# x 869 ny# = sizeofBigNat# y 870 871neqBigNat# :: BigNat -> BigNat -> Int# 872neqBigNat# x@(BN# x#) y@(BN# y#) 873 | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# /=# 0# 874 | True = 1# 875 where 876 nx# = sizeofBigNat# x 877 ny# = sizeofBigNat# y 878 879eqBigNatWord :: BigNat -> GmpLimb# -> Bool 880eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#) 881 882eqBigNatWord# :: BigNat -> GmpLimb# -> Int# 883eqBigNatWord# bn w# 884 = (sizeofBigNat# bn ==# 1#) `andI#` (bigNatToWord bn `eqWord#` w#) 885 886 887-- | Same as @'indexBigNat#' bn 0\#@ 888bigNatToWord :: BigNat -> Word# 889bigNatToWord bn = indexBigNat# bn 0# 890 891-- | Equivalent to @'word2Int#' . 'bigNatToWord'@ 892bigNatToInt :: BigNat -> Int# 893bigNatToInt (BN# ba#) = indexIntArray# ba# 0# 894 895-- | CAF representing the value @0 :: BigNat@ 896zeroBigNat :: BigNat 897zeroBigNat = runS $ do 898 mbn <- newBigNat# 1# 899 _ <- svoid (writeBigNat# mbn 0# 0##) 900 unsafeFreezeBigNat# mbn 901{-# NOINLINE zeroBigNat #-} 902 903-- | Test if 'BigNat' value is equal to zero. 904isZeroBigNat :: BigNat -> Bool 905isZeroBigNat bn = eqBigNatWord bn 0## 906 907-- | CAF representing the value @1 :: BigNat@ 908oneBigNat :: BigNat 909oneBigNat = runS $ do 910 mbn <- newBigNat# 1# 911 _ <- svoid (writeBigNat# mbn 0# 1##) 912 unsafeFreezeBigNat# mbn 913{-# NOINLINE oneBigNat #-} 914 915czeroBigNat :: BigNat 916czeroBigNat = runS $ do 917 mbn <- newBigNat# 1# 918 _ <- svoid (writeBigNat# mbn 0# (not# 0##)) 919 unsafeFreezeBigNat# mbn 920{-# NOINLINE czeroBigNat #-} 921 922-- | Special 0-sized bigNat returned in case of arithmetic underflow 923-- 924-- This is currently only returned by the following operations: 925-- 926-- - 'minusBigNat' 927-- - 'minusBigNatWord' 928-- 929-- Other operations such as 'quotBigNat' may return 'nullBigNat' as 930-- well as a dummy/place-holder value instead of 'undefined' since we 931-- can't throw exceptions. But that behaviour should not be relied 932-- upon. 933-- 934-- NB: @isValidBigNat# nullBigNat@ is false 935nullBigNat :: BigNat 936nullBigNat = runS (newBigNat# 0# >>= unsafeFreezeBigNat#) 937{-# NOINLINE nullBigNat #-} 938 939-- | Test for special 0-sized 'BigNat' representing underflows. 940isNullBigNat# :: BigNat -> Int# 941isNullBigNat# (BN# ba#) = sizeofByteArray# ba# ==# 0# 942 943-- | Construct 1-limb 'BigNat' from 'Word#' 944wordToBigNat :: Word# -> BigNat 945wordToBigNat 0## = zeroBigNat 946wordToBigNat 1## = oneBigNat 947wordToBigNat w# 948 | isTrue# (not# w# `eqWord#` 0##) = czeroBigNat 949 | True = runS $ do 950 mbn <- newBigNat# 1# 951 _ <- svoid (writeBigNat# mbn 0# w#) 952 unsafeFreezeBigNat# mbn 953 954-- | Construct BigNat from 2 limbs. 955-- The first argument is the most-significant limb. 956wordToBigNat2 :: Word# -> Word# -> BigNat 957wordToBigNat2 0## lw# = wordToBigNat lw# 958wordToBigNat2 hw# lw# = runS $ do 959 mbn <- newBigNat# 2# 960 _ <- svoid (writeBigNat# mbn 0# lw#) 961 _ <- svoid (writeBigNat# mbn 1# hw#) 962 unsafeFreezeBigNat# mbn 963 964plusBigNat :: BigNat -> BigNat -> BigNat 965plusBigNat x y 966 | isTrue# (eqBigNatWord# x 0##) = y 967 | isTrue# (eqBigNatWord# y 0##) = x 968 | isTrue# (nx# >=# ny#) = go x nx# y ny# 969 | True = go y ny# x nx# 970 where 971 go (BN# a#) na# (BN# b#) nb# = runS $ do 972 mbn@(MBN# mba#) <- newBigNat# na# 973 (W# c#) <- liftIO (c_mpn_add mba# a# na# b# nb#) 974 case c# of 975 0## -> unsafeFreezeBigNat# mbn 976 _ -> unsafeSnocFreezeBigNat# mbn c# 977 978 nx# = sizeofBigNat# x 979 ny# = sizeofBigNat# y 980 981plusBigNatWord :: BigNat -> GmpLimb# -> BigNat 982plusBigNatWord x 0## = x 983plusBigNatWord x@(BN# x#) y# = runS $ do 984 mbn@(MBN# mba#) <- newBigNat# nx# 985 (W# c#) <- liftIO (c_mpn_add_1 mba# x# nx# y#) 986 case c# of 987 0## -> unsafeFreezeBigNat# mbn 988 _ -> unsafeSnocFreezeBigNat# mbn c# 989 where 990 nx# = sizeofBigNat# x 991 992-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow 993minusBigNat :: BigNat -> BigNat -> BigNat 994minusBigNat x@(BN# x#) y@(BN# y#) 995 | isZeroBigNat y = x 996 | isTrue# (nx# >=# ny#) = runS $ do 997 mbn@(MBN# mba#) <- newBigNat# nx# 998 (W# b#) <- liftIO (c_mpn_sub mba# x# nx# y# ny#) 999 case b# of 1000 0## -> unsafeRenormFreezeBigNat# mbn 1001 _ -> return nullBigNat 1002 1003 | True = nullBigNat 1004 where 1005 nx# = sizeofBigNat# x 1006 ny# = sizeofBigNat# y 1007 1008-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow 1009minusBigNatWord :: BigNat -> GmpLimb# -> BigNat 1010minusBigNatWord x 0## = x 1011minusBigNatWord x@(BN# x#) y# = runS $ do 1012 mbn@(MBN# mba#) <- newBigNat# nx# 1013 (W# b#) <- liftIO $ c_mpn_sub_1 mba# x# nx# y# 1014 case b# of 1015 0## -> unsafeRenormFreezeBigNat# mbn 1016 _ -> return nullBigNat 1017 where 1018 nx# = sizeofBigNat# x 1019 1020 1021timesBigNat :: BigNat -> BigNat -> BigNat 1022timesBigNat x y 1023 | isZeroBigNat x = zeroBigNat 1024 | isZeroBigNat y = zeroBigNat 1025 | isTrue# (nx# >=# ny#) = go x nx# y ny# 1026 | True = go y ny# x nx# 1027 where 1028 go (BN# a#) na# (BN# b#) nb# = runS $ do 1029 let n# = nx# +# ny# 1030 mbn@(MBN# mba#) <- newBigNat# n# 1031 (W# msl#) <- liftIO (c_mpn_mul mba# a# na# b# nb#) 1032 case msl# of 1033 0## -> unsafeShrinkFreezeBigNat# mbn (n# -# 1#) 1034 _ -> unsafeFreezeBigNat# mbn 1035 1036 nx# = sizeofBigNat# x 1037 ny# = sizeofBigNat# y 1038 1039-- | Square 'BigNat' 1040sqrBigNat :: BigNat -> BigNat 1041sqrBigNat x 1042 | isZeroBigNat x = zeroBigNat 1043 -- TODO: 1-limb BigNats below sqrt(maxBound::GmpLimb) 1044sqrBigNat x = timesBigNat x x -- TODO: mpn_sqr 1045 1046timesBigNatWord :: BigNat -> GmpLimb# -> BigNat 1047timesBigNatWord !_ 0## = zeroBigNat 1048timesBigNatWord x 1## = x 1049timesBigNatWord x@(BN# x#) y# 1050 | isTrue# (nx# ==# 1#) = 1051 let !(# !h#, !l# #) = timesWord2# (bigNatToWord x) y# 1052 in wordToBigNat2 h# l# 1053 | True = runS $ do 1054 mbn@(MBN# mba#) <- newBigNat# nx# 1055 (W# msl#) <- liftIO (c_mpn_mul_1 mba# x# nx# y#) 1056 case msl# of 1057 0## -> unsafeFreezeBigNat# mbn 1058 _ -> unsafeSnocFreezeBigNat# mbn msl# 1059 1060 where 1061 nx# = sizeofBigNat# x 1062 1063-- | Specialised version of 1064-- 1065-- > bitBigNat = shiftLBigNat (wordToBigNat 1##) 1066-- 1067-- avoiding a few redundant allocations 1068bitBigNat :: Int# -> BigNat 1069bitBigNat i# 1070 | isTrue# (i# <# 0#) = zeroBigNat -- or maybe 'nullBigNat'? 1071 | isTrue# (i# ==# 0#) = oneBigNat 1072 | True = runS $ do 1073 mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) 1074 -- FIXME: do we really need to zero-init MBAs returned by 'newByteArray#'? 1075 -- clear all limbs (except for the most-significant limb) 1076 _ <- svoid (clearWordArray# mba# 0# li#) 1077 -- set single bit in most-significant limb 1078 _ <- svoid (writeBigNat# mbn li# (uncheckedShiftL# 1## bi#)) 1079 unsafeFreezeBigNat# mbn 1080 where 1081 !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# 1082 1083testBitBigNat :: BigNat -> Int# -> Bool 1084testBitBigNat bn i# 1085 | isTrue# (i# <# 0#) = False 1086 | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#) 1087 | True = False 1088 where 1089 !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# 1090 nx# = sizeofBigNat# bn 1091 1092testBitNegBigNat :: BigNat -> Int# -> Bool 1093testBitNegBigNat bn i# 1094 | isTrue# (i# <# 0#) = False 1095 | isTrue# (li# >=# nx#) = True 1096 | allZ li# = isTrue# ((testBitWord# 1097 (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#) 1098 | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#) 1099 where 1100 !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# 1101 nx# = sizeofBigNat# bn 1102 1103 allZ 0# = True 1104 allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#) 1105 | True = False 1106 1107 1108clearBitBigNat :: BigNat -> Int# -> BigNat 1109clearBitBigNat bn i# 1110 | not (inline testBitBigNat bn i#) = bn 1111 | isTrue# (nx# ==# 1#) = wordToBigNat (bigNatToWord bn `xor#` bitWord# bi#) 1112 | isTrue# (li# +# 1# ==# nx#) = -- special case, operating on most-sig limb 1113 case indexBigNat# bn li# `xor#` bitWord# bi# of 1114 0## -> do -- most-sig limb became zero -> result has less limbs 1115 case fmssl bn (li# -# 1#) of 1116 0# -> zeroBigNat 1117 n# -> runS $ do 1118 mbn <- newBigNat# n# 1119 _ <- copyWordArray bn 0# mbn 0# n# 1120 unsafeFreezeBigNat# mbn 1121 newlimb# -> runS $ do -- no shrinking 1122 mbn <- newBigNat# nx# 1123 _ <- copyWordArray bn 0# mbn 0# li# 1124 _ <- svoid (writeBigNat# mbn li# newlimb#) 1125 unsafeFreezeBigNat# mbn 1126 1127 | True = runS $ do 1128 mbn <- newBigNat# nx# 1129 _ <- copyWordArray bn 0# mbn 0# nx# 1130 let newlimb# = indexBigNat# bn li# `xor#` bitWord# bi# 1131 _ <- svoid (writeBigNat# mbn li# newlimb#) 1132 unsafeFreezeBigNat# mbn 1133 1134 where 1135 !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# 1136 nx# = sizeofBigNat# bn 1137 1138 1139 1140setBitBigNat :: BigNat -> Int# -> BigNat 1141setBitBigNat bn i# 1142 | inline testBitBigNat bn i# = bn 1143 | isTrue# (d# ># 0#) = runS $ do -- result BigNat will have more limbs 1144 mbn@(MBN# mba#) <- newBigNat# (li# +# 1#) 1145 _ <- copyWordArray bn 0# mbn 0# nx# 1146 _ <- svoid (clearWordArray# mba# nx# (d# -# 1#)) 1147 _ <- svoid (writeBigNat# mbn li# (bitWord# bi#)) 1148 unsafeFreezeBigNat# mbn 1149 1150 | True = runS $ do 1151 mbn <- newBigNat# nx# 1152 _ <- copyWordArray bn 0# mbn 0# nx# 1153 _ <- svoid (writeBigNat# mbn li# (indexBigNat# bn li# 1154 `or#` bitWord# bi#)) 1155 unsafeFreezeBigNat# mbn 1156 1157 where 1158 !(# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# 1159 nx# = sizeofBigNat# bn 1160 d# = li# +# 1# -# nx# 1161 1162 1163complementBitBigNat :: BigNat -> Int# -> BigNat 1164complementBitBigNat bn i# 1165 | testBitBigNat bn i# = clearBitBigNat bn i# 1166 | True = setBitBigNat bn i# 1167 1168popCountBigNat :: BigNat -> Int# 1169popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn)) 1170 1171 1172shiftLBigNat :: BigNat -> Int# -> BigNat 1173shiftLBigNat x 0# = x 1174shiftLBigNat x _ | isZeroBigNat x = zeroBigNat 1175shiftLBigNat x@(BN# xba#) n# = runS $ do 1176 ymbn@(MBN# ymba#) <- newBigNat# yn# 1177 W# ymsl <- liftIO (c_mpn_lshift ymba# xba# xn# (int2Word# n#)) 1178 case ymsl of 1179 0## -> unsafeShrinkFreezeBigNat# ymbn (yn# -# 1#) 1180 _ -> unsafeFreezeBigNat# ymbn 1181 where 1182 xn# = sizeofBigNat# x 1183 yn# = xn# +# nlimbs# +# (nbits# /=# 0#) 1184 !(# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# 1185 1186 1187 1188shiftRBigNat :: BigNat -> Int# -> BigNat 1189shiftRBigNat x 0# = x 1190shiftRBigNat x _ | isZeroBigNat x = zeroBigNat 1191shiftRBigNat x@(BN# xba#) n# 1192 | isTrue# (nlimbs# >=# xn#) = zeroBigNat 1193 | True = runS $ do 1194 ymbn@(MBN# ymba#) <- newBigNat# yn# 1195 W# ymsl <- liftIO (c_mpn_rshift ymba# xba# xn# (int2Word# n#)) 1196 case ymsl of 1197 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one 1198 _ -> unsafeFreezeBigNat# ymbn 1199 where 1200 xn# = sizeofBigNat# x 1201 yn# = xn# -# nlimbs# 1202 nlimbs# = quotInt# n# GMP_LIMB_BITS# 1203 1204shiftRNegBigNat :: BigNat -> Int# -> BigNat 1205shiftRNegBigNat x 0# = x 1206shiftRNegBigNat x _ | isZeroBigNat x = zeroBigNat 1207shiftRNegBigNat x@(BN# xba#) n# 1208 | isTrue# (nlimbs# >=# xn#) = zeroBigNat 1209 | True = runS $ do 1210 ymbn@(MBN# ymba#) <- newBigNat# yn# 1211 W# ymsl <- liftIO (c_mpn_rshift_2c ymba# xba# xn# (int2Word# n#)) 1212 case ymsl of 1213 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one 1214 _ -> unsafeFreezeBigNat# ymbn 1215 where 1216 xn# = sizeofBigNat# x 1217 yn# = xn# -# nlimbs# 1218 nlimbs# = quotInt# (n# -# 1#) GMP_LIMB_BITS# 1219 1220 1221orBigNat :: BigNat -> BigNat -> BigNat 1222orBigNat x@(BN# x#) y@(BN# y#) 1223 | isZeroBigNat x = y 1224 | isZeroBigNat y = x 1225 | isTrue# (nx# >=# ny#) = runS (ior' x# nx# y# ny#) 1226 | True = runS (ior' y# ny# x# nx#) 1227 where 1228 ior' a# na# b# nb# = do -- na >= nb 1229 mbn@(MBN# mba#) <- newBigNat# na# 1230 _ <- liftIO (c_mpn_ior_n mba# a# b# nb#) 1231 _ <- case isTrue# (na# ==# nb#) of 1232 False -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) 1233 True -> return () 1234 unsafeFreezeBigNat# mbn 1235 1236 nx# = sizeofBigNat# x 1237 ny# = sizeofBigNat# y 1238 1239 1240xorBigNat :: BigNat -> BigNat -> BigNat 1241xorBigNat x@(BN# x#) y@(BN# y#) 1242 | isZeroBigNat x = y 1243 | isZeroBigNat y = x 1244 | isTrue# (nx# >=# ny#) = runS (xor' x# nx# y# ny#) 1245 | True = runS (xor' y# ny# x# nx#) 1246 where 1247 xor' a# na# b# nb# = do -- na >= nb 1248 mbn@(MBN# mba#) <- newBigNat# na# 1249 _ <- liftIO (c_mpn_xor_n mba# a# b# nb#) 1250 case isTrue# (na# ==# nb#) of 1251 False -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) 1252 unsafeFreezeBigNat# mbn 1253 True -> unsafeRenormFreezeBigNat# mbn 1254 1255 nx# = sizeofBigNat# x 1256 ny# = sizeofBigNat# y 1257 1258-- | aka @\x y -> x .&. (complement y)@ 1259andnBigNat :: BigNat -> BigNat -> BigNat 1260andnBigNat x@(BN# x#) y@(BN# y#) 1261 | isZeroBigNat x = zeroBigNat 1262 | isZeroBigNat y = x 1263 | True = runS $ do 1264 mbn@(MBN# mba#) <- newBigNat# nx# 1265 _ <- liftIO (c_mpn_andn_n mba# x# y# n#) 1266 _ <- case isTrue# (nx# ==# n#) of 1267 False -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) 1268 True -> return () 1269 unsafeRenormFreezeBigNat# mbn 1270 where 1271 n# | isTrue# (nx# <# ny#) = nx# 1272 | True = ny# 1273 nx# = sizeofBigNat# x 1274 ny# = sizeofBigNat# y 1275 1276 1277andBigNat :: BigNat -> BigNat -> BigNat 1278andBigNat x@(BN# x#) y@(BN# y#) 1279 | isZeroBigNat x = zeroBigNat 1280 | isZeroBigNat y = zeroBigNat 1281 | True = runS $ do 1282 mbn@(MBN# mba#) <- newBigNat# n# 1283 _ <- liftIO (c_mpn_and_n mba# x# y# n#) 1284 unsafeRenormFreezeBigNat# mbn 1285 where 1286 n# | isTrue# (nx# <# ny#) = nx# 1287 | True = ny# 1288 nx# = sizeofBigNat# x 1289 ny# = sizeofBigNat# y 1290 1291-- | If divisor is zero, @(\# 'nullBigNat', 'nullBigNat' \#)@ is returned 1292quotRemBigNat :: BigNat -> BigNat -> (# BigNat,BigNat #) 1293quotRemBigNat n@(BN# nba#) d@(BN# dba#) 1294 | isZeroBigNat d = (# nullBigNat, nullBigNat #) 1295 | eqBigNatWord d 1## = (# n, zeroBigNat #) 1296 | n < d = (# zeroBigNat, n #) 1297 | True = case runS go of (!q,!r) -> (# q, r #) 1298 where 1299 nn# = sizeofBigNat# n 1300 dn# = sizeofBigNat# d 1301 qn# = 1# +# nn# -# dn# 1302 rn# = dn# 1303 1304 go = do 1305 qmbn@(MBN# qmba#) <- newBigNat# qn# 1306 rmbn@(MBN# rmba#) <- newBigNat# rn# 1307 1308 _ <- liftIO (c_mpn_tdiv_qr qmba# rmba# 0# nba# nn# dba# dn#) 1309 1310 q <- unsafeRenormFreezeBigNat# qmbn 1311 r <- unsafeRenormFreezeBigNat# rmbn 1312 return (q, r) 1313 1314quotBigNat :: BigNat -> BigNat -> BigNat 1315quotBigNat n@(BN# nba#) d@(BN# dba#) 1316 | isZeroBigNat d = nullBigNat 1317 | eqBigNatWord d 1## = n 1318 | n < d = zeroBigNat 1319 | True = runS $ do 1320 let nn# = sizeofBigNat# n 1321 let dn# = sizeofBigNat# d 1322 let qn# = 1# +# nn# -# dn# 1323 qmbn@(MBN# qmba#) <- newBigNat# qn# 1324 _ <- liftIO (c_mpn_tdiv_q qmba# nba# nn# dba# dn#) 1325 unsafeRenormFreezeBigNat# qmbn 1326 1327remBigNat :: BigNat -> BigNat -> BigNat 1328remBigNat n@(BN# nba#) d@(BN# dba#) 1329 | isZeroBigNat d = nullBigNat 1330 | eqBigNatWord d 1## = zeroBigNat 1331 | n < d = n 1332 | True = runS $ do 1333 let nn# = sizeofBigNat# n 1334 let dn# = sizeofBigNat# d 1335 rmbn@(MBN# rmba#) <- newBigNat# dn# 1336 _ <- liftIO (c_mpn_tdiv_r rmba# nba# nn# dba# dn#) 1337 unsafeRenormFreezeBigNat# rmbn 1338 1339-- | Note: Result of div/0 undefined 1340quotRemBigNatWord :: BigNat -> GmpLimb# -> (# BigNat, GmpLimb# #) 1341quotRemBigNatWord !_ 0## = (# nullBigNat, 0## #) 1342quotRemBigNatWord n 1## = (# n, 0## #) 1343quotRemBigNatWord n@(BN# nba#) d# = case compareBigNatWord n d# of 1344 LT -> (# zeroBigNat, bigNatToWord n #) 1345 EQ -> (# oneBigNat, 0## #) 1346 GT -> case runS go of (!q,!(W# r#)) -> (# q, r# #) -- TODO: handle word/word 1347 where 1348 go = do 1349 let nn# = sizeofBigNat# n 1350 qmbn@(MBN# qmba#) <- newBigNat# nn# 1351 r <- liftIO (c_mpn_divrem_1 qmba# 0# nba# nn# d#) 1352 q <- unsafeRenormFreezeBigNat# qmbn 1353 return (q,r) 1354 1355quotBigNatWord :: BigNat -> GmpLimb# -> BigNat 1356quotBigNatWord n d# = case inline quotRemBigNatWord n d# of (# q, _ #) -> q 1357 1358-- | div/0 not checked 1359remBigNatWord :: BigNat -> GmpLimb# -> Word# 1360remBigNatWord n@(BN# nba#) d# = c_mpn_mod_1 nba# (sizeofBigNat# n) d# 1361 1362gcdBigNatWord :: BigNat -> Word# -> Word# 1363gcdBigNatWord bn@(BN# ba#) = c_mpn_gcd_1# ba# (sizeofBigNat# bn) 1364 1365gcdBigNat :: BigNat -> BigNat -> BigNat 1366gcdBigNat x@(BN# x#) y@(BN# y#) 1367 | isZeroBigNat x = y 1368 | isZeroBigNat y = x 1369 | isTrue# (nx# >=# ny#) = runS (gcd' x# nx# y# ny#) 1370 | True = runS (gcd' y# ny# x# nx#) 1371 where 1372 gcd' a# na# b# nb# = do -- na >= nb 1373 mbn@(MBN# mba#) <- newBigNat# nb# 1374 I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#) 1375 let rn# = narrowGmpSize# rn'# 1376 case isTrue# (rn# ==# nb#) of 1377 False -> unsafeShrinkFreezeBigNat# mbn rn# 1378 True -> unsafeFreezeBigNat# mbn 1379 1380 nx# = sizeofBigNat# x 1381 ny# = sizeofBigNat# y 1382 1383-- | Extended euclidean algorithm. 1384-- 1385-- For @/a/@ and @/b/@, compute their greatest common divisor @/g/@ 1386-- and the coefficient @/s/@ satisfying @/a//s/ + /b//t/ = /g/@. 1387-- 1388-- @since 0.5.1.0 1389{-# NOINLINE gcdExtInteger #-} 1390gcdExtInteger :: Integer -> Integer -> (# Integer, Integer #) 1391gcdExtInteger a b = case gcdExtSBigNat a' b' of 1392 (# g, s #) -> let !g' = bigNatToInteger g 1393 !s' = sBigNatToInteger s 1394 in (# g', s' #) 1395 where 1396 a' = integerToSBigNat a 1397 b' = integerToSBigNat b 1398 1399-- internal helper 1400gcdExtSBigNat :: SBigNat -> SBigNat -> (# BigNat, SBigNat #) 1401gcdExtSBigNat x y = case runS go of (g,s) -> (# g, s #) 1402 where 1403 go = do 1404 g@(MBN# g#) <- newBigNat# gn0# 1405 -- According to https://gmplib.org/manual/Number-Theoretic-Functions.html#index-mpz_005fgcdext 1406 -- abs(s) < abs(y) / (2 g) 1407 s@(MBN# s#) <- newBigNat# (absI# yn#) 1408 I# ssn_# <- liftIO (integer_gmp_gcdext# s# g# x# xn# y# yn#) 1409 let ssn# = narrowGmpSize# ssn_# 1410 sn# = absI# ssn# 1411 s' <- unsafeShrinkFreezeBigNat# s sn# 1412 g' <- unsafeRenormFreezeBigNat# g 1413 case isTrue# (ssn# >=# 0#) of 1414 False -> return ( g', NegBN s' ) 1415 True -> return ( g', PosBN s' ) 1416 1417 !(BN# x#) = absSBigNat x 1418 !(BN# y#) = absSBigNat y 1419 xn# = ssizeofSBigNat# x 1420 yn# = ssizeofSBigNat# y 1421 1422 gn0# = minI# (absI# xn#) (absI# yn#) 1423 1424---------------------------------------------------------------------------- 1425-- modular exponentiation 1426 1427-- | \"@'powModInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to 1428-- exponent @/e/@ modulo @abs(/m/)@. 1429-- 1430-- Negative exponents are supported if an inverse modulo @/m/@ 1431-- exists. 1432-- 1433-- __Warning__: It's advised to avoid calling this primitive with 1434-- negative exponents unless it is guaranteed the inverse exists, as 1435-- failure to do so will likely cause program abortion due to a 1436-- divide-by-zero fault. See also 'recipModInteger'. 1437-- 1438-- Future versions of @integer_gmp@ may not support negative @/e/@ 1439-- values anymore. 1440-- 1441-- @since 0.5.1.0 1442{-# NOINLINE powModInteger #-} 1443powModInteger :: Integer -> Integer -> Integer -> Integer 1444powModInteger (S# b#) (S# e#) (S# m#) 1445 | isTrue# (b# >=# 0#), isTrue# (e# >=# 0#) 1446 = wordToInteger (powModWord (int2Word# b#) (int2Word# e#) 1447 (int2Word# (absI# m#))) 1448powModInteger b e m = case m of 1449 (S# m#) -> wordToInteger (powModSBigNatWord b' e' (int2Word# (absI# m#))) 1450 (Jp# m') -> bigNatToInteger (powModSBigNat b' e' m') 1451 (Jn# m') -> bigNatToInteger (powModSBigNat b' e' m') 1452 where 1453 b' = integerToSBigNat b 1454 e' = integerToSBigNat e 1455 1456-- | \"@'powModSecInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to 1457-- exponent @/e/@ modulo @/m/@. It is required that @/e/ >= 0@ and 1458-- @/m/@ is odd. 1459-- 1460-- This is a \"secure\" variant of 'powModInteger' using the 1461-- @mpz_powm_sec()@ function which is designed to be resilient to side 1462-- channel attacks and is therefore intended for cryptographic 1463-- applications. 1464-- 1465-- This primitive is only available when the underlying GMP library 1466-- supports it (GMP >= 5). Otherwise, it internally falls back to 1467-- @'powModInteger'@, and a warning will be emitted when used. 1468-- 1469-- @since 1.0.2.0 1470{-# NOINLINE powModSecInteger #-} 1471powModSecInteger :: Integer -> Integer -> Integer -> Integer 1472powModSecInteger b e m = bigNatToInteger (powModSecSBigNat b' e' m') 1473 where 1474 b' = integerToSBigNat b 1475 e' = integerToSBigNat e 1476 m' = absSBigNat (integerToSBigNat m) 1477 1478#if HAVE_SECURE_POWM == 0 1479{-# 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" #-} 1480#endif 1481 1482-- | Version of 'powModInteger' operating on 'BigNat's 1483-- 1484-- @since 1.0.0.0 1485powModBigNat :: BigNat -> BigNat -> BigNat -> BigNat 1486powModBigNat b e m = inline powModSBigNat (PosBN b) (PosBN e) m 1487 1488-- | Version of 'powModInteger' for 'Word#'-sized moduli 1489-- 1490-- @since 1.0.0.0 1491powModBigNatWord :: BigNat -> BigNat -> GmpLimb# -> GmpLimb# 1492powModBigNatWord b e m# = inline powModSBigNatWord (PosBN b) (PosBN e) m# 1493 1494-- | Version of 'powModInteger' operating on 'Word#'s 1495-- 1496-- @since 1.0.0.0 1497foreign import ccall unsafe "integer_gmp_powm_word" 1498 powModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# 1499 1500-- internal non-exported helper 1501powModSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat 1502powModSBigNat b e m@(BN# m#) = runS $ do 1503 r@(MBN# r#) <- newBigNat# mn# 1504 I# rn_# <- liftIO (integer_gmp_powm# r# b# bn# e# en# m# mn#) 1505 let rn# = narrowGmpSize# rn_# 1506 case isTrue# (rn# ==# mn#) of 1507 False -> unsafeShrinkFreezeBigNat# r rn# 1508 True -> unsafeFreezeBigNat# r 1509 where 1510 !(BN# b#) = absSBigNat b 1511 !(BN# e#) = absSBigNat e 1512 bn# = ssizeofSBigNat# b 1513 en# = ssizeofSBigNat# e 1514 mn# = sizeofBigNat# m 1515 1516foreign import ccall unsafe "integer_gmp_powm" 1517 integer_gmp_powm# :: MutableByteArray# RealWorld 1518 -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# 1519 -> ByteArray# -> GmpSize# -> IO GmpSize 1520 1521-- internal non-exported helper 1522powModSBigNatWord :: SBigNat -> SBigNat -> GmpLimb# -> GmpLimb# 1523powModSBigNatWord b e m# = integer_gmp_powm1# b# bn# e# en# m# 1524 where 1525 !(BN# b#) = absSBigNat b 1526 !(BN# e#) = absSBigNat e 1527 bn# = ssizeofSBigNat# b 1528 en# = ssizeofSBigNat# e 1529 1530foreign import ccall unsafe "integer_gmp_powm1" 1531 integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# 1532 -> GmpLimb# -> GmpLimb# 1533 1534-- internal non-exported helper 1535powModSecSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat 1536powModSecSBigNat b e m@(BN# m#) = runS $ do 1537 r@(MBN# r#) <- newBigNat# mn# 1538 I# rn_# <- liftIO (integer_gmp_powm_sec# r# b# bn# e# en# m# mn#) 1539 let rn# = narrowGmpSize# rn_# 1540 case isTrue# (rn# ==# mn#) of 1541 False -> unsafeShrinkFreezeBigNat# r rn# 1542 True -> unsafeFreezeBigNat# r 1543 where 1544 !(BN# b#) = absSBigNat b 1545 !(BN# e#) = absSBigNat e 1546 bn# = ssizeofSBigNat# b 1547 en# = ssizeofSBigNat# e 1548 mn# = sizeofBigNat# m 1549 1550foreign import ccall unsafe "integer_gmp_powm_sec" 1551 integer_gmp_powm_sec# :: MutableByteArray# RealWorld 1552 -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# 1553 -> ByteArray# -> GmpSize# -> IO GmpSize 1554 1555 1556-- | \"@'recipModInteger' /x/ /m/@\" computes the inverse of @/x/@ modulo @/m/@. If 1557-- the inverse exists, the return value @/y/@ will satisfy @0 < /y/ < 1558-- abs(/m/)@, otherwise the result is @0@. 1559-- 1560-- @since 0.5.1.0 1561{-# NOINLINE recipModInteger #-} 1562recipModInteger :: Integer -> Integer -> Integer 1563recipModInteger (S# x#) (S# m#) 1564 | isTrue# (x# >=# 0#) 1565 = wordToInteger (recipModWord (int2Word# x#) (int2Word# (absI# m#))) 1566recipModInteger x m = bigNatToInteger (recipModSBigNat x' m') 1567 where 1568 x' = integerToSBigNat x 1569 m' = absSBigNat (integerToSBigNat m) 1570 1571-- | Version of 'recipModInteger' operating on 'BigNat's 1572-- 1573-- @since 1.0.0.0 1574recipModBigNat :: BigNat -> BigNat -> BigNat 1575recipModBigNat x m = inline recipModSBigNat (PosBN x) m 1576 1577-- | Version of 'recipModInteger' operating on 'Word#'s 1578-- 1579-- @since 1.0.0.0 1580foreign import ccall unsafe "integer_gmp_invert_word" 1581 recipModWord :: GmpLimb# -> GmpLimb# -> GmpLimb# 1582 1583-- internal non-exported helper 1584recipModSBigNat :: SBigNat -> BigNat -> BigNat 1585recipModSBigNat x m@(BN# m#) = runS $ do 1586 r@(MBN# r#) <- newBigNat# mn# 1587 I# rn_# <- liftIO (integer_gmp_invert# r# x# xn# m# mn#) 1588 let rn# = narrowGmpSize# rn_# 1589 case isTrue# (rn# ==# mn#) of 1590 False -> unsafeShrinkFreezeBigNat# r rn# 1591 True -> unsafeFreezeBigNat# r 1592 where 1593 !(BN# x#) = absSBigNat x 1594 xn# = ssizeofSBigNat# x 1595 mn# = sizeofBigNat# m 1596 1597foreign import ccall unsafe "integer_gmp_invert" 1598 integer_gmp_invert# :: MutableByteArray# RealWorld 1599 -> ByteArray# -> GmpSize# 1600 -> ByteArray# -> GmpSize# -> IO GmpSize 1601 1602---------------------------------------------------------------------------- 1603-- Conversions to/from floating point 1604 1605decodeDoubleInteger :: Double# -> (# Integer, Int# #) 1606-- decodeDoubleInteger 0.0## = (# S# 0#, 0# #) 1607#if WORD_SIZE_IN_BITS == 64 1608decodeDoubleInteger x = case decodeDouble_Int64# x of 1609 (# m#, e# #) -> (# S# m#, e# #) 1610#elif WORD_SIZE_IN_BITS == 32 1611decodeDoubleInteger x = case decodeDouble_Int64# x of 1612 (# m#, e# #) -> (# int64ToInteger m#, e# #) 1613#endif 1614{-# CONSTANT_FOLDED decodeDoubleInteger #-} 1615 1616-- provided by GHC's RTS 1617foreign import ccall unsafe "__int_encodeDouble" 1618 int_encodeDouble# :: Int# -> Int# -> Double# 1619 1620encodeDoubleInteger :: Integer -> Int# -> Double# 1621encodeDoubleInteger (S# m#) 0# = int2Double# m# 1622encodeDoubleInteger (S# m#) e# = int_encodeDouble# m# e# 1623encodeDoubleInteger (Jp# bn@(BN# bn#)) e# 1624 = c_mpn_get_d bn# (sizeofBigNat# bn) e# 1625encodeDoubleInteger (Jn# bn@(BN# bn#)) e# 1626 = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) e# 1627{-# CONSTANT_FOLDED encodeDoubleInteger #-} 1628 1629-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) 1630foreign import ccall unsafe "integer_gmp_mpn_get_d" 1631 c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# 1632 1633doubleFromInteger :: Integer -> Double# 1634doubleFromInteger (S# m#) = int2Double# m# 1635doubleFromInteger (Jp# bn@(BN# bn#)) 1636 = c_mpn_get_d bn# (sizeofBigNat# bn) 0# 1637doubleFromInteger (Jn# bn@(BN# bn#)) 1638 = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) 0# 1639{-# CONSTANT_FOLDED doubleFromInteger #-} 1640 1641-- TODO: Not sure if it's worth to write 'Float' optimized versions here 1642floatFromInteger :: Integer -> Float# 1643floatFromInteger i = double2Float# (doubleFromInteger i) 1644 1645encodeFloatInteger :: Integer -> Int# -> Float# 1646encodeFloatInteger m e = double2Float# (encodeDoubleInteger m e) 1647 1648---------------------------------------------------------------------------- 1649-- FFI ccall imports 1650 1651foreign import ccall unsafe "integer_gmp_gcd_word" 1652 gcdWord# :: GmpLimb# -> GmpLimb# -> GmpLimb# 1653 1654foreign import ccall unsafe "integer_gmp_mpn_gcd_1" 1655 c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# 1656 1657foreign import ccall unsafe "integer_gmp_mpn_gcd" 1658 c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# 1659 -> ByteArray# -> GmpSize# -> IO GmpSize 1660 1661foreign import ccall unsafe "integer_gmp_gcdext" 1662 integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s 1663 -> ByteArray# -> GmpSize# 1664 -> ByteArray# -> GmpSize# -> IO GmpSize 1665 1666-- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, 1667-- mp_limb_t s2limb) 1668foreign import ccall unsafe "gmp.h __gmpn_add_1" 1669 c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# 1670 -> IO GmpLimb 1671 1672-- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, 1673-- mp_limb_t s2limb) 1674foreign import ccall unsafe "gmp.h __gmpn_sub_1" 1675 c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# 1676 -> IO GmpLimb 1677 1678-- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, 1679-- mp_limb_t s2limb) 1680foreign import ccall unsafe "gmp.h __gmpn_mul_1" 1681 c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# 1682 -> IO GmpLimb 1683 1684-- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, 1685-- const mp_limb_t *s2p, mp_size_t s2n) 1686foreign import ccall unsafe "gmp.h __gmpn_add" 1687 c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# 1688 -> ByteArray# -> GmpSize# -> IO GmpLimb 1689 1690-- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, 1691-- const mp_limb_t *s2p, mp_size_t s2n) 1692foreign import ccall unsafe "gmp.h __gmpn_sub" 1693 c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# 1694 -> GmpSize# -> IO GmpLimb 1695 1696-- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, 1697-- const mp_limb_t *s2p, mp_size_t s2n) 1698foreign import ccall unsafe "gmp.h __gmpn_mul" 1699 c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# 1700 -> GmpSize# -> IO GmpLimb 1701 1702-- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) 1703foreign import ccall unsafe "gmp.h __gmpn_cmp" 1704 c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> CInt# 1705 1706-- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, 1707-- const mp_limb_t *np, mp_size_t nn, 1708-- const mp_limb_t *dp, mp_size_t dn) 1709foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" 1710 c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# 1711 -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () 1712 1713foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" 1714 c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# 1715 -> GmpSize# -> IO () 1716 1717foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" 1718 c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# 1719 -> GmpSize# -> IO () 1720 1721-- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, 1722-- mp_size_t s2n, mp_limb_t s3limb) 1723foreign import ccall unsafe "gmp.h __gmpn_divrem_1" 1724 c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# 1725 -> GmpLimb# -> IO GmpLimb 1726 1727-- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) 1728foreign import ccall unsafe "gmp.h __gmpn_mod_1" 1729 c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# 1730 1731-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], 1732-- mp_size_t sn, mp_bitcnt_t count) 1733foreign import ccall unsafe "integer_gmp_mpn_rshift" 1734 c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# 1735 -> IO GmpLimb 1736 1737-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], 1738-- mp_size_t sn, mp_bitcnt_t count) 1739foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" 1740 c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# 1741 -> IO GmpLimb 1742 1743-- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], 1744-- mp_size_t sn, mp_bitcnt_t count) 1745foreign import ccall unsafe "integer_gmp_mpn_lshift" 1746 c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# 1747 -> IO GmpLimb 1748 1749-- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, 1750-- mp_size_t n) 1751foreign import ccall unsafe "integer_gmp_mpn_and_n" 1752 c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# 1753 -> IO () 1754 1755-- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, 1756-- mp_size_t n) 1757foreign import ccall unsafe "integer_gmp_mpn_andn_n" 1758 c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# 1759 -> IO () 1760 1761-- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, 1762-- mp_size_t n) 1763foreign import ccall unsafe "integer_gmp_mpn_ior_n" 1764 c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# 1765 -> IO () 1766 1767-- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, 1768-- mp_size_t n) 1769foreign import ccall unsafe "integer_gmp_mpn_xor_n" 1770 c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# 1771 -> IO () 1772 1773-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) 1774foreign import ccall unsafe "gmp.h __gmpn_popcount" 1775 c_mpn_popcount :: ByteArray# -> GmpSize# -> GmpBitCnt# 1776 1777---------------------------------------------------------------------------- 1778-- BigNat-wrapped ByteArray#-primops 1779 1780-- | Return number of limbs contained in 'BigNat'. 1781-- 1782-- The result is always @>= 1@ since even zero is encoded with 1 limb. 1783sizeofBigNat# :: BigNat -> GmpSize# 1784sizeofBigNat# (BN# x#) 1785 = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# 1786 1787data MutBigNat s = MBN# !(MutableByteArray# s) 1788 1789getSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, GmpSize# #) 1790--getSizeofMutBigNat# :: MutBigNat s -> S s GmpSize# 1791getSizeofMutBigNat# (MBN# x#) s = 1792 case getSizeofMutableByteArray# x# s of 1793 (# s', n# #) -> (# s', n# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# #) 1794 1795newBigNat# :: GmpSize# -> S s (MutBigNat s) 1796newBigNat# limbs# s = 1797 case newByteArray# (limbs# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) s of 1798 (# s', mba# #) -> (# s', MBN# mba# #) 1799 1800writeBigNat# :: MutBigNat s -> GmpSize# -> GmpLimb# -> State# s -> State# s 1801writeBigNat# (MBN# mba#) = writeWordArray# mba# 1802 1803-- | Extract /n/-th (0-based) limb in 'BigNat'. 1804-- /n/ must be less than size as reported by 'sizeofBigNat#'. 1805indexBigNat# :: BigNat -> GmpSize# -> GmpLimb# 1806indexBigNat# (BN# ba#) = indexWordArray# ba# 1807 1808unsafeFreezeBigNat# :: MutBigNat s -> S s BigNat 1809unsafeFreezeBigNat# (MBN# mba#) s = case unsafeFreezeByteArray# mba# s of 1810 (# s', ba# #) -> (# s', BN# ba# #) 1811 1812resizeMutBigNat# :: MutBigNat s -> GmpSize# -> S s (MutBigNat s) 1813resizeMutBigNat# (MBN# mba0#) nsz# s 1814 | isTrue# (bsz# ==# n#) = (# s', MBN# mba0# #) 1815 | True = 1816 case resizeMutableByteArray# mba0# bsz# s' of 1817 (# s'', mba# #) -> (# s'', MBN# mba# #) 1818 where 1819 bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# 1820 !(# s', n# #) = getSizeofMutableByteArray# mba0# s 1821 1822shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s 1823shrinkMutBigNat# (MBN# mba0#) nsz# s 1824 | isTrue# (bsz# ==# n#) = s' -- no-op 1825 | True = shrinkMutableByteArray# mba0# bsz# s' 1826 where 1827 bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# 1828 !(# s', n# #) = getSizeofMutableByteArray# mba0# s 1829 1830unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat 1831unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# s = go s' 1832 where 1833 n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# 1834 !(# s', nb0# #) = getSizeofMutableByteArray# mba0# s 1835 go = do 1836 (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) 1837 _ <- svoid (writeWordArray# mba# n# limb#) 1838 unsafeFreezeBigNat# (MBN# mba#) 1839 1840-- | May shrink underlyng 'ByteArray#' if needed to satisfy BigNat invariant 1841unsafeRenormFreezeBigNat# :: MutBigNat s -> S s BigNat 1842unsafeRenormFreezeBigNat# mbn s 1843 | isTrue# (n0# ==# 0#) = (# s'', nullBigNat #) 1844 | isTrue# (n# ==# 0#) = (# s'', zeroBigNat #) 1845 | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s'' 1846 | True = (unsafeShrinkFreezeBigNat# mbn n#) s'' 1847 where 1848 !(# s', n0# #) = getSizeofMutBigNat# mbn s 1849 !(# s'', n# #) = normSizeofMutBigNat'# mbn n0# s' 1850 1851-- | Shrink MBN 1852unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat 1853unsafeShrinkFreezeBigNat# x@(MBN# xmba) 1# 1854 = \s -> case readWordArray# xmba 0# s of 1855 (# s', w# #) -> freezeOneLimb w# s' 1856 where 1857 freezeOneLimb 0## = return zeroBigNat 1858 freezeOneLimb 1## = return oneBigNat 1859 freezeOneLimb w# | isTrue# (not# w# `eqWord#` 0##) = return czeroBigNat 1860 freezeOneLimb _ = do 1861 _ <- svoid (shrinkMutBigNat# x 1#) 1862 unsafeFreezeBigNat# x 1863unsafeShrinkFreezeBigNat# x y# = do 1864 _ <- svoid (shrinkMutBigNat# x y#) 1865 unsafeFreezeBigNat# x 1866 1867 1868copyWordArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# 1869 -> State# s -> State# s 1870copyWordArray# src src_ofs dst dst_ofs len 1871 = copyByteArray# src (src_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 1872 dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 1873 (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 1874 1875copyWordArray :: BigNat -> Int# -> MutBigNat s -> Int# -> Int# -> S s () 1876copyWordArray (BN# ba#) ofs_ba# (MBN# mba#) ofs_mba# len# 1877 = svoid (copyWordArray# ba# ofs_ba# mba# ofs_mba# len#) 1878 1879clearWordArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s 1880clearWordArray# mba ofs len 1881 = setByteArray# mba (ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 1882 (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 0# 1883 1884-- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#' 1885normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) 1886normSizeofMutBigNat# mbn@(MBN# mba) s = normSizeofMutBigNat'# mbn sz# s' 1887 where 1888 !(# s', n# #) = getSizeofMutableByteArray# mba s 1889 sz# = n# `uncheckedIShiftRA#` GMP_LIMB_SHIFT# 1890 1891-- | Find most-significant non-zero limb and return its index-position 1892-- plus one. Start scanning downward from the initial limb-size 1893-- (i.e. start-index plus one) given as second argument. 1894-- 1895-- NB: The 'normSizeofMutBigNat' of 'zeroBigNat' would be @0#@ 1896normSizeofMutBigNat'# :: MutBigNat s -> GmpSize# 1897 -> State# s -> (# State# s, GmpSize# #) 1898normSizeofMutBigNat'# (MBN# mba) = go 1899 where 1900 go 0# s = (# s, 0# #) 1901 go i0# s = case readWordArray# mba (i0# -# 1#) s of 1902 (# s', 0## #) -> go (i0# -# 1#) s' 1903 (# s', _ #) -> (# s', i0# #) 1904 1905-- | Construct 'BigNat' from existing 'ByteArray#' containing /n/ 1906-- 'GmpLimb's in least-significant-first order. 1907-- 1908-- If possible 'ByteArray#', will be used directly (i.e. shared 1909-- /without/ cloning the 'ByteArray#' into a newly allocated one) 1910-- 1911-- Note: size parameter (times @sizeof(GmpLimb)@) must be less or 1912-- equal to its 'sizeofByteArray#'. 1913byteArrayToBigNat# :: ByteArray# -> GmpSize# -> BigNat 1914byteArrayToBigNat# ba# n0# 1915 | isTrue# (n# ==# 0#) = zeroBigNat 1916 | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size 1917 , isTrue# (baszq# ==# n#) = (BN# ba#) 1918 | True = runS $ \s -> 1919 let !(# s', mbn@(MBN# mba#) #) = newBigNat# n# s 1920 !(# s'', ba_sz# #) = getSizeofMutableByteArray# mba# s' 1921 go = do _ <- svoid (copyByteArray# ba# 0# mba# 0# ba_sz# ) 1922 unsafeFreezeBigNat# mbn 1923 in go s'' 1924 where 1925 !(# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# 1926 1927 n# = fmssl (BN# ba#) (n0# -# 1#) 1928 1929-- | Read 'Integer' (without sign) from memory location at @/addr/@ in 1930-- base-256 representation. 1931-- 1932-- @'importIntegerFromAddr' /addr/ /size/ /msbf/@ 1933-- 1934-- See description of 'importIntegerFromByteArray' for more details. 1935-- 1936-- @since 1.0.0.0 1937importIntegerFromAddr :: Addr# -> Word# -> Int# -> IO Integer 1938importIntegerFromAddr addr len msbf = IO $ do 1939 bn <- liftIO (importBigNatFromAddr addr len msbf) 1940 return (bigNatToInteger bn) 1941 1942-- | Version of 'importIntegerFromAddr' constructing a 'BigNat' 1943importBigNatFromAddr :: Addr# -> Word# -> Int# -> IO BigNat 1944importBigNatFromAddr _ 0## _ = IO (\s -> (# s, zeroBigNat #)) 1945importBigNatFromAddr addr len0 1# = IO $ do -- MSBF 1946 W# ofs <- liftIO (c_scan_nzbyte_addr addr 0## len0) 1947 let len = len0 `minusWord#` ofs 1948 addr' = addr `plusAddr#` (word2Int# ofs) 1949 importBigNatFromAddr# addr' len 1# 1950importBigNatFromAddr addr len0 _ = IO $ do -- LSBF 1951 W# len <- liftIO (c_rscan_nzbyte_addr addr 0## len0) 1952 importBigNatFromAddr# addr len 0# 1953 1954foreign import ccall unsafe "integer_gmp_scan_nzbyte" 1955 c_scan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word 1956 1957foreign import ccall unsafe "integer_gmp_rscan_nzbyte" 1958 c_rscan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word 1959 1960-- | Helper for 'importBigNatFromAddr' 1961importBigNatFromAddr# :: Addr# -> Word# -> Int# -> S RealWorld BigNat 1962importBigNatFromAddr# _ 0## _ = return zeroBigNat 1963importBigNatFromAddr# addr len msbf = do 1964 mbn@(MBN# mba#) <- newBigNat# n# 1965 () <- liftIO (c_mpn_import_addr mba# addr 0## len msbf) 1966 unsafeFreezeBigNat# mbn 1967 where 1968 -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required 1969 n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# 1970 1971foreign import ccall unsafe "integer_gmp_mpn_import" 1972 c_mpn_import_addr :: MutableByteArray# RealWorld -> Addr# -> Word# -> Word# 1973 -> Int# -> IO () 1974 1975-- | Read 'Integer' (without sign) from byte-array in base-256 representation. 1976-- 1977-- The call 1978-- 1979-- @'importIntegerFromByteArray' /ba/ /offset/ /size/ /msbf/@ 1980-- 1981-- reads 1982-- 1983-- * @/size/@ bytes from the 'ByteArray#' @/ba/@ starting at @/offset/@ 1984-- 1985-- * with most significant byte first if @/msbf/@ is @1#@ or least 1986-- significant byte first if @/msbf/@ is @0#@, and 1987-- 1988-- * returns a new 'Integer' 1989-- 1990-- @since 1.0.0.0 1991importIntegerFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> Integer 1992importIntegerFromByteArray ba ofs len msbf 1993 = bigNatToInteger (importBigNatFromByteArray ba ofs len msbf) 1994 1995-- | Version of 'importIntegerFromByteArray' constructing a 'BigNat' 1996importBigNatFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> BigNat 1997importBigNatFromByteArray _ _ 0## _ = zeroBigNat 1998importBigNatFromByteArray ba ofs0 len0 1# = runS $ do -- MSBF 1999 W# ofs <- liftIO (c_scan_nzbyte_bytearray ba ofs0 len0) 2000 let len = (len0 `plusWord#` ofs0) `minusWord#` ofs 2001 importBigNatFromByteArray# ba ofs len 1# 2002importBigNatFromByteArray ba ofs len0 _ = runS $ do -- LSBF 2003 W# len <- liftIO (c_rscan_nzbyte_bytearray ba ofs len0) 2004 importBigNatFromByteArray# ba ofs len 0# 2005 2006foreign import ccall unsafe "integer_gmp_scan_nzbyte" 2007 c_scan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word 2008 2009foreign import ccall unsafe "integer_gmp_rscan_nzbyte" 2010 c_rscan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word 2011 2012-- | Helper for 'importBigNatFromByteArray' 2013importBigNatFromByteArray# :: ByteArray# -> Word# -> Word# -> Int# 2014 -> S RealWorld BigNat 2015importBigNatFromByteArray# _ _ 0## _ = return zeroBigNat 2016importBigNatFromByteArray# ba ofs len msbf = do 2017 mbn@(MBN# mba#) <- newBigNat# n# 2018 () <- liftIO (c_mpn_import_bytearray mba# ba ofs len msbf) 2019 unsafeFreezeBigNat# mbn 2020 where 2021 -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required 2022 n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD# 2023 2024foreign import ccall unsafe "integer_gmp_mpn_import" 2025 c_mpn_import_bytearray :: MutableByteArray# RealWorld -> ByteArray# -> Word# 2026 -> Word# -> Int# -> IO () 2027 2028-- | Test whether all internal invariants are satisfied by 'BigNat' value 2029-- 2030-- Returns @1#@ if valid, @0#@ otherwise. 2031-- 2032-- This operation is mostly useful for test-suites and/or code which 2033-- constructs 'Integer' values directly. 2034isValidBigNat# :: BigNat -> Int# 2035isValidBigNat# (BN# ba#) 2036 = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm# 2037 where 2038 isNorm# 2039 | isTrue# (szq# ># 1#) = (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## 2040 | True = 1# 2041 2042 sz# = sizeofByteArray# ba# 2043 2044 !(# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# 2045 2046-- | Version of 'nextPrimeInteger' operating on 'BigNat's 2047-- 2048-- @since 1.0.0.0 2049nextPrimeBigNat :: BigNat -> BigNat 2050nextPrimeBigNat bn@(BN# ba#) = runS $ do 2051 mbn@(MBN# mba#) <- newBigNat# n# 2052 (W# c#) <- liftIO (nextPrime# mba# ba# n#) 2053 case c# of 2054 0## -> unsafeFreezeBigNat# mbn 2055 _ -> unsafeSnocFreezeBigNat# mbn c# 2056 where 2057 n# = sizeofBigNat# bn 2058 2059foreign import ccall unsafe "integer_gmp_next_prime" 2060 nextPrime# :: MutableByteArray# RealWorld -> ByteArray# -> GmpSize# 2061 -> IO GmpLimb 2062 2063---------------------------------------------------------------------------- 2064-- monadic combinators for low-level state threading 2065 2066type S s a = State# s -> (# State# s, a #) 2067 2068infixl 1 >>= 2069infixl 1 >> 2070infixr 0 $ 2071 2072{-# INLINE ($) #-} 2073($) :: (a -> b) -> a -> b 2074f $ x = f x 2075 2076{-# INLINE (>>=) #-} 2077(>>=) :: S s a -> (a -> S s b) -> S s b 2078(>>=) m k = \s -> case m s of (# s', a #) -> k a s' 2079 2080{-# INLINE (>>) #-} 2081(>>) :: S s a -> S s b -> S s b 2082(>>) m k = \s -> case m s of (# s', _ #) -> k s' 2083 2084{-# INLINE svoid #-} 2085svoid :: (State# s -> State# s) -> S s () 2086svoid m0 = \s -> case m0 s of s' -> (# s', () #) 2087 2088{-# INLINE return #-} 2089return :: a -> S s a 2090return a = \s -> (# s, a #) 2091 2092{-# INLINE liftIO #-} 2093liftIO :: IO a -> S RealWorld a 2094liftIO (IO m) = m 2095 2096-- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there 2097runS :: S RealWorld a -> a 2098runS m = case runRW# m of (# _, a #) -> a 2099 2100-- stupid hack 2101fail :: [Char] -> S s a 2102fail s = return (raise# s) 2103 2104---------------------------------------------------------------------------- 2105 2106-- | Internal helper type for "signed" 'BigNat's 2107-- 2108-- This is a useful abstraction for operations which support negative 2109-- mp_size_t arguments. 2110data SBigNat = NegBN !BigNat | PosBN !BigNat 2111 2112-- | Absolute value of 'SBigNat' 2113absSBigNat :: SBigNat -> BigNat 2114absSBigNat (NegBN bn) = bn 2115absSBigNat (PosBN bn) = bn 2116 2117-- | /Signed/ limb count. Negative sizes denote negative integers 2118ssizeofSBigNat# :: SBigNat -> GmpSize# 2119ssizeofSBigNat# (NegBN bn) = negateInt# (sizeofBigNat# bn) 2120ssizeofSBigNat# (PosBN bn) = sizeofBigNat# bn 2121 2122-- | Construct 'SBigNat' from 'Int#' value 2123intToSBigNat# :: Int# -> SBigNat 2124intToSBigNat# 0# = PosBN zeroBigNat 2125intToSBigNat# 1# = PosBN oneBigNat 2126intToSBigNat# (-1#) = NegBN oneBigNat 2127intToSBigNat# i# | isTrue# (i# ># 0#) = PosBN (wordToBigNat (int2Word# i#)) 2128 | True = NegBN (wordToBigNat (int2Word# (negateInt# i#))) 2129 2130-- | Convert 'Integer' into 'SBigNat' 2131integerToSBigNat :: Integer -> SBigNat 2132integerToSBigNat (S# i#) = intToSBigNat# i# 2133integerToSBigNat (Jp# bn) = PosBN bn 2134integerToSBigNat (Jn# bn) = NegBN bn 2135 2136-- | Convert 'SBigNat' into 'Integer' 2137sBigNatToInteger :: SBigNat -> Integer 2138sBigNatToInteger (NegBN bn) = bigNatToNegInteger bn 2139sBigNatToInteger (PosBN bn) = bigNatToInteger bn 2140 2141---------------------------------------------------------------------------- 2142-- misc helpers, some of these should rather be primitives exported by ghc-prim 2143 2144cmpW# :: Word# -> Word# -> Ordering 2145cmpW# x# y# 2146 | isTrue# (x# `ltWord#` y#) = LT 2147 | isTrue# (x# `eqWord#` y#) = EQ 2148 | True = GT 2149{-# INLINE cmpW# #-} 2150 2151bitWord# :: Int# -> Word# 2152bitWord# = uncheckedShiftL# 1## 2153{-# INLINE bitWord# #-} 2154 2155testBitWord# :: Word# -> Int# -> Int# 2156testBitWord# w# i# = (bitWord# i# `and#` w#) `neWord#` 0## 2157{-# INLINE testBitWord# #-} 2158 2159popCntI# :: Int# -> Int# 2160popCntI# i# = word2Int# (popCnt# (int2Word# i#)) 2161{-# INLINE popCntI# #-} 2162 2163-- branchless version 2164absI# :: Int# -> Int# 2165absI# i# = (i# `xorI#` nsign) -# nsign 2166 where 2167 -- nsign = negateInt# (i# <# 0#) 2168 nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#) 2169 2170-- branchless version 2171sgnI# :: Int# -> Int# 2172sgnI# x# = (x# ># 0#) -# (x# <# 0#) 2173 2174cmpI# :: Int# -> Int# -> Int# 2175cmpI# x# y# = (x# ># y#) -# (x# <# y#) 2176 2177minI# :: Int# -> Int# -> Int# 2178minI# x# y# | isTrue# (x# <=# y#) = x# 2179 | True = y# 2180 2181-- find most-sig set limb, starting at given index 2182fmssl :: BigNat -> Int# -> Int# 2183fmssl !bn i0# = go i0# 2184 where 2185 go i# | isTrue# (i# <# 0#) = 0# 2186 | isTrue# (neWord# (indexBigNat# bn i#) 0##) = i# +# 1# 2187 | True = go (i# -# 1#) 2188