48c5ed85bcdf7ae12c229aebacefab570d50a738
[ghc.git] / libraries / integer-gmp2 / src / GHC / Integer / Type.hs
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
25 module GHC.Integer.Type where
26
27 #include "MachDeps.h"
28
29 -- Sanity check as CPP defines are implicitly 0-valued when undefined
30 #if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \
31 && defined(WORD_SIZE_IN_BITS))
32 # error missing defines
33 #endif
34
35 import GHC.Classes
36 import GHC.Magic
37 import GHC.Prim
38 import GHC.Types
39 #if WORD_SIZE_IN_BITS < 64
40 import GHC.IntWord64
41 #endif
42
43 default ()
44
45 -- Most high-level operations need to be marked `NOINLINE` as
46 -- otherwise GHC doesn't recognize them and fails to apply constant
47 -- folding to `Integer`-typed expression.
48 --
49 -- To this end, the CPP hack below allows to write the pseudo-pragma
50 --
51 -- {-# CONSTANT_FOLDED plusInteger #-}
52 --
53 -- which is simply expaned into a
54 --
55 -- {-# NOINLINE plusInteger #-}
56 --
57 #define CONSTANT_FOLDED NOINLINE
58
59 ----------------------------------------------------------------------------
60 -- type definitions
61
62 -- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS
63 -- The C99 code in cbits/wrappers.c will fail to compile if this doesn't hold
64
65 -- | Type representing a GMP Limb
66 type GmpLimb = Word -- actually, 'CULong'
67 type GmpLimb# = Word#
68
69 -- | Count of 'GmpLimb's, must be positive (unless specified otherwise).
70 type GmpSize = Int -- actually, a 'CLong'
71 type GmpSize# = Int#
72
73 narrowGmpSize# :: Int# -> Int#
74 #if SIZEOF_LONG == SIZEOF_HSWORD
75 narrowGmpSize# x = x
76 #elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8)
77 -- On IL32P64 (i.e. Win64), we have to be careful with CLong not being
78 -- 64bit. This is mostly an issue on values returned from C functions
79 -- due to sign-extension.
80 narrowGmpSize# = narrow32Int#
81 #endif
82
83
84 type GmpBitCnt = Word -- actually, 'CULong'
85 type GmpBitCnt# = Word# -- actually, 'CULong'
86
87 -- Pseudo FFI CType
88 type CInt = Int
89 type CInt# = Int#
90
91 narrowCInt# :: Int# -> Int#
92 narrowCInt# = narrow32Int#
93
94 -- | Bits in a 'GmpLimb'. Same as @WORD_SIZE_IN_BITS@.
95 gmpLimbBits :: Word -- 8 `shiftL` gmpLimbShift
96 gmpLimbBits = W# WORD_SIZE_IN_BITS##
97
98 #if WORD_SIZE_IN_BITS == 64
99 # define GMP_LIMB_SHIFT 3
100 # define GMP_LIMB_BYTES 8
101 # define GMP_LIMB_BITS 64
102 # define INT_MINBOUND -0x8000000000000000
103 # define INT_MAXBOUND 0x7fffffffffffffff
104 # define ABS_INT_MINBOUND 0x8000000000000000
105 # define SQRT_INT_MAXBOUND 0xb504f333
106 #elif WORD_SIZE_IN_BITS == 32
107 # define GMP_LIMB_SHIFT 2
108 # define GMP_LIMB_BYTES 4
109 # define GMP_LIMB_BITS 32
110 # define INT_MINBOUND -0x80000000
111 # define INT_MAXBOUND 0x7fffffff
112 # define ABS_INT_MINBOUND 0x80000000
113 # define SQRT_INT_MAXBOUND 0xb504
114 #else
115 # error unsupported WORD_SIZE_IN_BITS config
116 #endif
117
118 -- | Type representing /raw/ arbitrary-precision Naturals
119 --
120 -- This is common type used by 'Natural' and 'Integer'. As this type
121 -- consists of a single constructor wrapping a 'ByteArray#' it can be
122 -- unpacked.
123 --
124 -- Essential invariants:
125 --
126 -- - 'ByteArray#' size is an exact multiple of 'Word#' size
127 -- - limbs are stored in least-significant-limb-first order,
128 -- - the most-significant limb must be non-zero, except for
129 -- - @0@ which is represented as a 1-limb.
130 data BigNat = BN# ByteArray#
131
132 instance Eq BigNat where
133 (==) = eqBigNat
134
135 instance Ord BigNat where
136 compare = compareBigNat
137
138 -- | Invariant: 'Jn#' and 'Jp#' are used iff value doesn't fit in 'S#'
139 --
140 -- Useful properties resulting from the invariants:
141 --
142 -- - @abs ('S#' _) <= abs ('Jp#' _)@
143 -- - @abs ('S#' _) < abs ('Jn#' _)@
144 --
145 data Integer = S# !Int#
146 -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range
147 | Jp# {-# UNPACK #-} !BigNat
148 -- ^ iff value in @]maxBound::'Int', +inf[@ range
149 | Jn# {-# UNPACK #-} !BigNat
150 -- ^ iff value in @]-inf, minBound::'Int'[@ range
151
152 -- TODO: experiment with different constructor-ordering
153
154 instance Eq Integer where
155 (==) = eqInteger
156 (/=) = neqInteger
157
158 instance Ord Integer where
159 compare = compareInteger
160 (>) = gtInteger
161 (>=) = geInteger
162 (<) = ltInteger
163 (<=) = leInteger
164
165 ----------------------------------------------------------------------------
166
167 -- | Construct 'Integer' value from list of 'Int's.
168 --
169 -- This function is used by GHC for constructing 'Integer' literals.
170 mkInteger :: Bool -- ^ sign of integer ('True' if non-negative)
171 -> [Int] -- ^ absolute value expressed in 31 bit chunks, least
172 -- significant first (ideally these would be machine-word
173 -- 'Word's rather than 31-bit truncated 'Int's)
174 -> Integer
175 mkInteger nonNegative is
176 | nonNegative = f is
177 | True = negateInteger (f is)
178 where
179 f [] = S# 0#
180 f (I# i : is') = smallInteger (i `andI#` 0x7fffffff#) `orInteger`
181 shiftLInteger (f is') 31#
182 {-# CONSTANT_FOLDED mkInteger #-}
183
184 -- | Test whether all internal invariants are satisfied by 'Integer' value
185 --
186 -- Returns @1#@ if valid, @0#@ otherwise.
187 --
188 -- This operation is mostly useful for test-suites and/or code which
189 -- constructs 'Integer' values directly.
190 isValidInteger# :: Integer -> Int#
191 isValidInteger# (S# _) = 1#
192 isValidInteger# (Jp# bn)
193 = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` INT_MAXBOUND##)
194 isValidInteger# (Jn# bn)
195 = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` ABS_INT_MINBOUND##)
196
197 -- | Should rather be called @intToInteger@
198 smallInteger :: Int# -> Integer
199 smallInteger i# = S# i#
200 {-# CONSTANT_FOLDED smallInteger #-}
201
202 ----------------------------------------------------------------------------
203 -- Int64/Word64 specific primitives
204
205 #if WORD_SIZE_IN_BITS < 64
206 int64ToInteger :: Int64# -> Integer
207 int64ToInteger i
208 | isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#)
209 , isTrue# (i `geInt64#` intToInt64# -0x80000000#)
210 = S# (int64ToInt# i)
211 | isTrue# (i `geInt64#` intToInt64# 0#)
212 = Jp# (word64ToBigNat (int64ToWord64# i))
213 | True
214 = Jn# (word64ToBigNat (int64ToWord64# (negateInt64# i)))
215 {-# CONSTANT_FOLDED int64ToInteger #-}
216
217 word64ToInteger :: Word64# -> Integer
218 word64ToInteger w
219 | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##)
220 = S# (int64ToInt# (word64ToInt64# w))
221 | True
222 = Jp# (word64ToBigNat w)
223 {-# CONSTANT_FOLDED word64ToInteger #-}
224
225 integerToInt64 :: Integer -> Int64#
226 integerToInt64 (S# i#) = intToInt64# i#
227 integerToInt64 (Jp# bn) = word64ToInt64# (bigNatToWord64 bn)
228 integerToInt64 (Jn# bn) = negateInt64# (word64ToInt64# (bigNatToWord64 bn))
229 {-# CONSTANT_FOLDED integerToInt64 #-}
230
231 integerToWord64 :: Integer -> Word64#
232 integerToWord64 (S# i#) = int64ToWord64# (intToInt64# i#)
233 integerToWord64 (Jp# bn) = bigNatToWord64 bn
234 integerToWord64 (Jn# bn)
235 = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64 bn)))
236 {-# CONSTANT_FOLDED integerToWord64 #-}
237
238 #if GMP_LIMB_BITS == 32
239 word64ToBigNat :: Word64# -> BigNat
240 word64ToBigNat w64 = wordToBigNat2 wh# wl#
241 where
242 wh# = word64ToWord# (uncheckedShiftRL64# w64 32#)
243 wl# = word64ToWord# w64
244
245 bigNatToWord64 :: BigNat -> Word64#
246 bigNatToWord64 bn
247 | isTrue# (sizeofBigNat# bn ># 1#)
248 = let wh# = wordToWord64# (indexBigNat# bn 1#)
249 in uncheckedShiftL64# wh# 32# `or64#` wl#
250 | True = wl#
251 where
252 wl# = wordToWord64# (bigNatToWord bn)
253 #endif
254 #endif
255
256 -- End of Int64/Word64 specific primitives
257 ----------------------------------------------------------------------------
258
259 -- | Truncates 'Integer' to least-significant 'Int#'
260 integerToInt :: Integer -> Int#
261 integerToInt (S# i#) = i#
262 integerToInt (Jp# bn) = bigNatToInt bn
263 integerToInt (Jn# bn) = negateInt# (bigNatToInt bn)
264 {-# CONSTANT_FOLDED integerToInt #-}
265
266 hashInteger :: Integer -> Int#
267 hashInteger = integerToInt -- emulating what integer-{simple,gmp} already do
268
269 integerToWord :: Integer -> Word#
270 integerToWord (S# i#) = int2Word# i#
271 integerToWord (Jp# bn) = bigNatToWord bn
272 integerToWord (Jn# bn) = int2Word# (negateInt# (bigNatToInt bn))
273 {-# CONSTANT_FOLDED integerToWord #-}
274
275 wordToInteger :: Word# -> Integer
276 wordToInteger w#
277 | isTrue# (i# >=# 0#) = S# i#
278 | True = Jp# (wordToBigNat w#)
279 where
280 i# = word2Int# w#
281 {-# CONSTANT_FOLDED wordToInteger #-}
282
283 wordToNegInteger :: Word# -> Integer
284 wordToNegInteger w#
285 | isTrue# (i# <=# 0#) = S# i#
286 | True = Jn# (wordToBigNat w#)
287 where
288 i# = negateInt# (word2Int# w#)
289
290 -- we could almost auto-derive Ord if it wasn't for the Jn#-Jn# case
291 compareInteger :: Integer -> Integer -> Ordering
292 compareInteger (Jn# x) (Jn# y) = compareBigNat y x
293 compareInteger (S# x) (S# y) = compareInt# x y
294 compareInteger (Jp# x) (Jp# y) = compareBigNat x y
295 compareInteger (Jn# _) _ = LT
296 compareInteger (S# _) (Jp# _) = LT
297 compareInteger (S# _) (Jn# _) = GT
298 compareInteger (Jp# _) _ = GT
299 {-# CONSTANT_FOLDED compareInteger #-}
300
301 isNegInteger# :: Integer -> Int#
302 isNegInteger# (S# i#) = i# <# 0#
303 isNegInteger# (Jp# _) = 0#
304 isNegInteger# (Jn# _) = 1#
305
306 -- | Not-equal predicate.
307 neqInteger :: Integer -> Integer -> Bool
308 neqInteger x y = isTrue# (neqInteger# x y)
309
310 eqInteger, leInteger, ltInteger, gtInteger, geInteger
311 :: Integer -> Integer -> Bool
312 eqInteger x y = isTrue# (eqInteger# x y)
313 leInteger x y = isTrue# (leInteger# x y)
314 ltInteger x y = isTrue# (ltInteger# x y)
315 gtInteger x y = isTrue# (gtInteger# x y)
316 geInteger x y = isTrue# (geInteger# x y)
317
318 eqInteger#, neqInteger#, leInteger#, ltInteger#, gtInteger#, geInteger#
319 :: Integer -> Integer -> Int#
320 eqInteger# (S# x#) (S# y#) = x# ==# y#
321 eqInteger# (Jn# x) (Jn# y) = eqBigNat# x y
322 eqInteger# (Jp# x) (Jp# y) = eqBigNat# x y
323 eqInteger# _ _ = 0#
324 {-# CONSTANT_FOLDED eqInteger# #-}
325
326 neqInteger# (S# x#) (S# y#) = x# /=# y#
327 neqInteger# (Jn# x) (Jn# y) = neqBigNat# x y
328 neqInteger# (Jp# x) (Jp# y) = neqBigNat# x y
329 neqInteger# _ _ = 1#
330 {-# CONSTANT_FOLDED neqInteger# #-}
331
332
333 gtInteger# (S# x#) (S# y#) = x# ># y#
334 gtInteger# x y | inline compareInteger x y == GT = 1#
335 gtInteger# _ _ = 0#
336 {-# CONSTANT_FOLDED gtInteger# #-}
337
338 leInteger# (S# x#) (S# y#) = x# <=# y#
339 leInteger# x y | inline compareInteger x y /= GT = 1#
340 leInteger# _ _ = 0#
341 {-# CONSTANT_FOLDED leInteger# #-}
342
343 ltInteger# (S# x#) (S# y#) = x# <# y#
344 ltInteger# x y | inline compareInteger x y == LT = 1#
345 ltInteger# _ _ = 0#
346 {-# CONSTANT_FOLDED ltInteger# #-}
347
348 geInteger# (S# x#) (S# y#) = x# >=# y#
349 geInteger# x y | inline compareInteger x y /= LT = 1#
350 geInteger# _ _ = 0#
351 {-# CONSTANT_FOLDED geInteger# #-}
352
353 -- | Compute absolute value of an 'Integer'
354 absInteger :: Integer -> Integer
355 absInteger (Jn# n) = Jp# n
356 absInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##)
357 absInteger (S# i#) | isTrue# (i# <# 0#) = S# (negateInt# i#)
358 absInteger i@(S# _) = i
359 absInteger i@(Jp# _) = i
360 {-# CONSTANT_FOLDED absInteger #-}
361
362 -- | Return @-1@, @0@, and @1@ depending on whether argument is
363 -- negative, zero, or positive, respectively
364 signumInteger :: Integer -> Integer
365 signumInteger j = S# (signumInteger# j)
366 {-# CONSTANT_FOLDED signumInteger #-}
367
368 -- | Return @-1#@, @0#@, and @1#@ depending on whether argument is
369 -- negative, zero, or positive, respectively
370 signumInteger# :: Integer -> Int#
371 signumInteger# (Jn# _) = -1#
372 signumInteger# (S# i#) = sgnI# i#
373 signumInteger# (Jp# _ ) = 1#
374
375 -- | Negate 'Integer'
376 negateInteger :: Integer -> Integer
377 negateInteger (Jn# n) = Jp# n
378 negateInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##)
379 negateInteger (S# i#) = S# (negateInt# i#)
380 negateInteger (Jp# bn)
381 | isTrue# (eqBigNatWord# bn ABS_INT_MINBOUND##) = S# INT_MINBOUND#
382 | True = Jn# bn
383 {-# CONSTANT_FOLDED negateInteger #-}
384
385 -- one edge-case issue to take into account is that Int's range is not
386 -- symmetric around 0. I.e. @minBound+maxBound = -1@
387 --
388 -- Jp# is used iff n > maxBound::Int
389 -- Jn# is used iff n < minBound::Int
390
391 -- | Add two 'Integer's
392 plusInteger :: Integer -> Integer -> Integer
393 plusInteger x (S# 0#) = x
394 plusInteger (S# 0#) y = y
395 plusInteger (S# x#) (S# y#)
396 = case addIntC# x# y# of
397 (# z#, 0# #) -> S# z#
398 (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) -- 2*minBound::Int
399 (# z#, _ #)
400 | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#))))
401 | True -> Jp# (wordToBigNat ( (int2Word# z#)))
402 plusInteger y@(S# _) x = plusInteger x y
403 -- no S# as first arg from here on
404 plusInteger (Jp# x) (Jp# y) = Jp# (plusBigNat x y)
405 plusInteger (Jn# x) (Jn# y) = Jn# (plusBigNat x y)
406 plusInteger (Jp# x) (S# y#) -- edge-case: @(maxBound+1) + minBound == 0@
407 | isTrue# (y# >=# 0#) = Jp# (plusBigNatWord x (int2Word# y#))
408 | True = bigNatToInteger (minusBigNatWord x (int2Word#
409 (negateInt# y#)))
410 plusInteger (Jn# x) (S# y#) -- edge-case: @(minBound-1) + maxBound == -2@
411 | isTrue# (y# >=# 0#) = bigNatToNegInteger (minusBigNatWord x (int2Word# y#))
412 | True = Jn# (plusBigNatWord x (int2Word# (negateInt# y#)))
413 plusInteger y@(Jn# _) x@(Jp# _) = plusInteger x y
414 plusInteger (Jp# x) (Jn# y)
415 = case compareBigNat x y of
416 LT -> bigNatToNegInteger (minusBigNat y x)
417 EQ -> S# 0#
418 GT -> bigNatToInteger (minusBigNat x y)
419 {-# CONSTANT_FOLDED plusInteger #-}
420
421 -- TODO
422 -- | Subtract two 'Integer's from each other.
423 minusInteger :: Integer -> Integer -> Integer
424 minusInteger x y = inline plusInteger x (inline negateInteger y)
425 {-# CONSTANT_FOLDED minusInteger #-}
426
427 -- | Multiply two 'Integer's
428 timesInteger :: Integer -> Integer -> Integer
429 timesInteger _ (S# 0#) = S# 0#
430 timesInteger (S# 0#) _ = S# 0#
431 timesInteger x (S# 1#) = x
432 timesInteger (S# 1#) y = y
433 timesInteger x (S# -1#) = negateInteger x
434 timesInteger (S# -1#) y = negateInteger y
435 timesInteger (S# x#) (S# y#)
436 = case mulIntMayOflo# x# y# of
437 0# -> S# (x# *# y#)
438 _ -> timesInt2Integer x# y#
439 timesInteger x@(S# _) y = timesInteger y x
440 -- no S# as first arg from here on
441 timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y)
442 timesInteger (Jp# x) (Jn# y) = Jn# (timesBigNat x y)
443 timesInteger (Jp# x) (S# y#)
444 | isTrue# (y# >=# 0#) = Jp# (timesBigNatWord x (int2Word# y#))
445 | True = Jn# (timesBigNatWord x (int2Word# (negateInt# y#)))
446 timesInteger (Jn# x) (Jn# y) = Jp# (timesBigNat x y)
447 timesInteger (Jn# x) (Jp# y) = Jn# (timesBigNat x y)
448 timesInteger (Jn# x) (S# y#)
449 | isTrue# (y# >=# 0#) = Jn# (timesBigNatWord x (int2Word# y#))
450 | True = Jp# (timesBigNatWord x (int2Word# (negateInt# y#)))
451 {-# CONSTANT_FOLDED timesInteger #-}
452
453 -- | Square 'Integer'
454 sqrInteger :: Integer -> Integer
455 sqrInteger (S# INT_MINBOUND#) = timesInt2Integer INT_MINBOUND# INT_MINBOUND#
456 sqrInteger (S# j#) | isTrue# (absI# j# <=# SQRT_INT_MAXBOUND#) = S# (j# *# j#)
457 sqrInteger (S# j#) = timesInt2Integer j# j#
458 sqrInteger (Jp# bn) = Jp# (sqrBigNat bn)
459 sqrInteger (Jn# bn) = Jp# (sqrBigNat bn)
460
461 -- | Construct 'Integer' from the product of two 'Int#'s
462 timesInt2Integer :: Int# -> Int# -> Integer
463 timesInt2Integer x# y# = case (# x# >=# 0#, y# >=# 0# #) of
464 (# 0#, 0# #) -> case timesWord2# (int2Word# (negateInt# x#))
465 (int2Word# (negateInt# y#)) of
466 (# 0##,l #) -> inline wordToInteger l
467 (# h ,l #) -> Jp# (wordToBigNat2 h l)
468
469 (# _, 0# #) -> case timesWord2# (int2Word# x#)
470 (int2Word# (negateInt# y#)) of
471 (# 0##,l #) -> wordToNegInteger l
472 (# h ,l #) -> Jn# (wordToBigNat2 h l)
473
474 (# 0#, _ #) -> case timesWord2# (int2Word# (negateInt# x#))
475 (int2Word# y#) of
476 (# 0##,l #) -> wordToNegInteger l
477 (# h ,l #) -> Jn# (wordToBigNat2 h l)
478
479 (# _, _ #) -> case timesWord2# (int2Word# x#)
480 (int2Word# y#) of
481 (# 0##,l #) -> inline wordToInteger l
482 (# h ,l #) -> Jp# (wordToBigNat2 h l)
483
484 bigNatToInteger :: BigNat -> Integer
485 bigNatToInteger bn
486 | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# >=# 0#)) = S# i#
487 | True = Jp# bn
488 where
489 i# = word2Int# (bigNatToWord bn)
490
491 bigNatToNegInteger :: BigNat -> Integer
492 bigNatToNegInteger bn
493 | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# <=# 0#)) = S# i#
494 | True = Jn# bn
495 where
496 i# = negateInt# (word2Int# (bigNatToWord bn))
497
498 -- | Count number of set bits. For negative arguments returns negative
499 -- population count of negated argument.
500 popCountInteger :: Integer -> Int#
501 popCountInteger (S# i#)
502 | isTrue# (i# >=# 0#) = popCntI# i#
503 | True = negateInt# (popCntI# (negateInt# i#))
504 popCountInteger (Jp# bn) = popCountBigNat bn
505 popCountInteger (Jn# bn) = negateInt# (popCountBigNat bn)
506 {-# CONSTANT_FOLDED popCountInteger #-}
507
508 -- | 'Integer' for which only /n/-th bit is set. Undefined behaviour
509 -- for negative /n/ values.
510 bitInteger :: Int# -> Integer
511 bitInteger i#
512 | isTrue# (i# <# (GMP_LIMB_BITS# -# 1#)) = S# (uncheckedIShiftL# 1# i#)
513 | True = Jp# (bitBigNat i#)
514 {-# CONSTANT_FOLDED bitInteger #-}
515
516 -- | Test if /n/-th bit is set.
517 testBitInteger :: Integer -> Int# -> Bool
518 testBitInteger _ n# | isTrue# (n# <# 0#) = False
519 testBitInteger (S# i#) n#
520 | isTrue# (n# <# GMP_LIMB_BITS#) = isTrue# (((uncheckedIShiftL# 1# n#)
521 `andI#` i#) /=# 0#)
522 | True = isTrue# (i# <# 0#)
523 testBitInteger (Jp# bn) n = testBitBigNat bn n
524 testBitInteger (Jn# bn) n = testBitNegBigNat bn n
525 {-# CONSTANT_FOLDED testBitInteger #-}
526
527 -- | Bitwise @NOT@ operation
528 complementInteger :: Integer -> Integer
529 complementInteger (S# i#) = S# (notI# i#)
530 complementInteger (Jp# bn) = Jn# (plusBigNatWord bn 1##)
531 complementInteger (Jn# bn) = Jp# (minusBigNatWord bn 1##)
532 {-# CONSTANT_FOLDED complementInteger #-}
533
534 -- | Arithmetic shift-right operation
535 --
536 -- Even though the shift-amount is expressed as `Int#`, the result is
537 -- undefined for negative shift-amounts.
538 shiftRInteger :: Integer -> Int# -> Integer
539 shiftRInteger x 0# = x
540 shiftRInteger (S# i#) n# = S# (iShiftRA# i# n#)
541 where
542 iShiftRA# a b
543 | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#)
544 | True = a `uncheckedIShiftRA#` b
545 shiftRInteger (Jp# bn) n# = bigNatToInteger (shiftRBigNat bn n#)
546 shiftRInteger (Jn# bn) n#
547 = case bigNatToNegInteger (shiftRNegBigNat bn n#) of
548 S# 0# -> S# -1#
549 r -> r
550 {-# CONSTANT_FOLDED shiftRInteger #-}
551
552 -- | Shift-left operation
553 --
554 -- Even though the shift-amount is expressed as `Int#`, the result is
555 -- undefined for negative shift-amounts.
556 shiftLInteger :: Integer -> Int# -> Integer
557 shiftLInteger x 0# = x
558 shiftLInteger (S# 0#) _ = S# 0#
559 shiftLInteger (S# 1#) n# = bitInteger n#
560 shiftLInteger (S# i#) n#
561 | isTrue# (i# >=# 0#) = bigNatToInteger (shiftLBigNat
562 (wordToBigNat (int2Word# i#)) n#)
563 | True = bigNatToNegInteger (shiftLBigNat
564 (wordToBigNat (int2Word#
565 (negateInt# i#))) n#)
566 shiftLInteger (Jp# bn) n# = Jp# (shiftLBigNat bn n#)
567 shiftLInteger (Jn# bn) n# = Jn# (shiftLBigNat bn n#)
568 {-# CONSTANT_FOLDED shiftLInteger #-}
569
570 -- | Bitwise OR operation
571 orInteger :: Integer -> Integer -> Integer
572 -- short-cuts
573 orInteger (S# 0#) y = y
574 orInteger x (S# 0#) = x
575 orInteger (S# -1#) _ = S# -1#
576 orInteger _ (S# -1#) = S# -1#
577 -- base-cases
578 orInteger (S# x#) (S# y#) = S# (orI# x# y#)
579 orInteger (Jp# x) (Jp# y) = Jp# (orBigNat x y)
580 orInteger (Jn# x) (Jn# y)
581 = bigNatToNegInteger (plusBigNatWord (andBigNat
582 (minusBigNatWord x 1##)
583 (minusBigNatWord y 1##)) 1##)
584 orInteger x@(Jn# _) y@(Jp# _) = orInteger y x -- retry with swapped args
585 orInteger (Jp# x) (Jn# y)
586 = bigNatToNegInteger (plusBigNatWord (andnBigNat (minusBigNatWord y 1##) x)
587 1##)
588 -- TODO/FIXpromotion-hack
589 orInteger x@(S# _) y = orInteger (unsafePromote x) y
590 orInteger x y {- S# -}= orInteger x (unsafePromote y)
591 {-# CONSTANT_FOLDED orInteger #-}
592
593 -- | Bitwise XOR operation
594 xorInteger :: Integer -> Integer -> Integer
595 -- short-cuts
596 xorInteger (S# 0#) y = y
597 xorInteger x (S# 0#) = x
598 -- TODO: (S# -1) cases
599 -- base-cases
600 xorInteger (S# x#) (S# y#) = S# (xorI# x# y#)
601 xorInteger (Jp# x) (Jp# y) = bigNatToInteger (xorBigNat x y)
602 xorInteger (Jn# x) (Jn# y)
603 = bigNatToInteger (xorBigNat (minusBigNatWord x 1##)
604 (minusBigNatWord y 1##))
605 xorInteger x@(Jn# _) y@(Jp# _) = xorInteger y x -- retry with swapped args
606 xorInteger (Jp# x) (Jn# y)
607 = bigNatToNegInteger (plusBigNatWord (xorBigNat x (minusBigNatWord y 1##))
608 1##)
609 -- TODO/FIXME promotion-hack
610 xorInteger x@(S# _) y = xorInteger (unsafePromote x) y
611 xorInteger x y {- S# -} = xorInteger x (unsafePromote y)
612 {-# CONSTANT_FOLDED xorInteger #-}
613
614 -- | Bitwise AND operation
615 andInteger :: Integer -> Integer -> Integer
616 -- short-cuts
617 andInteger (S# 0#) _ = S# 0#
618 andInteger _ (S# 0#) = S# 0#
619 andInteger (S# -1#) y = y
620 andInteger x (S# -1#) = x
621 -- base-cases
622 andInteger (S# x#) (S# y#) = S# (andI# x# y#)
623 andInteger (Jp# x) (Jp# y) = bigNatToInteger (andBigNat x y)
624 andInteger (Jn# x) (Jn# y)
625 = bigNatToNegInteger (plusBigNatWord (orBigNat (minusBigNatWord x 1##)
626 (minusBigNatWord y 1##)) 1##)
627 andInteger x@(Jn# _) y@(Jp# _) = andInteger y x
628 andInteger (Jp# x) (Jn# y)
629 = bigNatToInteger (andnBigNat x (minusBigNatWord y 1##))
630 -- TODO/FIXME promotion-hack
631 andInteger x@(S# _) y = andInteger (unsafePromote x) y
632 andInteger x y {- S# -}= andInteger x (unsafePromote y)
633 {-# CONSTANT_FOLDED andInteger #-}
634
635 -- HACK warning! breaks invariant on purpose
636 unsafePromote :: Integer -> Integer
637 unsafePromote (S# x#)
638 | isTrue# (x# >=# 0#) = Jp# (wordToBigNat (int2Word# x#))
639 | True = Jn# (wordToBigNat (int2Word# (negateInt# x#)))
640 unsafePromote x = x
641
642 -- | Simultaneous 'quotInteger' and 'remInteger'.
643 --
644 -- Divisor must be non-zero otherwise the GHC runtime will terminate
645 -- with a division-by-zero fault.
646 quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)
647 quotRemInteger n (S# 1#) = (# n, S# 0# #)
648 quotRemInteger n (S# -1#) = let !q = negateInteger n in (# q, (S# 0#) #)
649 quotRemInteger _ (S# 0#) = (# S# (quotInt# 0# 0#),S# (remInt# 0# 0#) #)
650 quotRemInteger (S# 0#) _ = (# S# 0#, S# 0# #)
651 quotRemInteger (S# n#) (S# d#) = case quotRemInt# n# d# of
652 (# q#, r# #) -> (# S# q#, S# r# #)
653 quotRemInteger (Jp# n) (Jp# d) = case quotRemBigNat n d of
654 (# q, r #) -> (# bigNatToInteger q, bigNatToInteger r #)
655 quotRemInteger (Jp# n) (Jn# d) = case quotRemBigNat n d of
656 (# q, r #) -> (# bigNatToNegInteger q, bigNatToInteger r #)
657 quotRemInteger (Jn# n) (Jn# d) = case quotRemBigNat n d of
658 (# q, r #) -> (# bigNatToInteger q, bigNatToNegInteger r #)
659 quotRemInteger (Jn# n) (Jp# d) = case quotRemBigNat n d of
660 (# q, r #) -> (# bigNatToNegInteger q, bigNatToNegInteger r #)
661 quotRemInteger (Jp# n) (S# d#)
662 | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of
663 (# q, r# #) -> (# bigNatToInteger q, inline wordToInteger r# #)
664 | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of
665 (# q, r# #) -> (# bigNatToNegInteger q, inline wordToInteger r# #)
666 quotRemInteger (Jn# n) (S# d#)
667 | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of
668 (# q, r# #) -> (# bigNatToNegInteger q, wordToNegInteger r# #)
669 | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of
670 (# q, r# #) -> (# bigNatToInteger q, wordToNegInteger r# #)
671 quotRemInteger n@(S# _) (Jn# _) = (# S# 0#, n #) -- since @n < d@
672 quotRemInteger n@(S# n#) (Jp# d) -- need to account for (S# minBound)
673 | isTrue# (n# ># 0#) = (# S# 0#, n #)
674 | isTrue# (gtBigNatWord# d (int2Word# (negateInt# n#))) = (# S# 0#, n #)
675 | True {- abs(n) == d -} = (# S# -1#, S# 0# #)
676 {-# CONSTANT_FOLDED quotRemInteger #-}
677
678
679 quotInteger :: Integer -> Integer -> Integer
680 quotInteger n (S# 1#) = n
681 quotInteger n (S# -1#) = negateInteger n
682 quotInteger _ (S# 0#) = S# (quotInt# 0# 0#)
683 quotInteger (S# 0#) _ = S# 0#
684 quotInteger (S# n#) (S# d#) = S# (quotInt# n# d#)
685 quotInteger (Jp# n) (S# d#)
686 | isTrue# (d# >=# 0#) = bigNatToInteger (quotBigNatWord n (int2Word# d#))
687 | True = bigNatToNegInteger (quotBigNatWord n
688 (int2Word# (negateInt# d#)))
689 quotInteger (Jn# n) (S# d#)
690 | isTrue# (d# >=# 0#) = bigNatToNegInteger (quotBigNatWord n (int2Word# d#))
691 | True = bigNatToInteger (quotBigNatWord n
692 (int2Word# (negateInt# d#)))
693 quotInteger (Jp# n) (Jp# d) = bigNatToInteger (quotBigNat n d)
694 quotInteger (Jp# n) (Jn# d) = bigNatToNegInteger (quotBigNat n d)
695 quotInteger (Jn# n) (Jp# d) = bigNatToNegInteger (quotBigNat n d)
696 quotInteger (Jn# n) (Jn# d) = bigNatToInteger (quotBigNat n d)
697 -- handle remaining non-allocating cases
698 quotInteger n d = case inline quotRemInteger n d of (# q, _ #) -> q
699 {-# CONSTANT_FOLDED quotInteger #-}
700
701 remInteger :: Integer -> Integer -> Integer
702 remInteger _ (S# 1#) = S# 0#
703 remInteger _ (S# -1#) = S# 0#
704 remInteger _ (S# 0#) = S# (remInt# 0# 0#)
705 remInteger (S# 0#) _ = S# 0#
706 remInteger (S# n#) (S# d#) = S# (remInt# n# d#)
707 remInteger (Jp# n) (S# d#)
708 = wordToInteger (remBigNatWord n (int2Word# (absI# d#)))
709 remInteger (Jn# n) (S# d#)
710 = wordToNegInteger (remBigNatWord n (int2Word# (absI# d#)))
711 remInteger (Jp# n) (Jp# d) = bigNatToInteger (remBigNat n d)
712 remInteger (Jp# n) (Jn# d) = bigNatToInteger (remBigNat n d)
713 remInteger (Jn# n) (Jp# d) = bigNatToNegInteger (remBigNat n d)
714 remInteger (Jn# n) (Jn# d) = bigNatToNegInteger (remBigNat n d)
715 -- handle remaining non-allocating cases
716 remInteger n d = case inline quotRemInteger n d of (# _, r #) -> r
717 {-# CONSTANT_FOLDED remInteger #-}
718
719 -- | Simultaneous 'divInteger' and 'modInteger'.
720 --
721 -- Divisor must be non-zero otherwise the GHC runtime will terminate
722 -- with a division-by-zero fault.
723 divModInteger :: Integer -> Integer -> (# Integer, Integer #)
724 divModInteger n d
725 | isTrue# (signumInteger# r ==# negateInt# (signumInteger# d))
726 = let !q' = plusInteger q (S# -1#) -- TODO: optimize
727 !r' = plusInteger r d
728 in (# q', r' #)
729 | True = qr
730 where
731 qr@(# q, r #) = quotRemInteger n d
732 {-# CONSTANT_FOLDED divModInteger #-}
733
734 divInteger :: Integer -> Integer -> Integer
735 -- same-sign ops can be handled by more efficient 'quotInteger'
736 divInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = quotInteger n d
737 divInteger n d = case inline divModInteger n d of (# q, _ #) -> q
738 {-# CONSTANT_FOLDED divInteger #-}
739
740 modInteger :: Integer -> Integer -> Integer
741 -- same-sign ops can be handled by more efficient 'remInteger'
742 modInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = remInteger n d
743 modInteger n d = case inline divModInteger n d of (# _, r #) -> r
744 {-# CONSTANT_FOLDED modInteger #-}
745
746 -- | Compute greatest common divisor.
747 gcdInteger :: Integer -> Integer -> Integer
748 gcdInteger (S# 0#) b = absInteger b
749 gcdInteger a (S# 0#) = absInteger a
750 gcdInteger (S# 1#) _ = S# 1#
751 gcdInteger (S# -1#) _ = S# 1#
752 gcdInteger _ (S# 1#) = S# 1#
753 gcdInteger _ (S# -1#) = S# 1#
754 gcdInteger (S# a#) (S# b#)
755 = wordToInteger (gcdWord# (int2Word# (absI# a#)) (int2Word# (absI# b#)))
756 gcdInteger a@(S# _) b = gcdInteger b a
757 gcdInteger (Jn# a) b = gcdInteger (Jp# a) b
758 gcdInteger (Jp# a) (Jp# b) = bigNatToInteger (gcdBigNat a b)
759 gcdInteger (Jp# a) (Jn# b) = bigNatToInteger (gcdBigNat a b)
760 gcdInteger (Jp# a) (S# b#)
761 = wordToInteger (gcdBigNatWord a (int2Word# (absI# b#)))
762 {-# CONSTANT_FOLDED gcdInteger #-}
763
764 -- | Compute least common multiple.
765 lcmInteger :: Integer -> Integer -> Integer
766 lcmInteger (S# 0#) _ = S# 0#
767 lcmInteger (S# 1#) b = absInteger b
768 lcmInteger (S# -1#) b = absInteger b
769 lcmInteger _ (S# 0#) = S# 0#
770 lcmInteger a (S# 1#) = absInteger a
771 lcmInteger a (S# -1#) = absInteger a
772 lcmInteger a b = (aa `quotInteger` (aa `gcdInteger` ab)) `timesInteger` ab
773 where
774 aa = absInteger a
775 ab = absInteger b
776 {-# CONSTANT_FOLDED lcmInteger #-}
777
778 -- | Compute greatest common divisor.
779 --
780 -- __Warning__: result may become negative if (at least) one argument
781 -- is 'minBound'
782 gcdInt :: Int# -> Int# -> Int#
783 gcdInt x# y#
784 = word2Int# (gcdWord# (int2Word# (absI# x#)) (int2Word# (absI# y#)))
785
786 -- | Compute greatest common divisor.
787 --
788 -- /Since: 1.0.0.0/
789 gcdWord :: Word# -> Word# -> Word#
790 gcdWord = gcdWord#
791
792 ----------------------------------------------------------------------------
793 -- BigNat operations
794
795 compareBigNat :: BigNat -> BigNat -> Ordering
796 compareBigNat x@(BN# x#) y@(BN# y#)
797 | isTrue# (nx# ==# ny#)
798 = compareInt# (narrowCInt# (c_mpn_cmp x# y# nx#)) 0#
799 | isTrue# (nx# <# ny#) = LT
800 | True = GT
801 where
802 nx# = sizeofBigNat# x
803 ny# = sizeofBigNat# y
804
805 compareBigNatWord :: BigNat -> GmpLimb# -> Ordering
806 compareBigNatWord bn w#
807 | isTrue# (sizeofBigNat# bn ==# 1#) = cmpW# (bigNatToWord bn) w#
808 | True = GT
809
810 gtBigNatWord# :: BigNat -> GmpLimb# -> Int#
811 gtBigNatWord# bn w#
812 = (sizeofBigNat# bn ># 1#) `orI#` (bigNatToWord bn `gtWord#` w#)
813
814 eqBigNat :: BigNat -> BigNat -> Bool
815 eqBigNat x y = isTrue# (eqBigNat# x y)
816
817 eqBigNat# :: BigNat -> BigNat -> Int#
818 eqBigNat# x@(BN# x#) y@(BN# y#)
819 | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# ==# 0#
820 | True = 0#
821 where
822 nx# = sizeofBigNat# x
823 ny# = sizeofBigNat# y
824
825 neqBigNat# :: BigNat -> BigNat -> Int#
826 neqBigNat# x@(BN# x#) y@(BN# y#)
827 | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# /=# 0#
828 | True = 1#
829 where
830 nx# = sizeofBigNat# x
831 ny# = sizeofBigNat# y
832
833 eqBigNatWord :: BigNat -> GmpLimb# -> Bool
834 eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#)
835
836 eqBigNatWord# :: BigNat -> GmpLimb# -> Int#
837 eqBigNatWord# bn w#
838 = sizeofBigNat# bn ==# 1# `andI#` (bigNatToWord bn `eqWord#` w#)
839
840
841 -- | Same as @'indexBigNat#' bn 0\#@
842 bigNatToWord :: BigNat -> Word#
843 bigNatToWord bn = indexBigNat# bn 0#
844
845 -- | Equivalent to @'word2Int#' . 'bigNatToWord'@
846 bigNatToInt :: BigNat -> Int#
847 bigNatToInt (BN# ba#) = indexIntArray# ba# 0#
848
849 -- | CAF representing the value @0 :: BigNat@
850 zeroBigNat :: BigNat
851 zeroBigNat = runS $ do
852 mbn <- newBigNat# 1#
853 _ <- svoid (writeBigNat# mbn 0# 0##)
854 unsafeFreezeBigNat# mbn
855 {-# NOINLINE zeroBigNat #-}
856
857 -- | Test if 'BigNat' value is equal to zero.
858 isZeroBigNat :: BigNat -> Bool
859 isZeroBigNat bn = eqBigNatWord bn 0##
860
861 -- | CAF representing the value @1 :: BigNat@
862 oneBigNat :: BigNat
863 oneBigNat = runS $ do
864 mbn <- newBigNat# 1#
865 _ <- svoid (writeBigNat# mbn 0# 1##)
866 unsafeFreezeBigNat# mbn
867 {-# NOINLINE oneBigNat #-}
868
869 czeroBigNat :: BigNat
870 czeroBigNat = runS $ do
871 mbn <- newBigNat# 1#
872 _ <- svoid (writeBigNat# mbn 0# (not# 0##))
873 unsafeFreezeBigNat# mbn
874 {-# NOINLINE czeroBigNat #-}
875
876 -- | Special 0-sized bigNat returned in case of arithmetic underflow
877 --
878 -- This is currently only returned by the following operations:
879 --
880 -- - 'minusBigNat'
881 -- - 'minusBigNatWord'
882 --
883 -- Other operations such as 'quotBigNat' may return 'nullBigNat' as
884 -- well as a dummy/place-holder value instead of 'undefined' since we
885 -- can't throw exceptions. But that behaviour should not be relied
886 -- upon.
887 --
888 -- NB: @isValidBigNat# nullBigNat@ is false
889 nullBigNat :: BigNat
890 nullBigNat = runS (newBigNat# 0# >>= unsafeFreezeBigNat#)
891 {-# NOINLINE nullBigNat #-}
892
893 -- | Test for special 0-sized 'BigNat' representing underflows.
894 isNullBigNat# :: BigNat -> Int#
895 isNullBigNat# (BN# ba#) = sizeofByteArray# ba# ==# 0#
896
897 -- | Construct 1-limb 'BigNat' from 'Word#'
898 wordToBigNat :: Word# -> BigNat
899 wordToBigNat 0## = zeroBigNat
900 wordToBigNat 1## = oneBigNat
901 wordToBigNat w#
902 | isTrue# (not# w# `eqWord#` 0##) = czeroBigNat
903 | True = runS $ do
904 mbn <- newBigNat# 1#
905 _ <- svoid (writeBigNat# mbn 0# w#)
906 unsafeFreezeBigNat# mbn
907
908 -- | Construct BigNat from 2 limbs.
909 -- The first argument is the most-significant limb.
910 wordToBigNat2 :: Word# -> Word# -> BigNat
911 wordToBigNat2 0## lw# = wordToBigNat lw#
912 wordToBigNat2 hw# lw# = runS $ do
913 mbn <- newBigNat# 2#
914 _ <- svoid (writeBigNat# mbn 0# lw#)
915 _ <- svoid (writeBigNat# mbn 1# hw#)
916 unsafeFreezeBigNat# mbn
917
918 plusBigNat :: BigNat -> BigNat -> BigNat
919 plusBigNat x y
920 | isTrue# (eqBigNatWord# x 0##) = y
921 | isTrue# (eqBigNatWord# y 0##) = x
922 | isTrue# (nx# >=# ny#) = go x nx# y ny#
923 | True = go y ny# x nx#
924 where
925 go (BN# a#) na# (BN# b#) nb# = runS $ do
926 mbn@(MBN# mba#) <- newBigNat# na#
927 (W# c#) <- liftIO (c_mpn_add mba# a# na# b# nb#)
928 case c# of
929 0## -> unsafeFreezeBigNat# mbn
930 _ -> unsafeSnocFreezeBigNat# mbn c#
931
932 nx# = sizeofBigNat# x
933 ny# = sizeofBigNat# y
934
935 plusBigNatWord :: BigNat -> GmpLimb# -> BigNat
936 plusBigNatWord x 0## = x
937 plusBigNatWord x@(BN# x#) y# = runS $ do
938 mbn@(MBN# mba#) <- newBigNat# nx#
939 (W# c#) <- liftIO (c_mpn_add_1 mba# x# nx# y#)
940 case c# of
941 0## -> unsafeFreezeBigNat# mbn
942 _ -> unsafeSnocFreezeBigNat# mbn c#
943 where
944 nx# = sizeofBigNat# x
945
946 -- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow
947 minusBigNat :: BigNat -> BigNat -> BigNat
948 minusBigNat x@(BN# x#) y@(BN# y#)
949 | isZeroBigNat y = x
950 | isTrue# (nx# >=# ny#) = runS $ do
951 mbn@(MBN# mba#) <- newBigNat# nx#
952 (W# b#) <- liftIO (c_mpn_sub mba# x# nx# y# ny#)
953 case b# of
954 0## -> unsafeRenormFreezeBigNat# mbn
955 _ -> return nullBigNat
956
957 | True = nullBigNat
958 where
959 nx# = sizeofBigNat# x
960 ny# = sizeofBigNat# y
961
962 -- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow
963 minusBigNatWord :: BigNat -> GmpLimb# -> BigNat
964 minusBigNatWord x 0## = x
965 minusBigNatWord x@(BN# x#) y# = runS $ do
966 mbn@(MBN# mba#) <- newBigNat# nx#
967 (W# b#) <- liftIO $ c_mpn_sub_1 mba# x# nx# y#
968 case b# of
969 0## -> unsafeRenormFreezeBigNat# mbn
970 _ -> return nullBigNat
971 where
972 nx# = sizeofBigNat# x
973
974
975 timesBigNat :: BigNat -> BigNat -> BigNat
976 timesBigNat x y
977 | isZeroBigNat x = zeroBigNat
978 | isZeroBigNat y = zeroBigNat
979 | isTrue# (nx# >=# ny#) = go x nx# y ny#
980 | True = go y ny# x nx#
981 where
982 go (BN# a#) na# (BN# b#) nb# = runS $ do
983 let n# = nx# +# ny#
984 mbn@(MBN# mba#) <- newBigNat# n#
985 (W# msl#) <- liftIO (c_mpn_mul mba# a# na# b# nb#)
986 case msl# of
987 0## -> unsafeShrinkFreezeBigNat# mbn (n# -# 1#)
988 _ -> unsafeFreezeBigNat# mbn
989
990 nx# = sizeofBigNat# x
991 ny# = sizeofBigNat# y
992
993 -- | Square 'BigNat'
994 sqrBigNat :: BigNat -> BigNat
995 sqrBigNat x
996 | isZeroBigNat x = zeroBigNat
997 -- TODO: 1-limb BigNats below sqrt(maxBound::GmpLimb)
998 sqrBigNat x = timesBigNat x x -- TODO: mpn_sqr
999
1000 timesBigNatWord :: BigNat -> GmpLimb# -> BigNat
1001 timesBigNatWord _ 0## = zeroBigNat
1002 timesBigNatWord x 1## = x
1003 timesBigNatWord x@(BN# x#) y#
1004 | isTrue# (nx# ==# 1#) =
1005 let (# !h#, !l# #) = timesWord2# (bigNatToWord x) y#
1006 in wordToBigNat2 h# l#
1007 | True = runS $ do
1008 mbn@(MBN# mba#) <- newBigNat# nx#
1009 (W# msl#) <- liftIO (c_mpn_mul_1 mba# x# nx# y#)
1010 case msl# of
1011 0## -> unsafeFreezeBigNat# mbn
1012 _ -> unsafeSnocFreezeBigNat# mbn msl#
1013
1014 where
1015 nx# = sizeofBigNat# x
1016
1017 bitBigNat :: Int# -> BigNat
1018 bitBigNat i# = shiftLBigNat (wordToBigNat 1##) i# -- FIXME
1019
1020 testBitBigNat :: BigNat -> Int# -> Bool
1021 testBitBigNat bn i#
1022 | isTrue# (i# <# 0#) = False
1023 | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#)
1024 | True = False
1025 where
1026 (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS#
1027 nx# = sizeofBigNat# bn
1028
1029 testBitNegBigNat :: BigNat -> Int# -> Bool
1030 testBitNegBigNat bn i#
1031 | isTrue# (i# <# 0#) = False
1032 | isTrue# (li# >=# nx#) = True
1033 | allZ li# = isTrue# ((testBitWord#
1034 (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#)
1035 | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#)
1036 where
1037 (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS#
1038 nx# = sizeofBigNat# bn
1039
1040 allZ 0# = True
1041 allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#)
1042 | True = False
1043
1044 popCountBigNat :: BigNat -> Int#
1045 popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn))
1046
1047
1048 shiftLBigNat :: BigNat -> Int# -> BigNat
1049 shiftLBigNat x 0# = x
1050 shiftLBigNat x _ | isZeroBigNat x = zeroBigNat
1051 shiftLBigNat x@(BN# xba#) n# = runS $ do
1052 ymbn@(MBN# ymba#) <- newBigNat# yn#
1053 W# ymsl <- liftIO (c_mpn_lshift ymba# xba# xn# (int2Word# n#))
1054 case ymsl of
1055 0## -> unsafeShrinkFreezeBigNat# ymbn (yn# -# 1#)
1056 _ -> unsafeFreezeBigNat# ymbn
1057 where
1058 xn# = sizeofBigNat# x
1059 yn# = xn# +# nlimbs# +# (nbits# /=# 0#)
1060 (# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS#
1061
1062
1063
1064 shiftRBigNat :: BigNat -> Int# -> BigNat
1065 shiftRBigNat x 0# = x
1066 shiftRBigNat x _ | isZeroBigNat x = zeroBigNat
1067 shiftRBigNat x@(BN# xba#) n#
1068 | isTrue# (nlimbs# >=# xn#) = zeroBigNat
1069 | True = runS $ do
1070 ymbn@(MBN# ymba#) <- newBigNat# yn#
1071 W# ymsl <- liftIO (c_mpn_rshift ymba# xba# xn# (int2Word# n#))
1072 case ymsl of
1073 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one
1074 _ -> unsafeFreezeBigNat# ymbn
1075 where
1076 xn# = sizeofBigNat# x
1077 yn# = xn# -# nlimbs#
1078 nlimbs# = quotInt# n# GMP_LIMB_BITS#
1079
1080 shiftRNegBigNat :: BigNat -> Int# -> BigNat
1081 shiftRNegBigNat x 0# = x
1082 shiftRNegBigNat x _ | isZeroBigNat x = zeroBigNat
1083 shiftRNegBigNat x@(BN# xba#) n#
1084 | isTrue# (nlimbs# >=# xn#) = zeroBigNat
1085 | True = runS $ do
1086 ymbn@(MBN# ymba#) <- newBigNat# yn#
1087 W# ymsl <- liftIO (c_mpn_rshift_2c ymba# xba# xn# (int2Word# n#))
1088 case ymsl of
1089 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one
1090 _ -> unsafeFreezeBigNat# ymbn
1091 where
1092 xn# = sizeofBigNat# x
1093 yn# = xn# -# nlimbs#
1094 nlimbs# = quotInt# n# GMP_LIMB_BITS#
1095
1096
1097 orBigNat :: BigNat -> BigNat -> BigNat
1098 orBigNat x@(BN# x#) y@(BN# y#)
1099 | isZeroBigNat x = y
1100 | isZeroBigNat y = x
1101 | isTrue# (nx# >=# ny#) = runS (ior' x# nx# y# ny#)
1102 | True = runS (ior' y# ny# x# nx#)
1103 where
1104 ior' a# na# b# nb# = do -- na >= nb
1105 mbn@(MBN# mba#) <- newBigNat# na#
1106 _ <- liftIO (c_mpn_ior_n mba# a# b# nb#)
1107 _ <- case na# ==# nb# of
1108 0# -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#))
1109 _ -> return ()
1110 unsafeFreezeBigNat# mbn
1111
1112 nx# = sizeofBigNat# x
1113 ny# = sizeofBigNat# y
1114
1115
1116 xorBigNat :: BigNat -> BigNat -> BigNat
1117 xorBigNat x@(BN# x#) y@(BN# y#)
1118 | isZeroBigNat x = y
1119 | isZeroBigNat y = x
1120 | isTrue# (nx# >=# ny#) = runS (xor' x# nx# y# ny#)
1121 | True = runS (xor' y# ny# x# nx#)
1122 where
1123 xor' a# na# b# nb# = do -- na >= nb
1124 mbn@(MBN# mba#) <- newBigNat# na#
1125 _ <- liftIO (c_mpn_xor_n mba# a# b# nb#)
1126 case na# ==# nb# of
1127 0# -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#))
1128 unsafeFreezeBigNat# mbn
1129 _ -> unsafeRenormFreezeBigNat# mbn
1130
1131 nx# = sizeofBigNat# x
1132 ny# = sizeofBigNat# y
1133
1134 -- | aka @\x y -> x .&. (complement y)@
1135 andnBigNat :: BigNat -> BigNat -> BigNat
1136 andnBigNat x@(BN# x#) y@(BN# y#)
1137 | isZeroBigNat x = zeroBigNat
1138 | isZeroBigNat y = x
1139 | True = runS $ do
1140 mbn@(MBN# mba#) <- newBigNat# nx#
1141 _ <- liftIO (c_mpn_andn_n mba# x# y# n#)
1142 _ <- case nx# ==# n# of
1143 0# -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#))
1144 _ -> return ()
1145 unsafeRenormFreezeBigNat# mbn
1146 where
1147 n# | isTrue# (nx# <# ny#) = nx#
1148 | True = ny#
1149 nx# = sizeofBigNat# x
1150 ny# = sizeofBigNat# y
1151
1152
1153 andBigNat :: BigNat -> BigNat -> BigNat
1154 andBigNat x@(BN# x#) y@(BN# y#)
1155 | isZeroBigNat x = zeroBigNat
1156 | isZeroBigNat y = zeroBigNat
1157 | True = runS $ do
1158 mbn@(MBN# mba#) <- newBigNat# n#
1159 _ <- liftIO (c_mpn_and_n mba# x# y# n#)
1160 unsafeRenormFreezeBigNat# mbn
1161 where
1162 n# | isTrue# (nx# <# ny#) = nx#
1163 | True = ny#
1164 nx# = sizeofBigNat# x
1165 ny# = sizeofBigNat# y
1166
1167 -- | If divisor is zero, @(\# 'nullBigNat', 'nullBigNat' \#)@ is returned
1168 quotRemBigNat :: BigNat -> BigNat -> (# BigNat,BigNat #)
1169 quotRemBigNat n@(BN# nba#) d@(BN# dba#)
1170 | isZeroBigNat d = (# nullBigNat, nullBigNat #)
1171 | eqBigNatWord d 1## = (# n, zeroBigNat #)
1172 | n < d = (# zeroBigNat, n #)
1173 | True = case runS go of (!q,!r) -> (# q, r #)
1174 where
1175 nn# = sizeofBigNat# n
1176 dn# = sizeofBigNat# d
1177 qn# = 1# +# nn# -# dn#
1178 rn# = dn#
1179
1180 go = do
1181 qmbn@(MBN# qmba#) <- newBigNat# qn#
1182 rmbn@(MBN# rmba#) <- newBigNat# rn#
1183
1184 _ <- liftIO (c_mpn_tdiv_qr qmba# rmba# 0# nba# nn# dba# dn#)
1185
1186 q <- unsafeRenormFreezeBigNat# qmbn
1187 r <- unsafeRenormFreezeBigNat# rmbn
1188 return (q, r)
1189
1190 quotBigNat :: BigNat -> BigNat -> BigNat
1191 quotBigNat n@(BN# nba#) d@(BN# dba#)
1192 | isZeroBigNat d = nullBigNat
1193 | eqBigNatWord d 1## = n
1194 | n < d = zeroBigNat
1195 | True = runS $ do
1196 let nn# = sizeofBigNat# n
1197 let dn# = sizeofBigNat# d
1198 let qn# = 1# +# nn# -# dn#
1199 qmbn@(MBN# qmba#) <- newBigNat# qn#
1200 _ <- liftIO (c_mpn_tdiv_q qmba# nba# nn# dba# dn#)
1201 unsafeRenormFreezeBigNat# qmbn
1202
1203 remBigNat :: BigNat -> BigNat -> BigNat
1204 remBigNat n@(BN# nba#) d@(BN# dba#)
1205 | isZeroBigNat d = nullBigNat
1206 | eqBigNatWord d 1## = zeroBigNat
1207 | n < d = n
1208 | True = runS $ do
1209 let nn# = sizeofBigNat# n
1210 let dn# = sizeofBigNat# d
1211 rmbn@(MBN# rmba#) <- newBigNat# dn#
1212 _ <- liftIO (c_mpn_tdiv_r rmba# nba# nn# dba# dn#)
1213 unsafeRenormFreezeBigNat# rmbn
1214
1215 -- | Note: Result of div/0 undefined
1216 quotRemBigNatWord :: BigNat -> GmpLimb# -> (# BigNat, GmpLimb# #)
1217 quotRemBigNatWord _ 0## = (# nullBigNat, 0## #)
1218 quotRemBigNatWord n 1## = (# n, 0## #)
1219 quotRemBigNatWord n@(BN# nba#) d# = case compareBigNatWord n d# of
1220 LT -> (# zeroBigNat, bigNatToWord n #)
1221 EQ -> (# oneBigNat, 0## #)
1222 GT -> case runS go of (!q,!(W# r#)) -> (# q, r# #) -- TODO: handle word/word
1223 where
1224 go = do
1225 let nn# = sizeofBigNat# n
1226 qmbn@(MBN# qmba#) <- newBigNat# nn#
1227 r <- liftIO (c_mpn_divrem_1 qmba# 0# nba# nn# d#)
1228 q <- unsafeRenormFreezeBigNat# qmbn
1229 return (q,r)
1230
1231 quotBigNatWord :: BigNat -> GmpLimb# -> BigNat
1232 quotBigNatWord n d# = case inline quotRemBigNatWord n d# of (# q, _ #) -> q
1233
1234 -- | div/0 not checked
1235 remBigNatWord :: BigNat -> GmpLimb# -> Word#
1236 remBigNatWord n@(BN# nba#) d# = c_mpn_mod_1 nba# (sizeofBigNat# n) d#
1237
1238 gcdBigNatWord :: BigNat -> Word# -> Word#
1239 gcdBigNatWord bn@(BN# ba#) = c_mpn_gcd_1# ba# (sizeofBigNat# bn)
1240
1241 gcdBigNat :: BigNat -> BigNat -> BigNat
1242 gcdBigNat x@(BN# x#) y@(BN# y#)
1243 | isZeroBigNat x = y
1244 | isZeroBigNat y = x
1245 | isTrue# (nx# >=# ny#) = runS (gcd' x# nx# y# ny#)
1246 | True = runS (gcd' y# ny# x# nx#)
1247 where
1248 gcd' a# na# b# nb# = do -- na >= nb
1249 mbn@(MBN# mba#) <- newBigNat# nb#
1250 I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#)
1251 let rn# = narrowGmpSize# rn'#
1252 case rn# ==# nb# of
1253 0# -> unsafeShrinkFreezeBigNat# mbn rn#
1254 _ -> unsafeFreezeBigNat# mbn
1255
1256 nx# = sizeofBigNat# x
1257 ny# = sizeofBigNat# y
1258
1259
1260 ----------------------------------------------------------------------------
1261 -- Conversions to/from floating point
1262
1263 decodeDoubleInteger :: Double# -> (# Integer, Int# #)
1264 -- decodeDoubleInteger 0.0## = (# S# 0#, 0# #)
1265 #if WORD_SIZE_IN_BITS == 64
1266 decodeDoubleInteger x = case decodeDouble_Int64# x of
1267 (# m#, e# #) -> (# S# m#, e# #)
1268 #elif WORD_SIZE_IN_BITS == 32
1269 decodeDoubleInteger x = case decodeDouble_Int64# x of
1270 (# m#, e# #) -> (# int64ToInteger m#, e# #)
1271 #endif
1272 {-# CONSTANT_FOLDED decodeDoubleInteger #-}
1273
1274 -- provided by GHC's RTS
1275 foreign import ccall unsafe "__int_encodeDouble"
1276 int_encodeDouble# :: Int# -> Int# -> Double#
1277
1278 encodeDoubleInteger :: Integer -> Int# -> Double#
1279 encodeDoubleInteger (S# m#) 0# = int2Double# m#
1280 encodeDoubleInteger (S# m#) e# = int_encodeDouble# m# e#
1281 encodeDoubleInteger (Jp# bn@(BN# bn#)) e#
1282 = c_mpn_get_d bn# (sizeofBigNat# bn) e#
1283 encodeDoubleInteger (Jn# bn@(BN# bn#)) e#
1284 = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) e#
1285 {-# CONSTANT_FOLDED encodeDoubleInteger #-}
1286
1287 -- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn)
1288 foreign import ccall unsafe "integer_gmp_mpn_get_d"
1289 c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double#
1290
1291 doubleFromInteger :: Integer -> Double#
1292 doubleFromInteger (S# m#) = int2Double# m#
1293 doubleFromInteger (Jp# bn@(BN# bn#))
1294 = c_mpn_get_d bn# (sizeofBigNat# bn) 0#
1295 doubleFromInteger (Jn# bn@(BN# bn#))
1296 = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) 0#
1297 {-# CONSTANT_FOLDED doubleFromInteger #-}
1298
1299 -- TODO: Not sure if it's worth to write 'Float' optimized versions here
1300 floatFromInteger :: Integer -> Float#
1301 floatFromInteger i = double2Float# (doubleFromInteger i)
1302
1303 encodeFloatInteger :: Integer -> Int# -> Float#
1304 encodeFloatInteger m e = double2Float# (encodeDoubleInteger m e)
1305
1306 ----------------------------------------------------------------------------
1307 -- FFI ccall imports
1308
1309 foreign import ccall unsafe "integer_gmp_gcd_word"
1310 gcdWord# :: GmpLimb# -> GmpLimb# -> GmpLimb#
1311
1312 foreign import ccall unsafe "integer_gmp_mpn_gcd_1"
1313 c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb#
1314
1315 foreign import ccall unsafe "integer_gmp_mpn_gcd"
1316 c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize#
1317 -> ByteArray# -> GmpSize# -> IO GmpSize
1318
1319 -- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n,
1320 -- mp_limb_t s2limb)
1321 foreign import ccall unsafe "gmp.h __gmpn_add_1"
1322 c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb#
1323 -> IO GmpLimb
1324
1325 -- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n,
1326 -- mp_limb_t s2limb)
1327 foreign import ccall unsafe "gmp.h __gmpn_sub_1"
1328 c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb#
1329 -> IO GmpLimb
1330
1331 -- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n,
1332 -- mp_limb_t s2limb)
1333 foreign import ccall unsafe "gmp.h __gmpn_mul_1"
1334 c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb#
1335 -> IO GmpLimb
1336
1337 -- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n,
1338 -- const mp_limb_t *s2p, mp_size_t s2n)
1339 foreign import ccall unsafe "gmp.h __gmpn_add"
1340 c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize#
1341 -> ByteArray# -> GmpSize# -> IO GmpLimb
1342
1343 -- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n,
1344 -- const mp_limb_t *s2p, mp_size_t s2n)
1345 foreign import ccall unsafe "gmp.h __gmpn_sub"
1346 c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray#
1347 -> GmpSize# -> IO GmpLimb
1348
1349 -- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n,
1350 -- const mp_limb_t *s2p, mp_size_t s2n)
1351 foreign import ccall unsafe "gmp.h __gmpn_mul"
1352 c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray#
1353 -> GmpSize# -> IO GmpLimb
1354
1355 -- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n)
1356 foreign import ccall unsafe "gmp.h __gmpn_cmp"
1357 c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> CInt#
1358
1359 -- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn,
1360 -- const mp_limb_t *np, mp_size_t nn,
1361 -- const mp_limb_t *dp, mp_size_t dn)
1362 foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr"
1363 c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize#
1364 -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO ()
1365
1366 foreign import ccall unsafe "integer_gmp_mpn_tdiv_q"
1367 c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray#
1368 -> GmpSize# -> IO ()
1369
1370 foreign import ccall unsafe "integer_gmp_mpn_tdiv_r"
1371 c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray#
1372 -> GmpSize# -> IO ()
1373
1374 -- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p,
1375 -- mp_size_t s2n, mp_limb_t s3limb)
1376 foreign import ccall unsafe "gmp.h __gmpn_divrem_1"
1377 c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize#
1378 -> GmpLimb# -> IO GmpLimb
1379
1380 -- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb)
1381 foreign import ccall unsafe "gmp.h __gmpn_mod_1"
1382 c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb#
1383
1384 -- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[],
1385 -- mp_size_t sn, mp_bitcnt_t count)
1386 foreign import ccall unsafe "integer_gmp_mpn_rshift"
1387 c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt#
1388 -> IO GmpLimb
1389
1390 -- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[],
1391 -- mp_size_t sn, mp_bitcnt_t count)
1392 foreign import ccall unsafe "integer_gmp_mpn_rshift_2c"
1393 c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt#
1394 -> IO GmpLimb
1395
1396 -- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[],
1397 -- mp_size_t sn, mp_bitcnt_t count)
1398 foreign import ccall unsafe "integer_gmp_mpn_lshift"
1399 c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt#
1400 -> IO GmpLimb
1401
1402 -- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p,
1403 -- mp_size_t n)
1404 foreign import ccall unsafe "gmp.h __gmpn_and_n"
1405 c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize#
1406 -> IO ()
1407
1408 -- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p,
1409 -- mp_size_t n)
1410 foreign import ccall unsafe "gmp.h __gmpn_andn_n"
1411 c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize#
1412 -> IO ()
1413
1414 -- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p,
1415 -- mp_size_t n)
1416 foreign import ccall unsafe "gmp.h __gmpn_ior_n"
1417 c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize#
1418 -> IO ()
1419
1420 -- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p,
1421 -- mp_size_t n)
1422 foreign import ccall unsafe "gmp.h __gmpn_xor_n"
1423 c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize#
1424 -> IO ()
1425
1426 -- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n)
1427 foreign import ccall unsafe "gmp.h __gmpn_popcount"
1428 c_mpn_popcount :: ByteArray# -> GmpSize# -> GmpBitCnt#
1429
1430 ----------------------------------------------------------------------------
1431 -- BigNat-wrapped ByteArray#-primops
1432
1433 -- | Return number of limbs contained in 'BigNat'.
1434 sizeofBigNat# :: BigNat -> GmpSize#
1435 sizeofBigNat# (BN# x#)
1436 = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT#
1437
1438 data MutBigNat s = MBN# !(MutableByteArray# s)
1439
1440 sizeofMutBigNat# :: MutBigNat s -> GmpSize#
1441 sizeofMutBigNat# (MBN# x#)
1442 = sizeofMutableByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT#
1443
1444 newBigNat# :: GmpSize# -> S s (MutBigNat s)
1445 newBigNat# limbs# s =
1446 case newByteArray# (limbs# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) s of
1447 (# s', mba# #) -> (# s', MBN# mba# #)
1448
1449 writeBigNat# :: MutBigNat s -> GmpSize# -> GmpLimb# -> State# s -> State# s
1450 writeBigNat# (MBN# mba#) = writeWordArray# mba#
1451
1452 -- | Extract /n/-th (0-based) limb in 'BigNat'.
1453 -- /n/ must be less than size as reported by 'sizeofBigNat#'.
1454 indexBigNat# :: BigNat -> GmpSize# -> GmpLimb#
1455 indexBigNat# (BN# ba#) = indexWordArray# ba#
1456
1457 unsafeFreezeBigNat# :: MutBigNat s -> S s BigNat
1458 unsafeFreezeBigNat# (MBN# mba#) s = case unsafeFreezeByteArray# mba# s of
1459 (# s', ba# #) -> (# s', BN# ba# #)
1460
1461 resizeMutBigNat# :: MutBigNat s -> GmpSize# -> S s (MutBigNat s)
1462 resizeMutBigNat# (MBN# mba0#) nsz# s
1463 | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = (# s, MBN# mba0# #)
1464 | True = case resizeMutableByteArray# mba0# bsz# s of
1465 (# s', mba# #) -> (# s' , MBN# mba# #)
1466 where
1467 bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT#
1468
1469 shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s
1470 shrinkMutBigNat# (MBN# mba0#) nsz#
1471 | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = \s -> s -- no-op
1472 | True = shrinkMutableByteArray# mba0# bsz#
1473 where
1474 bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT#
1475
1476 unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat
1477 unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# = do
1478 -- (MBN# mba#) <- newBigNat# (n# +# 1#)
1479 -- _ <- svoid (copyMutableByteArray# mba0# 0# mba# 0# nb0#)
1480 (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#)
1481 _ <- svoid (writeWordArray# mba# n# limb#)
1482 unsafeFreezeBigNat# (MBN# mba#)
1483 where
1484 n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT#
1485 nb0# = sizeofMutableByteArray# mba0#
1486
1487 -- | May shrink underlyng 'ByteArray#' if needed to satisfy BigNat invariant
1488 unsafeRenormFreezeBigNat# :: MutBigNat s -> S s BigNat
1489 unsafeRenormFreezeBigNat# mbn s
1490 | isTrue# (n0# ==# 0#) = (# s', nullBigNat #)
1491 | isTrue# (n# ==# 0#) = (# s', zeroBigNat #)
1492 | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s'
1493 | True = (unsafeShrinkFreezeBigNat# mbn n#) s'
1494 where
1495 (# s', n# #) = normSizeofMutBigNat'# mbn n0# s
1496 n0# = sizeofMutBigNat# mbn
1497
1498 -- | Shrink MBN
1499 unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat
1500 unsafeShrinkFreezeBigNat# x@(MBN# xmba) 1#
1501 = \s -> case readWordArray# xmba 0# s of
1502 (# s', w# #) -> freezeOneLimb w# s'
1503 where
1504 freezeOneLimb 0## = return zeroBigNat
1505 freezeOneLimb 1## = return oneBigNat
1506 freezeOneLimb w# | isTrue# (not# w# `eqWord#` 0##) = return czeroBigNat
1507 freezeOneLimb _ = do
1508 _ <- svoid (shrinkMutBigNat# x 1#)
1509 unsafeFreezeBigNat# x
1510 unsafeShrinkFreezeBigNat# x y# = do
1511 _ <- svoid (shrinkMutBigNat# x y#)
1512 unsafeFreezeBigNat# x
1513
1514
1515 copyWordArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int#
1516 -> State# s -> State# s
1517 copyWordArray# src src_ofs dst dst_ofs len
1518 = copyByteArray# src (src_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
1519 dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
1520 (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
1521
1522 -- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#'
1523 normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #)
1524 normSizeofMutBigNat# mbn@(MBN# mba) = normSizeofMutBigNat'# mbn sz#
1525 where
1526 sz# = sizeofMutableByteArray# mba `uncheckedIShiftRA#` GMP_LIMB_SHIFT#
1527
1528 -- | Find most-significant non-zero limb and return its index-position
1529 -- plus one. Start scanning downward from the initial limb-size
1530 -- (i.e. start-index plus one) given as second argument.
1531 --
1532 -- NB: The 'normSizeofMutBigNat' of 'zeroBigNat' would be @0#@
1533 normSizeofMutBigNat'# :: MutBigNat s -> GmpSize#
1534 -> State# s -> (# State# s, GmpSize# #)
1535 normSizeofMutBigNat'# (MBN# mba) = go
1536 where
1537 go 0# s = (# s, 0# #)
1538 go i0# s = case readWordArray# mba (i0# -# 1#) s of
1539 (# s', 0## #) -> go (i0# -# 1#) s'
1540 (# s', _ #) -> (# s', i0# #)
1541
1542 -- | Construct 'BigNat' from existing 'ByteArray#' containing /n/
1543 -- 'GmpLimb's in least-significant-first order.
1544 --
1545 -- If possible 'ByteArray#', will be used directly (i.e. shared
1546 -- /without/ cloning the 'ByteArray#' into a newly allocated one)
1547 --
1548 -- Note: size parameter (times @sizeof(GmpLimb)@) must be less or
1549 -- equal to its 'sizeofByteArray#'.
1550 byteArrayToBigNat# :: ByteArray# -> GmpSize# -> BigNat
1551 byteArrayToBigNat# ba# n0#
1552 | isTrue# (n# ==# 0#) = zeroBigNat
1553 | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size
1554 , isTrue# (baszq# ==# n#) = (BN# ba#)
1555 | True = runS $ do
1556 mbn@(MBN# mba#) <- newBigNat# n#
1557 _ <- svoid (copyByteArray# ba# 0# mba# 0# (sizeofMutableByteArray# mba#))
1558 unsafeFreezeBigNat# mbn
1559 where
1560 (# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES#
1561
1562 n# = fmssl (n0# -# 1#)
1563
1564 -- find most signifcant set limb, return normalized size
1565 fmssl i#
1566 | isTrue# (i# <# 0#) = 0#
1567 | isTrue# (neWord# (indexWordArray# ba# i#) 0##) = i# +# 1#
1568 | True = fmssl (i# -# 1#)
1569
1570 -- | Read 'Integer' (without sign) from memory location at @/addr/@ in
1571 -- base-256 representation.
1572 --
1573 -- @'importIntegerFromAddr' /addr/ /size/ /msbf/@
1574 --
1575 -- See description of 'importIntegerFromByteArray' for more details.
1576 --
1577 -- /Since: 1.0.0.0/
1578 importIntegerFromAddr :: Addr# -> Word# -> Int# -> IO Integer
1579 importIntegerFromAddr addr len msbf = IO $ do
1580 bn <- liftIO (importBigNatFromAddr addr len msbf)
1581 return (bigNatToInteger bn)
1582
1583 -- | Version of 'importIntegerFromAddr' constructing a 'BigNat'
1584 importBigNatFromAddr :: Addr# -> Word# -> Int# -> IO BigNat
1585 importBigNatFromAddr _ 0## _ = IO (\s -> (# s, zeroBigNat #))
1586 importBigNatFromAddr addr len0 1# = IO $ do -- MSBF
1587 W# ofs <- liftIO (c_scan_nzbyte_addr addr 0## len0)
1588 let len = len0 `minusWord#` ofs
1589 addr' = addr `plusAddr#` (word2Int# ofs)
1590 importBigNatFromAddr# addr' len 1#
1591 importBigNatFromAddr addr len0 _ = IO $ do -- LSBF
1592 W# len <- liftIO (c_rscan_nzbyte_addr addr 0## len0)
1593 importBigNatFromAddr# addr len 0#
1594
1595 foreign import ccall unsafe "integer_gmp_scan_nzbyte"
1596 c_scan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word
1597
1598 foreign import ccall unsafe "integer_gmp_rscan_nzbyte"
1599 c_rscan_nzbyte_addr :: Addr# -> Word# -> Word# -> IO Word
1600
1601 -- | Helper for 'importBigNatFromAddr'
1602 importBigNatFromAddr# :: Addr# -> Word# -> Int# -> S RealWorld BigNat
1603 importBigNatFromAddr# _ 0## _ = return zeroBigNat
1604 importBigNatFromAddr# addr len msbf = do
1605 mbn@(MBN# mba#) <- newBigNat# n#
1606 () <- liftIO (c_mpn_import_addr mba# addr 0## len msbf)
1607 unsafeFreezeBigNat# mbn
1608 where
1609 -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required
1610 n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD#
1611
1612 foreign import ccall unsafe "integer_gmp_mpn_import"
1613 c_mpn_import_addr :: MutableByteArray# RealWorld -> Addr# -> Word# -> Word#
1614 -> Int# -> IO ()
1615
1616 -- | Read 'Integer' (without sign) from byte-array in base-256 representation.
1617 --
1618 -- The call
1619 --
1620 -- @'importIntegerFromByteArray' /ba/ /offset/ /size/ /msbf/@
1621 --
1622 -- reads
1623 --
1624 -- * @/size/@ bytes from the 'ByteArray#' @/ba/@ starting at @/offset/@
1625 --
1626 -- * with most significant byte first if @/msbf/@ is @1#@ or least
1627 -- significant byte first if @/msbf/@ is @0#@, and
1628 --
1629 -- * returns a new 'Integer'
1630 --
1631 -- /Since: 1.0.0.0/
1632 importIntegerFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> Integer
1633 importIntegerFromByteArray ba ofs len msbf
1634 = bigNatToInteger (importBigNatFromByteArray ba ofs len msbf)
1635
1636 -- | Version of 'importIntegerFromByteArray' constructing a 'BigNat'
1637 importBigNatFromByteArray :: ByteArray# -> Word# -> Word# -> Int# -> BigNat
1638 importBigNatFromByteArray _ _ 0## _ = zeroBigNat
1639 importBigNatFromByteArray ba ofs0 len0 1# = runS $ do -- MSBF
1640 W# ofs <- liftIO (c_scan_nzbyte_bytearray ba ofs0 len0)
1641 let len = (len0 `plusWord#` ofs0) `minusWord#` ofs
1642 importBigNatFromByteArray# ba ofs len 1#
1643 importBigNatFromByteArray ba ofs len0 _ = runS $ do -- LSBF
1644 W# len <- liftIO (c_rscan_nzbyte_bytearray ba ofs len0)
1645 importBigNatFromByteArray# ba ofs len 0#
1646
1647 foreign import ccall unsafe "integer_gmp_scan_nzbyte"
1648 c_scan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word
1649
1650 foreign import ccall unsafe "integer_gmp_rscan_nzbyte"
1651 c_rscan_nzbyte_bytearray :: ByteArray# -> Word# -> Word# -> IO Word
1652
1653 -- | Helper for 'importBigNatFromByteArray'
1654 importBigNatFromByteArray# :: ByteArray# -> Word# -> Word# -> Int#
1655 -> S RealWorld BigNat
1656 importBigNatFromByteArray# _ _ 0## _ = return zeroBigNat
1657 importBigNatFromByteArray# ba ofs len msbf = do
1658 mbn@(MBN# mba#) <- newBigNat# n#
1659 () <- liftIO (c_mpn_import_bytearray mba# ba ofs len msbf)
1660 unsafeFreezeBigNat# mbn
1661 where
1662 -- n = ceiling(len / SIZEOF_HSWORD), i.e. number of limbs required
1663 n# = (word2Int# len +# (SIZEOF_HSWORD# -# 1#)) `quotInt#` SIZEOF_HSWORD#
1664
1665 foreign import ccall unsafe "integer_gmp_mpn_import"
1666 c_mpn_import_bytearray :: MutableByteArray# RealWorld -> ByteArray# -> Word#
1667 -> Word# -> Int# -> IO ()
1668
1669 -- | Test whether all internal invariants are satisfied by 'BigNat' value
1670 --
1671 -- Returns @1#@ if valid, @0#@ otherwise.
1672 --
1673 -- This operation is mostly useful for test-suites and/or code which
1674 -- constructs 'Integer' values directly.
1675 isValidBigNat# :: BigNat -> Int#
1676 isValidBigNat# (BN# ba#)
1677 = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm#
1678 where
1679 isNorm# = case szq# ># 1# of
1680 1# -> (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0##
1681 _ -> 1#
1682
1683 sz# = sizeofByteArray# ba#
1684
1685 (# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES#
1686
1687 ----------------------------------------------------------------------------
1688 -- monadic combinators for low-level state threading
1689
1690 type S s a = State# s -> (# State# s, a #)
1691
1692 infixl 1 >>=
1693 infixl 1 >>
1694 infixr 0 $
1695
1696 {-# INLINE ($) #-}
1697 ($) :: (a -> b) -> a -> b
1698 f $ x = f x
1699
1700 {-# INLINE (>>=) #-}
1701 (>>=) :: S s a -> (a -> S s b) -> S s b
1702 (>>=) m k = \s -> case m s of (# s', a #) -> k a s'
1703
1704 {-# INLINE (>>) #-}
1705 (>>) :: S s a -> S s b -> S s b
1706 (>>) m k = \s -> case m s of (# s', _ #) -> k s'
1707
1708 {-# INLINE svoid #-}
1709 svoid :: (State# s -> State# s) -> S s ()
1710 svoid m0 = \s -> case m0 s of s' -> (# s', () #)
1711
1712 {-# INLINE return #-}
1713 return :: a -> S s a
1714 return a = \s -> (# s, a #)
1715
1716 {-# INLINE liftIO #-}
1717 liftIO :: IO a -> S RealWorld a
1718 liftIO (IO m) = m
1719
1720 -- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there
1721 runS :: S RealWorld a -> a
1722 runS m = lazy (case m realWorld# of (# _, r #) -> r)
1723 {-# NOINLINE runS #-}
1724
1725 -- stupid hack
1726 fail :: [Char] -> S s a
1727 fail s = return (raise# s)
1728
1729 ----------------------------------------------------------------------------
1730 -- misc helpers, some of these should rather be primitives exported by ghc-prim
1731
1732 cmpW# :: Word# -> Word# -> Ordering
1733 cmpW# x# y#
1734 | isTrue# (x# `ltWord#` y#) = LT
1735 | isTrue# (x# `eqWord#` y#) = EQ
1736 | True = GT
1737 {-# INLINE cmpW# #-}
1738
1739 subWordC# :: Word# -> Word# -> (# Word#, Int# #)
1740 subWordC# x# y# = (# d#, c# #)
1741 where
1742 d# = x# `minusWord#` y#
1743 c# = d# `gtWord#` x#
1744 {-# INLINE subWordC# #-}
1745
1746 bitWord# :: Int# -> Word#
1747 bitWord# = uncheckedShiftL# 1##
1748 {-# INLINE bitWord# #-}
1749
1750 testBitWord# :: Word# -> Int# -> Int#
1751 testBitWord# w# i# = (bitWord# i# `and#` w#) `neWord#` 0##
1752 {-# INLINE testBitWord# #-}
1753
1754 popCntI# :: Int# -> Int#
1755 popCntI# i# = word2Int# (popCnt# (int2Word# i#))
1756 {-# INLINE popCntI# #-}
1757
1758 -- branchless version
1759 absI# :: Int# -> Int#
1760 absI# i# = (i# `xorI#` nsign) -# nsign
1761 where
1762 -- nsign = negateInt# (i# <# 0#)
1763 nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#)
1764
1765 -- branchless version
1766 sgnI# :: Int# -> Int#
1767 sgnI# x# = (x# ># 0#) -# (x# <# 0#)
1768
1769 cmpI# :: Int# -> Int# -> Int#
1770 cmpI# x# y# = (x# ># y#) -# (x# <# y#)