module GHC.Num.Backend.Native where
#include "MachDeps.h"
#include "WordSize.h"
#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) || defined(BIGNUM_FFI)
import GHC.Num.BigNat
import GHC.Num.Natural
import GHC.Num.Integer
#else
import GHC.Num.BigNat
import GHC.Num.Natural
import GHC.Num.Integer
#endif
import GHC.Num.WordArray
import GHC.Num.Primitives
import GHC.Prim
import GHC.Types
default ()
count_words_bits :: Word# -> (# Word#, Word# #)
count_words_bits n = (# nw, nb #)
where
nw = n `uncheckedShiftRL#` WORD_SIZE_BITS_SHIFT#
nb = n `and#` WORD_SIZE_BITS_MASK##
count_words_bits_int :: Word# -> (# Int#, Int# #)
count_words_bits_int n = case count_words_bits n of
(# nw, nb #) -> (# word2Int# nw, word2Int# nb #)
bignat_compare :: WordArray# -> WordArray# -> Int#
bignat_compare wa wb = go (sz -# 1#)
where
sz = wordArraySize# wa
go i
| isTrue# (i <# 0#) = 0#
| a <- indexWordArray# wa i
, b <- indexWordArray# wb i
= if | isTrue# (a `eqWord#` b) -> go (i -# 1#)
| isTrue# (a `gtWord#` b) -> 1#
| True -> 1#
bignat_add
:: MutableWordArray# s
-> WordArray#
-> WordArray#
-> State# s
-> State# s
bignat_add mwa wa wb = addABc 0# 0##
where
!szA = wordArraySize# wa
!szB = wordArraySize# wb
!szMin = minI# szA szB
addABc i carry s
| isTrue# (i <# szMin) =
let
!(# carry', r #) = plusWord3#
(indexWordArray# wa i)
(indexWordArray# wb i)
carry
in case mwaWrite# mwa i r s of
s' -> addABc (i +# 1#) carry' s'
| isTrue# ((i ==# szA) &&# (i ==# szB))
= mwaWriteOrShrink mwa carry i s
| isTrue# (i ==# szA)
= addAoBc wb i carry s
| True
= addAoBc wa i carry s
addAoBc wab i carry s
| isTrue# (i ==# wordArraySize# wab)
= mwaWriteOrShrink mwa carry i s
| 0## <- carry
=
case mwaArrayCopy# mwa i wab i (wordArraySize# wab -# i) s of
s' -> mwaShrink# mwa 1# s'
| True
= let !(# carry', r #) = plusWord2# (indexWordArray# wab i) carry
in case mwaWrite# mwa i r s of
s' -> addAoBc wab (i +# 1#) carry' s'
bignat_add_word
:: MutableWordArray# RealWorld
-> WordArray#
-> Word#
-> State# RealWorld
-> State# RealWorld
bignat_add_word mwa wa b s = mwaInitArrayPlusWord mwa wa b s
bignat_sub_word
:: MutableWordArray# RealWorld
-> WordArray#
-> Word#
-> State# RealWorld
-> (# State# RealWorld, Bool# #)
bignat_sub_word mwa wa b = go b 0#
where
!sz = wordArraySize# wa
go carry i s
| isTrue# (i >=# sz)
= (# s, carry `eqWord#` 0## #)
| 0## <- carry
= case mwaArrayCopy# mwa i wa i (sz -# i) s of
s' -> (# s', 1# #)
| True
= case subWordC# (indexWordArray# wa i) carry of
(# 0##, 0# #)
| isTrue# (i ==# sz) -> case mwaShrink# mwa 1# s of
s' -> (# s', 1# #)
(# l , c #) -> case mwaWrite# mwa i l s of
s1 -> go (int2Word# c) (i +# 1#) s1
bignat_mul_word
:: MutableWordArray# RealWorld
-> WordArray#
-> Word#
-> State# RealWorld
-> State# RealWorld
bignat_mul_word mwa wa b = go 0# 0##
where
!szA = wordArraySize# wa
go i carry s
| isTrue# (i ==# szA) = mwaWriteOrShrink mwa carry i s
| True =
let
ai = indexWordArray# wa i
!(# carry', r #) = plusWord12# carry (timesWord2# ai b)
in case mwaWrite# mwa i r s of
s' -> go (i +# 1#) carry' s'
bignat_mul
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_mul mwa wa wb s1 =
case mwaFill# mwa 0## 0## (int2Word# sz) s1 of
s' -> mulEachB ctzB s'
where
!szA = wordArraySize# wa
!szB = wordArraySize# wb
!sz = szA +# szB
!ctzA = word2Int# (bigNatCtzWord# wa)
!ctzB = word2Int# (bigNatCtzWord# wb)
mul bj j i carry s
| isTrue# (i ==# szA)
= mwaAddInplaceWord# mwa (i +# j) carry s
| True = let
ai = indexWordArray# wa i
!(# c',r' #) = timesWord2# ai bj
!(# c'',r #) = plusWord2# r' carry
carry' = plusWord# c' c''
in case mwaAddInplaceWord# mwa (i +# j) r s of
s' -> mul bj j (i +# 1#) carry' s'
mulEachB i s
| isTrue# (i ==# szB) = s
| True = case indexWordArray# wb i of
0## -> mulEachB (i +# 1#) s
bi -> case mul bi i ctzA 0## s of
s' -> mulEachB (i +# 1#) s'
bignat_sub
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> (# State# RealWorld, Bool# #)
bignat_sub mwa wa wb s =
case mwaArrayCopy# mwa 0# wa 0# (wordArraySize# wa) s of
s' -> mwaSubInplaceArray mwa 0# wb s'
bignat_popcount :: WordArray# -> Word#
bignat_popcount wa = go 0# 0##
where
!sz = wordArraySize# wa
go i c
| isTrue# (i ==# sz) = c
| True = go (i +# 1#) (c `plusWord#` popCnt# (indexWordArray# wa i))
bignat_shiftl
:: MutableWordArray# s
-> WordArray#
-> Word#
-> State# s
-> State# s
bignat_shiftl mwa wa n s1 =
case mwaFill# mwa 0## 0## (int2Word# nw) s1 of
s2 -> if
| 0# <- nb -> mwaArrayCopy# mwa nw wa 0# szA s2
| True -> mwaBitShift 0# 0## s2
where
!szA = wordArraySize# wa
!(# nw, nb #) = count_words_bits_int n
!sh = WORD_SIZE_IN_BITS# -# nb
mwaBitShift i c s
| isTrue# (i ==# szA)
= mwaWriteOrShrink mwa c (i +# nw) s
| True =
let
!ai = indexWordArray# wa i
!v = c `or#` (ai `uncheckedShiftL#` nb)
!c' = ai `uncheckedShiftRL#` sh
in case mwaWrite# mwa (i +# nw) v s of
s' -> mwaBitShift (i +# 1#) c' s'
bignat_shiftr
:: MutableWordArray# s
-> WordArray#
-> Word#
-> State# s
-> State# s
bignat_shiftr mwa wa n s1
| isTrue# (nb ==# 0#) = mwaArrayCopy# mwa 0# wa nw sz s1
| True = mwaBitShift (sz -# 1#) 0## s1
where
!szA = wordArraySize# wa
!(# nw, nb #) = count_words_bits_int n
!sz = szA -# nw
!sh = WORD_SIZE_IN_BITS# -# nb
mwaBitShift i c s
| isTrue# (i <# 0#) = s
| True =
let
!ai = indexWordArray# wa (i +# nw)
!v = c `or#` (ai `uncheckedShiftRL#` nb)
!c' = ai `uncheckedShiftL#` sh
in case mwaWrite# mwa i v s of
s' -> mwaBitShift (i -# 1#) c' s'
bignat_shiftr_neg
:: MutableWordArray# s
-> WordArray#
-> Word#
-> State# s
-> State# s
bignat_shiftr_neg mwa wa n s1
= case mwaWrite# mwa (szA -# 1#) 0## s1 of
s2 -> case bignat_shiftr mwa wa n s2 of
s3 -> if nz_shifted_out
then mwaAddInplaceWord# mwa 0# 1## s3
else s3
where
!szA = wordArraySize# wa
!(# nw, nb #) = count_words_bits_int n
nz_shifted_out
| isTrue# (
(nb /=# 0#)
&&# (indexWordArray# wa nw `uncheckedShiftL#`
(WORD_SIZE_IN_BITS# -# nb) `neWord#` 0##))
= True
| True
= let
go j
| isTrue# (j ==# nw) = False
| isTrue# (indexWordArray# wa j `neWord#` 0##) = True
| True = go (j +# 1#)
in go 0#
bignat_or
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_or mwa wa wb s1
| isTrue# (szA >=# szB) = go wa szA wb szB s1
| True = go wb szB wa szA s1
where
!szA = wordArraySize# wa
!szB = wordArraySize# wb
go wx nx wy ny s =
case mwaInitArrayBinOp mwa wx wy or# s of
s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s'
bignat_xor
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_xor mwa wa wb s1
| isTrue# (szA >=# szB) = go wa szA wb szB s1
| True = go wb szB wa szA s1
where
!szA = wordArraySize# wa
!szB = wordArraySize# wb
go wx nx wy ny s =
case mwaInitArrayBinOp mwa wx wy xor# s of
s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s'
bignat_and
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s
bignat_and_not
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_and_not mwa wa wb s =
case mwaInitArrayBinOp mwa wa wb (\x y -> x `and#` not# y) s of
s' -> mwaArrayCopy# mwa szB wa szB (szA -# szB) s'
where
!szA = wordArraySize# wa
!szB = wordArraySize# wb
bignat_quotrem
:: MutableWordArray# s
-> MutableWordArray# s
-> WordArray#
-> WordArray#
-> State# s
-> State# s
bignat_quotrem mwq mwr uwa uwb s0 =
let !clzb = clz# (indexWordArray# uwb (wordArraySize# uwb -# 1#))
in case newWordArray# (wordArraySize# uwa +# 1#) s0 of { (# s1, mnwa #) ->
let normalizeA s = case mwaWrite# mnwa (wordArraySize# uwa) 0## s of
s -> case bignat_shiftl mnwa uwa clzb s of
s -> mwaTrimZeroes# mnwa s
in case normalizeA s1 of { s2 ->
let !nwb = bigNatShiftL# uwb clzb in
case bignat_quotrem_normalized mwq mnwa nwb s2 of { s3 ->
let denormalizeR s = case mwaTrimZeroes# mnwa s of
s -> case unsafeFreezeByteArray# mnwa s of
(# s, wr #) -> case mwaSetSize# mwr (wordArraySize# wr) s of
s -> case bignat_shiftr mwr wr clzb s of
s -> mwaTrimZeroes# mwr s
in denormalizeR s3
}}}
bignat_quot
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_quot mwq wa wb s =
case newWordArray# (wordArraySize# wb) s of
(# s, mwr #) -> bignat_quotrem mwq mwr wa wb s
bignat_rem
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_rem mwr wa wb s =
case newWordArray# szQ s of
(# s, mwq #) -> bignat_quotrem mwq mwr wa wb s
where
szA = wordArraySize# wa
szB = wordArraySize# wb
szQ = 1# +# szA -# szB
bignat_quotrem_normalized
:: MutableWordArray# s
-> MutableWordArray# s
-> WordArray#
-> State# s
-> State# s
bignat_quotrem_normalized mwq mwa b s0 =
let !n = wordArraySize# b
in case mwaSize# mwa s0 of { (# s1, szA #) ->
let !m = szA -# n in
let computeQm s = case mwaTrimCompare m mwa b s of
(# s, LT #) -> (# s, 0## #)
(# s, _ #) -> (# s, 1## #)
updateQj j qj qjb s = case mwaWrite# mwq j qj s of
s | 0## <- qj -> s
| True -> case mwaSubInplaceArray mwa j qjb s of
(# s, _ #) -> s
updateQm s = case computeQm s of
(# s, qm #) -> updateQj m qm b s
updateQmMaybe s = case mwaSize# mwq s of
(# s, szQ #) | isTrue# (m <# szQ) -> updateQm s
| True -> s
in case updateQmMaybe s1 of { s2 ->
let bmsw = wordArrayLast# b
estimateQj j s =
case mwaRead# mwa (n +# j) s of
(# s, a1 #) -> case mwaRead# mwa (n +# j -# 1#) s of
(# s, a0 #) -> case quotRemWord3# (# a1, a0 #) bmsw of
(# (# 0##, qj #), _ #) -> (# s, qj #)
(# (# _, _ #), _ #) -> (# s, WORD_MAXBOUND## #)
findRealQj j qj s = findRealQj' j qj (bigNatMulWord# b qj) s
findRealQj' j qj qjB s = case mwaTrimCompare j mwa qjB s of
(# s, LT #) -> findRealQj' j (qj `minusWord#` 1##) (bigNatSubUnsafe qjB b) s
(# s, _ #) -> (# s, qj, qjB #)
loop j s = case estimateQj j s of
(# s, qj #) -> case findRealQj j qj s of
(# s, qj, qjB #) -> case updateQj j qj qjB s of
s | 0# <- j -> s
| True -> loop (j -# 1#) s
in if | 0# <- m -> s2
| True -> loop (m -# 1#) s2
}}
bignat_quotrem_word
:: MutableWordArray# s
-> WordArray#
-> Word#
-> State# s
-> (# State# s, Word# #)
bignat_quotrem_word mwq wa b s = go (sz -# 1#) 0## s
where
sz = wordArraySize# wa
go i r s
| isTrue# (i <# 0#) = (# s, r #)
| True =
let
ai = indexWordArray# wa i
!(# q,r' #) = quotRemWord2# r ai b
in case mwaWrite# mwq i q s of
s' -> go (i -# 1#) r' s'
bignat_quot_word
:: MutableWordArray# s
-> WordArray#
-> Word#
-> State# s
-> State# s
bignat_quot_word mwq wa b s = go (sz -# 1#) 0## s
where
sz = wordArraySize# wa
go i r s
| isTrue# (i <# 0#) = s
| True =
let
ai = indexWordArray# wa i
!(# q,r' #) = quotRemWord2# r ai b
in case mwaWrite# mwq i q s of
s' -> go (i -# 1#) r' s'
bignat_rem_word
:: WordArray#
-> Word#
-> Word#
bignat_rem_word wa b = go (sz -# 1#) 0##
where
sz = wordArraySize# wa
go i r
| isTrue# (i <# 0#) = r
| True =
let
ai = indexWordArray# wa i
!(# _,r' #) = quotRemWord2# r ai b
in go (i -# 1#) r'
bignat_gcd
:: MutableWordArray# s
-> WordArray#
-> WordArray#
-> State# s
-> State# s
bignat_gcd mwr = go
where
go wmax wmin s
| isTrue# (wordArraySize# wmin ==# 0#)
= mwaInitCopyShrink# mwr wmax s
| True
= let
wmax' = wmin
!wmin' = bigNatRem wmax wmin
in go wmax' wmin' s
bignat_gcd_word
:: WordArray#
-> Word#
-> Word#
bignat_gcd_word a b = bignat_gcd_word_word b (bigNatRemWord# a b)
bignat_gcd_word_word
:: Word#
-> Word#
-> Word#
bignat_gcd_word_word a 0## = a
bignat_gcd_word_word a b = bignat_gcd_word_word b (a `remWord#` b)
bignat_encode_double :: WordArray# -> Int# -> Double#
bignat_encode_double wa e0 = go 0.0## e0 0#
where
sz = wordArraySize# wa
go acc e i
| isTrue# (i >=# sz) = acc
| True
= go (acc +## wordEncodeDouble# (indexWordArray# wa i) e)
(e +# WORD_SIZE_IN_BITS#)
(i +# 1#)
bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word#
bignat_powmod_word b0 e0 m = go (naturalFromBigNat# b0) (naturalFromBigNat# e0) (naturalFromWord# 1##)
where
go !b e !r
| isTrue# (e `naturalTestBit#` 0##)
= go b' e' ((r `naturalMul` b) `naturalRem` m')
| naturalIsZero e
= naturalToWord# r
| True
= go b' e' r
where
b' = (b `naturalMul` b) `naturalRem` m'
m' = naturalFromWord# m
e' = e `naturalShiftR#` 1##
bignat_powmod
:: MutableWordArray# RealWorld
-> WordArray#
-> WordArray#
-> WordArray#
-> State# RealWorld
-> State# RealWorld
bignat_powmod r b0 e0 m s = mwaInitCopyShrink# r r' s
where
!r' = go (naturalFromBigNat# b0)
(naturalFromBigNat# e0)
(naturalFromWord# 1##)
go !b e !r
| isTrue# (e `naturalTestBit#` 0##)
= go b' e' ((r `naturalMul` b) `naturalRem` m')
| naturalIsZero e
= naturalToBigNat# r
| True
= go b' e' r
where
b' = (b `naturalMul` b) `naturalRem` m'
m' = naturalFromBigNat# m
e' = e `naturalShiftR#` 1##
bignat_powmod_words
:: Word#
-> Word#
-> Word#
-> Word#
bignat_powmod_words b e m =
bignat_powmod_word (wordArrayFromWord# b)
(wordArrayFromWord# e)
m
integer_gcde
:: Integer
-> Integer
-> (# Integer, Integer, Integer #)
integer_gcde a b = f (# a,integerOne,integerZero #) (# b,integerZero,integerOne #)
where
fix (# g, x, y #)
| integerIsNegative g = (# integerNegate g, integerNegate x, integerNegate y #)
| True = (# g,x,y #)
f old@(# old_g, old_s, old_t #) new@(# g, s, t #)
| integerIsZero g = fix old
| True = case integerQuotRem# old_g g of
!(# q, r #) -> f new (# r , old_s `integerSub` (q `integerMul` s)
, old_t `integerSub` (q `integerMul` t) #)
integer_recip_mod
:: Integer
-> Natural
-> (# Natural | () #)
integer_recip_mod x m =
let m' = integerFromNatural m
in case integer_gcde x m' of
(# g, a, _b #)
| g `integerEq` integerOne -> (# integerToNatural (a `integerMod` m') | #)
| True -> (# | () #)
integer_powmod
:: Integer
-> Natural
-> Natural
-> Natural
integer_powmod b0 e0 m = go b0 e0 integerOne
where
!m' = integerFromNatural m
go !b e !r
| isTrue# (e `naturalTestBit#` 0##)
= go b' e' ((r `integerMul` b) `integerMod` m')
| naturalIsZero e
= integerToNatural r
| True
= go b' e' r
where
b' = (b `integerMul` b) `integerRem` m'
e' = e `naturalShiftR#` 1##