From 92daad241bf136a10346ecbf520d62921c82bf7d Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 23 Sep 2020 12:24:49 +0200 Subject: Bignum: refactor backend modules * move backends into GHC.Num.Backend.* * split backend selection into GHC.Num.Backend and GHC.Num.Backend.Selected to avoid duplication with the Check backend --- libraries/ghc-bignum/ghc-bignum.cabal | 13 +- libraries/ghc-bignum/src/GHC/Num/Backend.hs | 15 + libraries/ghc-bignum/src/GHC/Num/Backend/Check.hs | 455 +++++++++++++ libraries/ghc-bignum/src/GHC/Num/Backend/FFI.hs | 581 +++++++++++++++++ libraries/ghc-bignum/src/GHC/Num/Backend/GMP.hs | 499 ++++++++++++++ libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs | 719 +++++++++++++++++++++ .../ghc-bignum/src/GHC/Num/Backend/Selected.hs | 24 + libraries/ghc-bignum/src/GHC/Num/BigNat.hs | 17 +- libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs | 463 ------------- libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs | 581 ----------------- libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs | 499 -------------- libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs | 719 --------------------- 12 files changed, 2300 insertions(+), 2285 deletions(-) create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend.hs create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend/Check.hs create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend/FFI.hs create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend/GMP.hs create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs create mode 100644 libraries/ghc-bignum/src/GHC/Num/Backend/Selected.hs delete mode 100644 libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs delete mode 100644 libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs delete mode 100644 libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs delete mode 100644 libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs diff --git a/libraries/ghc-bignum/ghc-bignum.cabal b/libraries/ghc-bignum/ghc-bignum.cabal index 150ceabf51..bc478cf108 100644 --- a/libraries/ghc-bignum/ghc-bignum.cabal +++ b/libraries/ghc-bignum/ghc-bignum.cabal @@ -66,15 +66,12 @@ library default-language: Haskell2010 other-extensions: BangPatterns - CApiFFI CPP - DeriveDataTypeable ExplicitForAll GHCForeignImportPrim MagicHash NegativeLiterals NoImplicitPrelude - StandaloneDeriving UnboxedTuples UnliftedFFITypes ForeignFunctionInterface @@ -97,14 +94,14 @@ library if flag(gmp) cpp-options: -DBIGNUM_GMP other-modules: - GHC.Num.BigNat.GMP + GHC.Num.Backend.GMP c-sources: cbits/gmp_wrappers.c if flag(ffi) cpp-options: -DBIGNUM_FFI other-modules: - GHC.Num.BigNat.FFI + GHC.Num.Backend.FFI if flag(native) cpp-options: -DBIGNUM_NATIVE @@ -112,13 +109,15 @@ library if flag(check) cpp-options: -DBIGNUM_CHECK other-modules: - GHC.Num.BigNat.Check + GHC.Num.Backend.Check exposed-modules: GHC.Num.Primitives GHC.Num.WordArray GHC.Num.BigNat - GHC.Num.BigNat.Native + GHC.Num.Backend + GHC.Num.Backend.Selected + GHC.Num.Backend.Native GHC.Num.Natural GHC.Num.Integer diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend.hs b/libraries/ghc-bignum/src/GHC/Num/Backend.hs new file mode 100644 index 0000000000..285be2a703 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Selected backend +module GHC.Num.Backend + ( module Backend + ) +where + +#if defined(BIGNUM_CHECK) +import GHC.Num.Backend.Check as Backend +#else +import GHC.Num.Backend.Selected as Backend +#endif + diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend/Check.hs b/libraries/ghc-bignum/src/GHC/Num/Backend/Check.hs new file mode 100644 index 0000000000..73f8366ad0 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend/Check.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +-- | Check Native implementation against another backend +module GHC.Num.Backend.Check where + +import GHC.Prim +import GHC.Types +import GHC.Num.WordArray +import GHC.Num.Primitives +import qualified GHC.Num.Backend.Native as Native +import qualified GHC.Num.Backend.Selected as Other + +#if defined(BIGNUM_NATIVE) +#error You can't validate Native backend against itself. Choose another backend (e.g. gmp, ffi) +#endif + +default () + +bignat_compare + :: WordArray# + -> WordArray# + -> Int# +bignat_compare a b = + let + gr = Other.bignat_compare a b + nr = Native.bignat_compare a b + in case gr ==# nr of + 0# -> unexpectedValue_Int# (# #) + _ -> gr + +mwaCompare + :: MutableWordArray# s + -> MutableWordArray# s + -> State# s + -> (# State# s, Bool# #) +mwaCompare mwa mwb s = + case mwaSize# mwa s of + (# s, szA #) -> case mwaSize# mwb s of + (# s, szB #) -> case szA ==# szB of + 0# -> (# s, 0# #) + _ -> let + go i s + | isTrue# (i <# 0#) = (# s, 1# #) + | True = + case readWordArray# mwa i s of + (# s, a #) -> case readWordArray# mwb i s of + (# s, b #) -> case a `eqWord#` b of + 0# -> (# s, 0# #) + _ -> go (i -# 1#) s + in go (szA -# 1#) s + +mwaCompareOp + :: MutableWordArray# s + -> (MutableWordArray# s -> State# s -> State# s) + -> (MutableWordArray# s -> State# s -> State# s) + -> State# s + -> State# s +mwaCompareOp mwa f g s = + case mwaSize# mwa s of { (# s, sz #) -> + case newWordArray# sz s of { (# s, mwb #) -> + case f mwa s of { s -> + case g mwb s of { s -> + case mwaTrimZeroes# mwa s of { s -> + case mwaTrimZeroes# mwb s of { s -> + case mwaCompare mwa mwb s of + (# s, 0# #) -> case unexpectedValue of + !_ -> s + -- see Note [ghc-bignum exceptions] in + -- GHC.Num.Primitives + (# s, _ #) -> s + }}}}}} + +mwaCompareOp2 + :: MutableWordArray# s + -> MutableWordArray# s + -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) + -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) + -> State# s + -> State# s +mwaCompareOp2 mwa mwb f g s = + case mwaSize# mwa s of { (# s, szA #) -> + case mwaSize# mwb s of { (# s, szB #) -> + case newWordArray# szA s of { (# s, mwa' #) -> + case newWordArray# szB s of { (# s, mwb' #) -> + case f mwa mwb s of { s -> + case g mwa' mwb' s of { s -> + case mwaTrimZeroes# mwa s of { s -> + case mwaTrimZeroes# mwb s of { s -> + case mwaTrimZeroes# mwa' s of { s -> + case mwaTrimZeroes# mwb' s of { s -> + case mwaCompare mwa mwa' s of { (# s, ba #) -> + case mwaCompare mwb mwb' s of { (# s, bb #) -> + case ba &&# bb of + 0# -> case unexpectedValue of + !_ -> s + -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives + _ -> s + }}}}}}}}}}}} + +mwaCompareOpBool + :: MutableWordArray# s + -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) + -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) + -> State# s + -> (# State# s, Bool# #) +mwaCompareOpBool mwa f g s = + case mwaSize# mwa s of { (# s, sz #) -> + case newWordArray# sz s of { (# s, mwb #) -> + case f mwa s of { (# s, ra #) -> + case g mwb s of { (# s, rb #) -> + case ra ==# rb of + 0# -> case unexpectedValue of + !_ -> (# s, ra #) + -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives + _ -> case ra of -- don't compare MWAs if underflow signaled! + 0# -> (# s, ra #) -- underflow + _ -> case mwaTrimZeroes# mwa s of { s -> + case mwaTrimZeroes# mwb s of { s -> + case mwaCompare mwa mwb s of + (# s, 0# #) -> case unexpectedValue of + !_ -> (# s, ra #) + -- see Note [ghc-bignum exceptions] in + -- GHC.Num.Primitives + _ -> (# s, ra #) + }}}}}} + +mwaCompareOpWord + :: MutableWordArray# s + -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) + -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) + -> State# s + -> (# State# s, Word# #) +mwaCompareOpWord mwa f g s = + case mwaSize# mwa s of { (# s, sz #) -> + case newWordArray# sz s of { (# s, mwb #) -> + case f mwa s of { (# s, ra #) -> + case g mwb s of { (# s, rb #) -> + case mwaTrimZeroes# mwa s of { s -> + case mwaTrimZeroes# mwb s of { s -> + case mwaCompare mwa mwb s of + (# s, b #) -> case b &&# (ra `eqWord#` rb) of + 0# -> case unexpectedValue of + !_ -> (# s, ra #) + -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives + _ -> (# s, ra #) + }}}}}} + +bignat_add + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_add mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_add m wa wb) + (\m -> Native.bignat_add m wa wb) + +bignat_add_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_add_word mwa wa b + = mwaCompareOp mwa + (\m -> Other.bignat_add_word m wa b) + (\m -> Native.bignat_add_word m wa b) + +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_mul_word mwa wa b + = mwaCompareOp mwa + (\m -> Other.bignat_mul_word m wa b) + (\m -> Native.bignat_mul_word m wa b) + +bignat_sub + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub mwa wa wb + = mwaCompareOpBool mwa + (\m -> Other.bignat_sub m wa wb) + (\m -> Native.bignat_sub m wa wb) + +bignat_sub_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub_word mwa wa b + = mwaCompareOpBool mwa + (\m -> Other.bignat_sub_word m wa b) + (\m -> Native.bignat_sub_word m wa b) + +bignat_mul + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_mul mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_mul m wa wb) + (\m -> Native.bignat_mul m wa wb) + +bignat_popcount :: WordArray# -> Word# +bignat_popcount wa = + let + gr = Other.bignat_popcount wa + nr = Native.bignat_popcount wa + in case gr `eqWord#` nr of + 0# -> 1## `quotWord#` 0## + _ -> gr + +bignat_shiftl + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftl mwa wa n + = mwaCompareOp mwa + (\m -> Other.bignat_shiftl m wa n) + (\m -> Native.bignat_shiftl m wa n) + +bignat_shiftr + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr mwa wa n + = mwaCompareOp mwa + (\m -> Other.bignat_shiftr m wa n) + (\m -> Native.bignat_shiftr m wa n) + +bignat_shiftr_neg + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr_neg mwa wa n + = mwaCompareOp mwa + (\m -> Other.bignat_shiftr_neg m wa n) + (\m -> Native.bignat_shiftr_neg m wa n) + +bignat_or + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_or mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_or m wa wb) + (\m -> Native.bignat_or m wa wb) + +bignat_xor + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_xor mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_xor m wa wb) + (\m -> Native.bignat_xor m wa wb) + +bignat_and + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_and mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_and m wa wb) + (\m -> Native.bignat_and m wa wb) + +bignat_and_not + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_and_not mwa wa wb + = mwaCompareOp mwa + (\m -> Other.bignat_and_not m wa wb) + (\m -> Native.bignat_and_not m wa wb) + +bignat_quotrem + :: MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quotrem mwq mwr wa wb + = mwaCompareOp2 mwq mwr + (\m1 m2 -> Other.bignat_quotrem m1 m2 wa wb) + (\m1 m2 -> Native.bignat_quotrem m1 m2 wa wb) + +bignat_quot + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quot mwq wa wb + = mwaCompareOp mwq + (\m -> Other.bignat_quot m wa wb) + (\m -> Native.bignat_quot m wa wb) + +bignat_rem + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_rem mwr wa wb + = mwaCompareOp mwr + (\m -> Other.bignat_rem m wa wb) + (\m -> Native.bignat_rem m wa wb) + +bignat_quotrem_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Word# #) +bignat_quotrem_word mwq wa b + = mwaCompareOpWord mwq + (\m -> Other.bignat_quotrem_word m wa b) + (\m -> Native.bignat_quotrem_word m wa b) + +bignat_quot_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_quot_word mwq wa b + = mwaCompareOp mwq + (\m -> Other.bignat_quot_word m wa b) + (\m -> Native.bignat_quot_word m wa b) + +bignat_rem_word + :: WordArray# + -> Word# + -> Word# +bignat_rem_word wa b = + let + gr = Other.bignat_rem_word wa b + nr = Native.bignat_rem_word wa b + in case gr `eqWord#` nr of + 1# -> gr + _ -> unexpectedValue_Word# (# #) + +bignat_gcd + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_gcd mwr wa wb + = mwaCompareOp mwr + (\m -> Other.bignat_gcd m wa wb) + (\m -> Native.bignat_gcd m wa wb) + +bignat_gcd_word + :: WordArray# + -> Word# + -> Word# +bignat_gcd_word wa b = + let + gr = Other.bignat_gcd_word wa b + nr = Native.bignat_gcd_word wa b + in case gr `eqWord#` nr of + 1# -> gr + _ -> unexpectedValue_Word# (# #) + +bignat_gcd_word_word + :: Word# + -> Word# + -> Word# +bignat_gcd_word_word a b = + let + gr = Other.bignat_gcd_word_word a b + nr = Native.bignat_gcd_word_word a b + in case gr `eqWord#` nr of + 1# -> gr + _ -> unexpectedValue_Word# (# #) + +bignat_encode_double :: WordArray# -> Int# -> Double# +bignat_encode_double a e = + let + gr = Other.bignat_encode_double a e + nr = Native.bignat_encode_double a e + in case gr ==## nr of + 1# -> gr + _ -> case unexpectedValue of + !_ -> 0.0## + -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives + +bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# +bignat_powmod_word b e m = + let + gr = Other.bignat_powmod_word b e m + nr = Native.bignat_powmod_word b e m + in case gr `eqWord#` nr of + 1# -> gr + _ -> unexpectedValue_Word# (# #) + +bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_powmod r b e m + = mwaCompareOp r + (\r' -> Other.bignat_powmod r' b e m) + (\r' -> Native.bignat_powmod r' b e m) + +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words b e m = + let + gr = Other.bignat_powmod_words b e m + nr = Native.bignat_powmod_words b e m + in case gr `eqWord#` nr of + 1# -> gr + _ -> unexpectedValue_Word# (# #) diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend/FFI.hs b/libraries/ghc-bignum/src/GHC/Num/Backend/FFI.hs new file mode 100644 index 0000000000..a049cfe332 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend/FFI.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | External BigNat backend that directly call FFI operations. +-- +-- This backend can be useful for specific compilers such as GHCJS or Asterius +-- that replace bignat foreign calls with calls to the native platform bignat +-- library (e.g. JavaScript's BigInt). You can also link an extra object +-- providing the implementation. +module GHC.Num.Backend.FFI where + +import GHC.Prim +import GHC.Types +import GHC.Num.WordArray +import GHC.Num.Primitives + +default () + +-- | Compare two non-zero BigNat of the same length +-- +-- Return: +-- < 0 ==> LT +-- == 0 ==> EQ +-- > 0 ==> GT +bignat_compare + :: WordArray# + -> WordArray# + -> Int# +bignat_compare = ghc_bignat_compare + +foreign import ccall unsafe ghc_bignat_compare + :: WordArray# + -> WordArray# + -> Int# + +-- | Add two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_add + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_add mwa wa wb s + = ioVoid (ghc_bignat_add mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_add + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> IO () + +-- | Add a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_add_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_add_word mwa wa b s = + ioVoid (ghc_bignat_add_word mwa wa b) s + +foreign import ccall unsafe ghc_bignat_add_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> IO () + +-- | Multiply a non-zero BigNat and a non-zero Word# +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + 1 +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_mul_word mwa wa b s = + ioVoid (ghc_bignat_mul_word mwa wa b) s + +foreign import ccall unsafe ghc_bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> IO () + +-- | Sub two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. +bignat_sub + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub mwa wa wb s = ioBool (ghc_bignat_sub mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_sub + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> IO Bool + +-- | Sub a non-zero word from a non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +-- +-- Return False# to indicate underflow. +bignat_sub_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +bignat_sub_word mwa wa b s = ioBool (ghc_bignat_sub_word mwa wa b) s + +foreign import ccall unsafe ghc_bignat_sub_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> IO Bool + +-- | Multiply two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a+size b +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_mul + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_mul mwa wa wb s = ioVoid (ghc_bignat_mul mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_mul + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> IO () + +-- | PopCount of a non-zero BigNat +bignat_popcount :: WordArray# -> Word# +bignat_popcount = ghc_bignat_popcount + +foreign import ccall unsafe ghc_bignat_popcount + :: WordArray# + -> Word# + +-- | Left-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a + required new limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_shiftl + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftl mwa wa n s = ioVoid (ghc_bignat_shiftl mwa wa n) s + +foreign import ccall unsafe ghc_bignat_shiftl + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> IO () + +-- | Right-shift a non-zero BigNat by a non-zero amount of bits +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Word (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_shiftr + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr mwa wa n s = ioVoid (ghc_bignat_shiftr mwa wa n) s + +foreign import ccall unsafe ghc_bignat_shiftr + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> IO () + +-- | Right-shift a non-zero BigNat by a non-zero amount of bits by first +-- converting it into its two's complement representation and then again after +-- the arithmetic shift. +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: required limbs +-- +-- The potential 0 most-significant Words (i.e. the potential carry) will be +-- removed by the caller if it is not already done by the backend. +bignat_shiftr_neg + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr_neg mwa wa n s = ioVoid (ghc_bignat_shiftr_neg mwa wa n) s + +foreign import ccall unsafe ghc_bignat_shiftr_neg + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> IO () + + +-- | OR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) +bignat_or + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_or #-} +bignat_or mwa wa wb s = ioVoid (ghc_bignat_or mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_or + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | XOR two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: max (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_xor + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_xor #-} +bignat_xor mwa wa wb s = ioVoid (ghc_bignat_xor mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_xor + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | AND two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: min (size a, size b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_and + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and #-} +bignat_and mwa wa wb s = ioVoid (ghc_bignat_and mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_and + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | ANDNOT two non-zero BigNat +-- +-- Result is to be stored in the MutableWordArray#. +-- The latter has size: size a +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_and_not + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and_not #-} +bignat_and_not mwa wa wb s = ioVoid (ghc_bignat_and_not mwa wa wb) s + +foreign import ccall unsafe ghc_bignat_and_not + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | QuotRem of two non-zero BigNat +-- +-- Result quotient and remainder are to be stored in the MutableWordArray#. +-- The first one (quotient) has size: size(A)-size(B)+1 +-- The second one (remainder) has size: size(b) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_quotrem + :: MutableWordArray# RealWorld -- ^ Quotient + -> MutableWordArray# RealWorld -- ^ Remainder + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quotrem mwq mwr wa wb s = + ioVoid (ghc_bignat_quotrem mwq mwr wa wb) s + +foreign import ccall unsafe ghc_bignat_quotrem + :: MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | Quotient of two non-zero BigNat +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A)-size(B)+1 +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_quot + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quot mwq wa wb s = + ioVoid (ghc_bignat_quot mwq wa wb) s + +foreign import ccall unsafe ghc_bignat_quot + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | Remainder of two non-zero BigNat +-- +-- Result remainder is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_rem + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_rem mwr wa wb s = + ioVoid (ghc_bignat_rem mwr wa wb) s + +foreign import ccall unsafe ghc_bignat_rem + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | QuotRem of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The remainder is returned. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_quotrem_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Word# #) +bignat_quotrem_word mwq wa b s = + ioWord# (ghc_bignat_quotrem_word mwq wa b) s + +foreign import ccall unsafe ghc_bignat_quotrem_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> IO Word + +-- | Quot of a non-zero BigNat and a non-zero Word +-- +-- Result quotient is to be stored in the MutableWordArray#. +-- The latter has size: size(A) +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_quot_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_quot_word mwq wa b s = + ioVoid (ghc_bignat_quot_word mwq wa b) s + +foreign import ccall unsafe ghc_bignat_quot_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> IO () + +-- | Remainder of a non-zero BigNat and a non-zero Word +-- +-- The remainder is returned. +bignat_rem_word + :: WordArray# + -> Word# + -> Word# +bignat_rem_word = ghc_bignat_rem_word + +foreign import ccall unsafe ghc_bignat_rem_word + :: WordArray# + -> Word# + -> Word# + + +-- | Greatest common divisor (GCD) of two non-zero and non-one BigNat +-- +-- Result GCD is to be stored in the MutableWordArray#. +-- The latter has size: size(B) +-- The first WordArray# is greater than the second WordArray#. +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_gcd + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_gcd mwr wa wb s = + ioVoid (ghc_bignat_gcd mwr wa wb) s + +foreign import ccall unsafe ghc_bignat_gcd + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> IO () + +-- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a +-- non-zero/non-one Word# +-- +-- Result GCD is returned +bignat_gcd_word + :: WordArray# + -> Word# + -> Word# +bignat_gcd_word = ghc_bignat_gcd_word + +foreign import ccall unsafe ghc_bignat_gcd_word + :: WordArray# + -> Word# + -> Word# + +-- | Greatest common divisor (GCD) of two Word# +-- +-- Result GCD is returned +bignat_gcd_word_word + :: Word# + -> Word# + -> Word# +bignat_gcd_word_word = ghc_bignat_gcd_word_word + +foreign import ccall unsafe ghc_bignat_gcd_word_word + :: Word# + -> Word# + -> Word# + +-- | Encode (# BigNat mantissa, Int# exponent #) into a Double# +bignat_encode_double :: WordArray# -> Int# -> Double# +bignat_encode_double = ghc_bignat_encode_double + +foreign import ccall unsafe ghc_bignat_encode_double + :: WordArray# + -> Int# + -> Double# + +-- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 +bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# +bignat_powmod_word = ghc_bignat_powmod_word + +foreign import ccall unsafe ghc_bignat_powmod_word + :: WordArray# -> WordArray# -> Word# -> Word# + +-- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 +-- +-- Result is to be stored in the MutableWordArray# (which size is equal to the +-- one of m). +-- +-- The potential 0 most-significant Words will be removed by the caller if it is +-- not already done by the backend. +bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_powmod r b e m s = + ioVoid (ghc_bignat_powmod r b e m) s + +foreign import ccall unsafe ghc_bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> IO () + +-- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to +-- exponent @/e/@ modulo @/m/@. +-- +-- b > 1 +-- e > 0 +-- m > 1 +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words = ghc_bignat_powmod_words + +foreign import ccall unsafe ghc_bignat_powmod_words + :: Word# -> Word# -> Word# -> Word# + diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend/GMP.hs b/libraries/ghc-bignum/src/GHC/Num/Backend/GMP.hs new file mode 100644 index 0000000000..a340db573e --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend/GMP.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE BlockArguments #-} + +-- | Backend based on the GNU GMP library. +-- +-- This has been adapted from the legacy `integer-gmp` package written by +-- Herbert Valerio Riedel. +module GHC.Num.Backend.GMP where + +#include "MachDeps.h" +#include "WordSize.h" + +import GHC.Num.WordArray +import GHC.Num.Primitives +import GHC.Prim +import GHC.Types + +default () + +---------------------------------------------------------------------------- +-- type definitions + +-- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS +-- The C99 code in cbits/gmp_wrappers.c will fail to compile if this doesn't hold + +-- | Type representing a GMP Limb +type GmpLimb = Word -- actually, 'CULong' +type GmpLimb# = Word# + +-- | Count of 'GmpLimb's, must be positive (unless specified otherwise). +type GmpSize = Int -- actually, a 'CLong' +type GmpSize# = Int# + +narrowGmpSize# :: Int# -> Int# +#if SIZEOF_LONG == SIZEOF_HSWORD +narrowGmpSize# x = x +#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) +-- On IL32P64 (i.e. Win64), we have to be careful with CLong not being +-- 64bit. This is mostly an issue on values returned from C functions +-- due to sign-extension. +narrowGmpSize# = narrow32Int# +#endif + +narrowCInt# :: Int# -> Int# +narrowCInt# = narrow32Int# + +bignat_compare :: WordArray# -> WordArray# -> Int# +bignat_compare x y = narrowCInt# (c_mpn_cmp x y (wordArraySize# x)) + +bignat_add + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_add #-} +bignat_add mwa wa wb s + -- weird GMP requirement + | isTrue# (wordArraySize# wb ># wordArraySize# wa) + = bignat_add mwa wb wa s + + | True + = do + case ioWord# (c_mpn_add mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_add_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_add_word #-} +bignat_add_word mwa wa b s = do + case ioWord# (c_mpn_add_1 mwa wa (wordArraySize# wa) b) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_sub + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +{-# INLINE bignat_sub #-} +bignat_sub mwa wa wb s = + case ioWord# (c_mpn_sub mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', 1## #) -> (# s', 0# #) -- underflow + (# s', _ #) -> (# s', 1# #) -- no underflow + +bignat_sub_word + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Bool# #) +{-# INLINE bignat_sub_word #-} +bignat_sub_word mwa wa b s = + case ioWord# (c_mpn_sub_1 mwa wa (wordArraySize# wa) b) s of + (# s', 1## #) -> (# s', 0# #) -- underflow + (# s', _ #) -> (# s', 1# #) -- no underflow + +bignat_mul + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_mul #-} +bignat_mul mwa wa wb s = do + case ioWord# (c_mpn_mul mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_mul_word #-} +bignat_mul_word mwa wa b s = + case ioWord# (c_mpn_mul_1 mwa wa (wordArraySize# wa) b) s of + (# s', c #) -> mwaWriteMostSignificant mwa c s' + +bignat_popcount :: WordArray# -> Word# +{-# INLINE bignat_popcount #-} +bignat_popcount wa = c_mpn_popcount wa (wordArraySize# wa) + + +bignat_shiftl + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_shiftl #-} +bignat_shiftl mwa wa n s = + case ioWord# (c_mpn_lshift mwa wa (wordArraySize# wa) n) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_shiftr + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_shiftr #-} +bignat_shiftr mwa wa n s = + case ioWord# (c_mpn_rshift mwa wa (wordArraySize# wa) n) s of + (# s', _msl #) -> s' -- we don't care about the most-significant + -- limb. The caller shrink the mwa if + -- necessary anyway. + +bignat_or + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_or #-} +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 + -- nx >= ny + go wx nx wy ny s = case ioVoid (c_mpn_ior_n mwa wx wy ny) s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_xor + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_xor #-} +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 + -- nx >= ny + go wx nx wy ny s = case ioVoid (c_mpn_xor_n mwa wx wy ny) s of + s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' + +bignat_and + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and #-} +bignat_and mwa wa wb s = ioVoid (c_mpn_and_n mwa wa wb sz) s + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !sz = minI# szA szB + +bignat_and_not + :: MutableWordArray# RealWorld -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +{-# INLINE bignat_and_not #-} +bignat_and_not mwa wa wb s = + case ioVoid (c_mpn_andn_n mwa wa wb n) s of + s' -> mwaArrayCopy# mwa szB wa szB (szA -# szB) s' + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !n = minI# szA szB + +bignat_quotrem + :: MutableWordArray# RealWorld + -> MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quotrem mwq mwr wa wb s = + ioVoid (c_mpn_tdiv_qr mwq mwr 0# wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_quot + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_quot mwq wa wb s = + ioVoid (c_mpn_tdiv_q mwq wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_rem + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_rem mwr wa wb s = + ioVoid (c_mpn_tdiv_r mwr wa szA wb szB) s + where + szA = wordArraySize# wa + szB = wordArraySize# wb + +bignat_quotrem_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> (# State# RealWorld, Word# #) +bignat_quotrem_word mwq wa b s = + ioWord# (c_mpn_divrem_1 mwq 0# wa szA b) s + where + szA = wordArraySize# wa + +bignat_quot_word + :: MutableWordArray# RealWorld -- ^ Quotient + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_quot_word mwq wa b s = + case bignat_quotrem_word mwq wa b s of + (# s', _ #) -> s' + +bignat_rem_word + :: WordArray# + -> Word# + -> Word# +bignat_rem_word wa b = + c_mpn_mod_1 wa (wordArraySize# wa) b + + +bignat_gcd + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_gcd mwr wa wb s = + -- wa > wb + case ioInt# (c_mpn_gcd# mwr wa (wordArraySize# wa) wb (wordArraySize# wb)) s of + (# s', sz #) -> mwaSetSize# mwr (narrowGmpSize# sz) s' + +bignat_gcd_word + :: WordArray# + -> Word# + -> Word# +bignat_gcd_word wa b = c_mpn_gcd_1# wa (wordArraySize# wa) b + +bignat_gcd_word_word + :: Word# + -> Word# + -> Word# +bignat_gcd_word_word = integer_gmp_gcd_word + + +bignat_encode_double :: WordArray# -> Int# -> Double# +bignat_encode_double wa e = c_mpn_get_d wa (wordArraySize# wa) e + +bignat_shiftr_neg + :: MutableWordArray# RealWorld + -> WordArray# + -> Word# + -> State# RealWorld + -> State# RealWorld +bignat_shiftr_neg mwa wa n s = + ioVoid (c_mpn_rshift_2c mwa wa (wordArraySize# wa) n) s + +bignat_powmod_word + :: WordArray# + -> WordArray# + -> Word# + -> Word# +bignat_powmod_word b e m = + integer_gmp_powm1# b (wordArraySize# b) e (wordArraySize# e) m + +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words = integer_gmp_powm_word + +bignat_powmod + :: MutableWordArray# RealWorld + -> WordArray# + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_powmod r b e m s = + case ioInt# (integer_gmp_powm# r b (wordArraySize# b) e (wordArraySize# e) m (wordArraySize# m)) s of + (# s', n #) -> mwaSetSize# r (narrowGmpSize# n) s' + + +---------------------------------------------------------------------- +-- FFI ccall imports + +foreign import ccall unsafe "integer_gmp_gcd_word" + integer_gmp_gcd_word :: GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd_1" + c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd" + c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +foreign import ccall unsafe "integer_gmp_gcdext" + integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s + -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +-- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_add_1" + c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_sub_1" + c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mul_1" + c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_add" + c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_sub" + c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_mul" + c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_cmp" + c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> Int# + +-- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, +-- const mp_limb_t *np, mp_size_t nn, +-- const mp_limb_t *dp, mp_size_t dn) +foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" + c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" + c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" + c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +-- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, +-- mp_size_t s2n, mp_limb_t s3limb) +foreign import ccall unsafe "gmp.h __gmpn_divrem_1" + c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> IO GmpLimb + +-- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mod_1" + c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift" + c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" + c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_lshift" + c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# + -> IO GmpLimb + +-- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_and_n" + c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_andn_n" + c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_ior_n" + c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "integer_gmp_mpn_xor_n" + c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_popcount" + c_mpn_popcount :: ByteArray# -> GmpSize# -> Word# + +-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) +foreign import ccall unsafe "integer_gmp_mpn_get_d" + c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# + +foreign import ccall unsafe "integer_gmp_powm" + integer_gmp_powm# :: MutableByteArray# RealWorld + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +foreign import ccall unsafe "integer_gmp_powm_word" + integer_gmp_powm_word :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_powm1" + integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> GmpLimb# diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs b/libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs new file mode 100644 index 0000000000..1169af41d6 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE BinaryLiterals #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +module GHC.Num.Backend.Native where + +#include "MachDeps.h" +#include "WordSize.h" + +#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) +import {-# SOURCE #-} GHC.Num.BigNat +import {-# SOURCE #-} GHC.Num.Natural +#else +import GHC.Num.BigNat +import GHC.Num.Natural +#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 -- ^ Result + -> 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 + + -- we have four cases: + -- 1) we have a digit in A and in B + a potential carry + -- => perform triple addition + -- => result in (carry,word) + -- 2) we have a digit only in A or B and a carry + -- => perform double addition from a single array + -- => result in (carry,word) + -- 3) we have a digit only in A or B and no carry + -- => perform array copy and shrink the array + -- 4) We only have a potential carry + -- => write the carry or shrink the array + + 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 + = -- copy the remaining words and remove the word allocated for the + -- potential 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 -- ^ Result + -> 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# #) -- no underflow + + | True + = case subWordC# (indexWordArray# wa i) carry of + (# 0##, 0# #) + | isTrue# (i ==# sz) -> case mwaShrink# mwa 1# s of + s' -> (# s', 1# #) -- no underflow + + (# l , c #) -> case mwaWrite# mwa i l s of + s1 -> go (int2Word# c) (i +# 1#) s1 + +bignat_mul_word + :: MutableWordArray# RealWorld -- ^ Result + -> 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 -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_mul mwa wa wb s1 = + -- initialize the resulting WordArray + case mwaFill# mwa 0## 0## (int2Word# sz) s1 of + s' -> mulEachB ctzB s' -- loop on b Words + where + !szA = wordArraySize# wa + !szB = wordArraySize# wb + !sz = szA +# szB + + !ctzA = word2Int# (bigNatCtzWord# wa) + !ctzB = word2Int# (bigNatCtzWord# wb) + + -- multiply a single bj Word# to the whole wa WordArray + mul bj j i carry s + | isTrue# (i ==# szA) + -- write the carry + = 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' + + -- for each bj in wb, call `mul bj wa` + mulEachB i s + | isTrue# (i ==# szB) = s + | True = case indexWordArray# wb i of + -- detect bj == 0## and skip the loop + 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 = + -- initialize the resulting WordArray + -- Note: we could avoid the copy by subtracting the first non-zero + -- less-significant word of b... + 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 = + -- set the lower words to 0 + 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 + + -- Bit granularity (c is the carry from the previous shift) + mwaBitShift i c s + -- write the carry + | 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 + + -- Bit granularity (c is the carry from the previous shift) + 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 + -- initialize higher limb + = case mwaWrite# mwa (szA -# 1#) 0## s1 of + s2 -> case bignat_shiftr mwa wa n s2 of + s3 -> if nz_shifted_out + -- round if non-zero bits were shifted out + then mwaAddInplaceWord# mwa 0# 1## s3 + else s3 + where + !szA = wordArraySize# wa + !(# nw, nb #) = count_words_bits_int n + + -- non-zero bits are shifted out? + nz_shifted_out + -- test nb bits + | isTrue# ( + (nb /=# 0#) + &&# (indexWordArray# wa nw `uncheckedShiftL#` + (WORD_SIZE_IN_BITS# -# nb) `neWord#` 0##)) + = True + -- test nw words + | 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 -- ^ Result + -> 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 + -- nx >= ny + 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 -- ^ Result + -> 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 + -- nx >= ny + 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 -- ^ Result + -> WordArray# + -> WordArray# + -> State# RealWorld + -> State# RealWorld +bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s + +bignat_and_not + :: MutableWordArray# RealWorld -- ^ Result + -> 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 = + -- Normalization consists in left-shifting bits in B and A so that the + -- most-significant bit of the most-significant word of B is 1. It makes + -- quotient prediction much more efficient as we only use the two most + -- significant words of A and the most significant word of B to make the + -- prediction. + + -- we will left-shift A and B of "clzb" bits for normalization + let !clzb = clz# (indexWordArray# uwb (wordArraySize# uwb -# 1#)) + + -- we use a single array initially containing A (normalized) and + -- returning the remainder (normalized): mnwa (for "mutable normalized + -- wordarray A") + -- + -- We allocate it here with an additionnal Word compared to A because + -- normalizing can left shift at most (N-1) bits (on N-bit arch). + in case newWordArray# (wordArraySize# uwa +# 1#) s0 of { (# s1, mnwa #) -> + + -- normalized A in mnwa + let normalizeA s = case mwaWrite# mnwa (wordArraySize# uwa) 0## s of -- init potential carry + s -> case bignat_shiftl mnwa uwa clzb s of -- left shift + s -> mwaTrimZeroes# mnwa s -- remove null carry if any + in case normalizeA s1 of { s2 -> + + -- normalize B. We don't do it in a MutableWordArray because it will remain + -- constant during the whole computation. + let !nwb = bigNatShiftL# uwb clzb in + + -- perform quotrem on normalized inputs + case bignat_quotrem_normalized mwq mnwa nwb s2 of { s3 -> + + -- denormalize the remainder now stored in mnwa. We just have to right shift + -- of "clzb" bits. We copy the result into "mwr" array. + 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 = + -- allocate a temporary array for the remainder and call quotrem + 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 = + -- allocate a temporary array for the quotient and call quotrem + -- (we could avoid allocating it as it is not used to compute the result but + -- it would require non trivial modification of bignat_quotrem) + 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 + +-- | Perform quotRem on normalized inputs: +-- * highest bit of B is set +-- * A is trimmed +-- * A >= B +-- * B > 1 +bignat_quotrem_normalized + :: MutableWordArray# s + -> MutableWordArray# s + -> WordArray# + -> State# s + -> State# s +bignat_quotrem_normalized mwq mwa b s0 = + + -- n is the size of B + let !n = wordArraySize# b + + -- m+n is the size of A (m >= 0) + in case mwaSize# mwa s0 of { (# s1, szA #) -> + let !m = szA -# n in + + -- Definitions: + -- MSW(x) is the most-significant word of x + -- MSB(x) the most-significant bit of x + + -- We first compute MSW(Q). Thanks to the normalization of B, MSW(Q) can + -- only be 0 or 1 so we only have to perform a prefix comparison to compute + -- MSW(Q). + -- + -- Proof MSW(Q) < 2: + -- * MSB(MSW(B)) = 1 thanks to normalization. + -- * MSW(B) * MSW(Q) <= MSW(A) by definition + -- * suppose MSW(Q) >= 2: + -- MSW(B) * MSW(Q) >= MSW(B) << 1 { MSW(Q) >= 2 } + -- > MAX_WORD_VALUE { MSB(MSW(B)) = 1 } + -- > MSW(A) { MSW(A) <= MAX_WORD_VALUE } + -- contradiction. + -- + -- If A >= (B << m words) + -- then Qm = 1 + -- A := A - (B << m words) + -- else Qm = 0 + -- A unchanged + 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 -- write Qj + s | 0## <- qj -> s + | True -> case mwaSubInplaceArray mwa j qjb s of -- subtract (qjB << j words) + (# s, _ #) -> s + + -- update the highest word of Q + updateQm s = case computeQm s of + (# s, qm #) -> updateQj m qm b s + + -- the size of Q is szA+szB+1 BEFORE normalization. Normalization may add + -- an additional higher word to A. + -- * If A has an additional limb: + -- * MSW(A) < MSW(B). Because MSB(MSW(A)) can't be set (it would + -- mean that we shifted a whole word, which we didn't) + -- * hence MSW(Q) = 0 but we don't have to write it (and we mustn't) + -- because of the size of Q + -- * If A has no additional limb: + -- * We have to check if MSW(A) >= MSW(B) and to adjust A and MSW(Q) + -- accordingly + -- + -- We detect if A has an additional limb by comparing the size of Q with m + updateQmMaybe s = case mwaSize# mwq s of + (# s, szQ #) | isTrue# (m <# szQ) -> updateQm s + | True -> s + + in case updateQmMaybe s1 of { s2 -> + + + -- main loop: for j from (m-1) downto 0 + -- We estimate a one Word quotient qj: + -- e1e0 <- a(n+j)a(n+j-1) `div` b(n-1) + -- qj | e1 == 0 = e0 + -- | otherwise = maxBound + -- We loop until we find the real quotient: + -- while (A < ((qj*B) << j words)) qj-- + -- We update A and Qj: + -- Qj := qj + -- A := A - (qj*B << j words) + + let bmsw = wordArrayLast# b -- most significant word of 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## #) + + -- we perform the qj*B multiplication once and then we subtract B from + -- qj*B as much as needed until (qj'*B << j words) <= A + 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 + -- TODO: we could do the sub inplace to + -- reduce allocations + (# 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 -- ^ Quotient + -> 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 -- ^ Quotient + -> 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) + +-- | This operation doesn't really belongs here, but GMP's one is much faster +-- than this simple implementation (basic Euclid algorithm). +-- +-- Ideally we should make an implementation as fast as GMP's one and put it into +-- GHC.Num.Primitives. +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#) -- FIXME: we assume that e doesn't overflow... + (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## -- slightly faster than "e `div` 2" + +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## -- slightly faster than "e `div` 2" + +bignat_powmod_words + :: Word# + -> Word# + -> Word# + -> Word# +bignat_powmod_words b e m = + bignat_powmod_word (wordArrayFromWord# b) + (wordArrayFromWord# e) + m diff --git a/libraries/ghc-bignum/src/GHC/Num/Backend/Selected.hs b/libraries/ghc-bignum/src/GHC/Num/Backend/Selected.hs new file mode 100644 index 0000000000..f0ffd86220 --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/Backend/Selected.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Selected backend +-- +-- We need this module in addition to GHC.Num.Backend to avoid module loops with +-- Check backend. +module GHC.Num.Backend.Selected + ( module Backend + ) +where + +#if defined(BIGNUM_NATIVE) +import GHC.Num.Backend.Native as Backend + +#elif defined(BIGNUM_FFI) +import GHC.Num.Backend.FFI as Backend + +#elif defined(BIGNUM_GMP) +import GHC.Num.Backend.GMP as Backend + +#else +#error Undefined BigNum backend. Use a flag to select it (e.g. gmp, native, ffi)` +#endif diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs index e38c807ede..f2d9e58e17 100644 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs @@ -23,27 +23,12 @@ import GHC.Classes import GHC.Magic import GHC.Num.Primitives import GHC.Num.WordArray +import GHC.Num.Backend #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 #endif -#if defined(BIGNUM_CHECK) -import GHC.Num.BigNat.Check - -#elif defined(BIGNUM_NATIVE) -import GHC.Num.BigNat.Native - -#elif defined(BIGNUM_FFI) -import GHC.Num.BigNat.FFI - -#elif defined(BIGNUM_GMP) -import GHC.Num.BigNat.GMP - -#else -#error Undefined BigNat backend. Use a flag to select it (e.g. gmp, native, ffi)` -#endif - default () -- | A BigNat diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs deleted file mode 100644 index 8431a5564d..0000000000 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | Check Native implementation against another backend -module GHC.Num.BigNat.Check where - -import GHC.Prim -import GHC.Types -import GHC.Num.WordArray -import GHC.Num.Primitives -import qualified GHC.Num.BigNat.Native as Native - -#if defined(BIGNUM_NATIVE) -#error You can't validate Native backed against itself. Choose another backend (e.g. gmp, ffi) - -#elif defined(BIGNUM_FFI) -import qualified GHC.Num.BigNat.FFI as Other - -#elif defined(BIGNUM_GMP) -import qualified GHC.Num.BigNat.GMP as Other - -#else -#error Undefined BigNat backend. Use a flag to select it (e.g. gmp, native, ffi)` -#endif - -default () - -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare a b = - let - gr = Other.bignat_compare a b - nr = Native.bignat_compare a b - in case gr ==# nr of - 0# -> unexpectedValue_Int# (# #) - _ -> gr - -mwaCompare - :: MutableWordArray# s - -> MutableWordArray# s - -> State# s - -> (# State# s, Bool# #) -mwaCompare mwa mwb s = - case mwaSize# mwa s of - (# s, szA #) -> case mwaSize# mwb s of - (# s, szB #) -> case szA ==# szB of - 0# -> (# s, 0# #) - _ -> let - go i s - | isTrue# (i <# 0#) = (# s, 1# #) - | True = - case readWordArray# mwa i s of - (# s, a #) -> case readWordArray# mwb i s of - (# s, b #) -> case a `eqWord#` b of - 0# -> (# s, 0# #) - _ -> go (i -# 1#) s - in go (szA -# 1#) s - -mwaCompareOp - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { s -> - case g mwb s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - (# s, _ #) -> s - }}}}}} - -mwaCompareOp2 - :: MutableWordArray# s - -> MutableWordArray# s - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> (MutableWordArray# s -> MutableWordArray# s -> State# s -> State# s) - -> State# s - -> State# s -mwaCompareOp2 mwa mwb f g s = - case mwaSize# mwa s of { (# s, szA #) -> - case mwaSize# mwb s of { (# s, szB #) -> - case newWordArray# szA s of { (# s, mwa' #) -> - case newWordArray# szB s of { (# s, mwb' #) -> - case f mwa mwb s of { s -> - case g mwa' mwb' s of { s -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaTrimZeroes# mwa' s of { s -> - case mwaTrimZeroes# mwb' s of { s -> - case mwaCompare mwa mwa' s of { (# s, ba #) -> - case mwaCompare mwb mwb' s of { (# s, bb #) -> - case ba &&# bb of - 0# -> case unexpectedValue of - !_ -> s - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> s - }}}}}}}}}}}} - -mwaCompareOpBool - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Bool# #)) - -> State# s - -> (# State# s, Bool# #) -mwaCompareOpBool mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case ra ==# rb of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> case ra of -- don't compare MWAs if underflow signaled! - 0# -> (# s, ra #) -- underflow - _ -> case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, 0# #) -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in - -- GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -mwaCompareOpWord - :: MutableWordArray# s - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> (MutableWordArray# s -> State# s -> (#State# s, Word# #)) - -> State# s - -> (# State# s, Word# #) -mwaCompareOpWord mwa f g s = - case mwaSize# mwa s of { (# s, sz #) -> - case newWordArray# sz s of { (# s, mwb #) -> - case f mwa s of { (# s, ra #) -> - case g mwb s of { (# s, rb #) -> - case mwaTrimZeroes# mwa s of { s -> - case mwaTrimZeroes# mwb s of { s -> - case mwaCompare mwa mwb s of - (# s, b #) -> case b &&# (ra `eqWord#` rb) of - 0# -> case unexpectedValue of - !_ -> (# s, ra #) - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - _ -> (# s, ra #) - }}}}}} - -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_add m wa wb) - (\m -> Native.bignat_add m wa wb) - -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_add_word m wa b) - (\m -> Native.bignat_add_word m wa b) - -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b - = mwaCompareOp mwa - (\m -> Other.bignat_mul_word m wa b) - (\m -> Native.bignat_mul_word m wa b) - -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub m wa wb) - (\m -> Native.bignat_sub m wa wb) - -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b - = mwaCompareOpBool mwa - (\m -> Other.bignat_sub_word m wa b) - (\m -> Native.bignat_sub_word m wa b) - -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_mul m wa wb) - (\m -> Native.bignat_mul m wa wb) - -bignat_popcount :: WordArray# -> Word# -bignat_popcount wa = - let - gr = Other.bignat_popcount wa - nr = Native.bignat_popcount wa - in case gr `eqWord#` nr of - 0# -> 1## `quotWord#` 0## - _ -> gr - -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftl m wa n) - (\m -> Native.bignat_shiftl m wa n) - -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr m wa n) - (\m -> Native.bignat_shiftr m wa n) - -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n - = mwaCompareOp mwa - (\m -> Other.bignat_shiftr_neg m wa n) - (\m -> Native.bignat_shiftr_neg m wa n) - -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_or mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_or m wa wb) - (\m -> Native.bignat_or m wa wb) - -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_xor mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_xor m wa wb) - (\m -> Native.bignat_xor m wa wb) - -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and m wa wb) - (\m -> Native.bignat_and m wa wb) - -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and_not mwa wa wb - = mwaCompareOp mwa - (\m -> Other.bignat_and_not m wa wb) - (\m -> Native.bignat_and_not m wa wb) - -bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb - = mwaCompareOp2 mwq mwr - (\m1 m2 -> Other.bignat_quotrem m1 m2 wa wb) - (\m1 m2 -> Native.bignat_quotrem m1 m2 wa wb) - -bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb - = mwaCompareOp mwq - (\m -> Other.bignat_quot m wa wb) - (\m -> Native.bignat_quot m wa wb) - -bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_rem m wa wb) - (\m -> Native.bignat_rem m wa wb) - -bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b - = mwaCompareOpWord mwq - (\m -> Other.bignat_quotrem_word m wa b) - (\m -> Native.bignat_quotrem_word m wa b) - -bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b - = mwaCompareOp mwq - (\m -> Other.bignat_quot_word m wa b) - (\m -> Native.bignat_quot_word m wa b) - -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word wa b = - let - gr = Other.bignat_rem_word wa b - nr = Native.bignat_rem_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb - = mwaCompareOp mwr - (\m -> Other.bignat_gcd m wa wb) - (\m -> Native.bignat_gcd m wa wb) - -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word wa b = - let - gr = Other.bignat_gcd_word wa b - nr = Native.bignat_gcd_word wa b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word a b = - let - gr = Other.bignat_gcd_word_word a b - nr = Native.bignat_gcd_word_word a b - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double a e = - let - gr = Other.bignat_encode_double a e - nr = Native.bignat_encode_double a e - in case gr ==## nr of - 1# -> gr - _ -> case unexpectedValue of - !_ -> 0.0## - -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives - -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word b e m = - let - gr = Other.bignat_powmod_word b e m - nr = Native.bignat_powmod_word b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) - -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m - = mwaCompareOp r - (\r' -> Other.bignat_powmod r' b e m) - (\r' -> Native.bignat_powmod r' b e m) - -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words b e m = - let - gr = Other.bignat_powmod_words b e m - nr = Native.bignat_powmod_words b e m - in case gr `eqWord#` nr of - 1# -> gr - _ -> unexpectedValue_Word# (# #) diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs deleted file mode 100644 index cfd96be7a0..0000000000 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat/FFI.hs +++ /dev/null @@ -1,581 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE ForeignFunctionInterface #-} - --- | External BigNat backend that directly call FFI operations. --- --- This backend can be useful for specific compilers such as GHCJS or Asterius --- that replace bignat foreign calls with calls to the native platform bignat --- library (e.g. JavaScript's BigInt). You can also link an extra object --- providing the implementation. -module GHC.Num.BigNat.FFI where - -import GHC.Prim -import GHC.Types -import GHC.Num.WordArray -import GHC.Num.Primitives - -default () - --- | Compare two non-zero BigNat of the same length --- --- Return: --- < 0 ==> LT --- == 0 ==> EQ --- > 0 ==> GT -bignat_compare - :: WordArray# - -> WordArray# - -> Int# -bignat_compare = ghc_bignat_compare - -foreign import ccall unsafe ghc_bignat_compare - :: WordArray# - -> WordArray# - -> Int# - --- | Add two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_add mwa wa wb s - = ioVoid (ghc_bignat_add mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_add - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | Add a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_add_word mwa wa b s = - ioVoid (ghc_bignat_add_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_add_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Multiply a non-zero BigNat and a non-zero Word# --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + 1 --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_mul_word mwa wa b s = - ioVoid (ghc_bignat_mul_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO () - --- | Sub two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub mwa wa wb s = ioBool (ghc_bignat_sub mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_sub - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO Bool - --- | Sub a non-zero word from a non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. --- --- Return False# to indicate underflow. -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -bignat_sub_word mwa wa b s = ioBool (ghc_bignat_sub_word mwa wa b) s - -foreign import ccall unsafe ghc_bignat_sub_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> IO Bool - --- | Multiply two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a+size b --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb s = ioVoid (ghc_bignat_mul mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_mul - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> IO () - --- | PopCount of a non-zero BigNat -bignat_popcount :: WordArray# -> Word# -bignat_popcount = ghc_bignat_popcount - -foreign import ccall unsafe ghc_bignat_popcount - :: WordArray# - -> Word# - --- | Left-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a + required new limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftl mwa wa n s = ioVoid (ghc_bignat_shiftl mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Word (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr mwa wa n s = ioVoid (ghc_bignat_shiftr mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Right-shift a non-zero BigNat by a non-zero amount of bits by first --- converting it into its two's complement representation and then again after --- the arithmetic shift. --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: required limbs --- --- The potential 0 most-significant Words (i.e. the potential carry) will be --- removed by the caller if it is not already done by the backend. -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n s = ioVoid (ghc_bignat_shiftr_neg mwa wa n) s - -foreign import ccall unsafe ghc_bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - - --- | OR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_or #-} -bignat_or mwa wa wb s = ioVoid (ghc_bignat_or mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | XOR two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: max (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_xor #-} -bignat_xor mwa wa wb s = ioVoid (ghc_bignat_xor mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | AND two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: min (size a, size b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and #-} -bignat_and mwa wa wb s = ioVoid (ghc_bignat_and mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | ANDNOT two non-zero BigNat --- --- Result is to be stored in the MutableWordArray#. --- The latter has size: size a --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and_not #-} -bignat_and_not mwa wa wb s = ioVoid (ghc_bignat_and_not mwa wa wb) s - -foreign import ccall unsafe ghc_bignat_and_not - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of two non-zero BigNat --- --- Result quotient and remainder are to be stored in the MutableWordArray#. --- The first one (quotient) has size: size(A)-size(B)+1 --- The second one (remainder) has size: size(b) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem - :: MutableWordArray# RealWorld -- ^ Quotient - -> MutableWordArray# RealWorld -- ^ Remainder - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb s = - ioVoid (ghc_bignat_quotrem mwq mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Quotient of two non-zero BigNat --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A)-size(B)+1 --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb s = - ioVoid (ghc_bignat_quot mwq wa wb) s - -foreign import ccall unsafe ghc_bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Remainder of two non-zero BigNat --- --- Result remainder is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_rem - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb s = - ioVoid (ghc_bignat_rem mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | QuotRem of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The remainder is returned. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quotrem_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b s = - ioWord# (ghc_bignat_quotrem_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quotrem_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO Word - --- | Quot of a non-zero BigNat and a non-zero Word --- --- Result quotient is to be stored in the MutableWordArray#. --- The latter has size: size(A) --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_quot_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b s = - ioVoid (ghc_bignat_quot_word mwq wa b) s - -foreign import ccall unsafe ghc_bignat_quot_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> IO () - --- | Remainder of a non-zero BigNat and a non-zero Word --- --- The remainder is returned. -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word = ghc_bignat_rem_word - -foreign import ccall unsafe ghc_bignat_rem_word - :: WordArray# - -> Word# - -> Word# - - --- | Greatest common divisor (GCD) of two non-zero and non-one BigNat --- --- Result GCD is to be stored in the MutableWordArray#. --- The latter has size: size(B) --- The first WordArray# is greater than the second WordArray#. --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb s = - ioVoid (ghc_bignat_gcd mwr wa wb) s - -foreign import ccall unsafe ghc_bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> IO () - --- | Greatest common divisor (GCD) of a non-zero/non-one BigNat and a --- non-zero/non-one Word# --- --- Result GCD is returned -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word = ghc_bignat_gcd_word - -foreign import ccall unsafe ghc_bignat_gcd_word - :: WordArray# - -> Word# - -> Word# - --- | Greatest common divisor (GCD) of two Word# --- --- Result GCD is returned -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word = ghc_bignat_gcd_word_word - -foreign import ccall unsafe ghc_bignat_gcd_word_word - :: Word# - -> Word# - -> Word# - --- | Encode (# BigNat mantissa, Int# exponent #) into a Double# -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double = ghc_bignat_encode_double - -foreign import ccall unsafe ghc_bignat_encode_double - :: WordArray# - -> Int# - -> Double# - --- | \"@'bignat_powmod_word' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word# -bignat_powmod_word = ghc_bignat_powmod_word - -foreign import ccall unsafe ghc_bignat_powmod_word - :: WordArray# -> WordArray# -> Word# -> Word# - --- | \"@'bignat_powmod' r /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 --- --- Result is to be stored in the MutableWordArray# (which size is equal to the --- one of m). --- --- The potential 0 most-significant Words will be removed by the caller if it is --- not already done by the backend. -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m s = - ioVoid (ghc_bignat_powmod r b e m) s - -foreign import ccall unsafe ghc_bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> IO () - --- | \"@'bignat_powmod' /b/ /e/ /m/@\" computes base @/b/@ raised to --- exponent @/e/@ modulo @/m/@. --- --- b > 1 --- e > 0 --- m > 1 -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words = ghc_bignat_powmod_words - -foreign import ccall unsafe ghc_bignat_powmod_words - :: Word# -> Word# -> Word# -> Word# - diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs deleted file mode 100644 index 35d3983313..0000000000 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat/GMP.hs +++ /dev/null @@ -1,499 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE BlockArguments #-} - --- | Backend based on the GNU GMP library. --- --- This has been adapted from the legacy `integer-gmp` package written by --- Herbert Valerio Riedel. -module GHC.Num.BigNat.GMP where - -#include "MachDeps.h" -#include "WordSize.h" - -import GHC.Num.WordArray -import GHC.Num.Primitives -import GHC.Prim -import GHC.Types - -default () - ----------------------------------------------------------------------------- --- type definitions - --- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS --- The C99 code in cbits/gmp_wrappers.c will fail to compile if this doesn't hold - --- | Type representing a GMP Limb -type GmpLimb = Word -- actually, 'CULong' -type GmpLimb# = Word# - --- | Count of 'GmpLimb's, must be positive (unless specified otherwise). -type GmpSize = Int -- actually, a 'CLong' -type GmpSize# = Int# - -narrowGmpSize# :: Int# -> Int# -#if SIZEOF_LONG == SIZEOF_HSWORD -narrowGmpSize# x = x -#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) --- On IL32P64 (i.e. Win64), we have to be careful with CLong not being --- 64bit. This is mostly an issue on values returned from C functions --- due to sign-extension. -narrowGmpSize# = narrow32Int# -#endif - -narrowCInt# :: Int# -> Int# -narrowCInt# = narrow32Int# - -bignat_compare :: WordArray# -> WordArray# -> Int# -bignat_compare x y = narrowCInt# (c_mpn_cmp x y (wordArraySize# x)) - -bignat_add - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_add #-} -bignat_add mwa wa wb s - -- weird GMP requirement - | isTrue# (wordArraySize# wb ># wordArraySize# wa) - = bignat_add mwa wb wa s - - | True - = do - case ioWord# (c_mpn_add mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of - (# s', c #) -> mwaWriteMostSignificant mwa c s' - -bignat_add_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_add_word #-} -bignat_add_word mwa wa b s = do - case ioWord# (c_mpn_add_1 mwa wa (wordArraySize# wa) b) s of - (# s', c #) -> mwaWriteMostSignificant mwa c s' - -bignat_sub - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -{-# INLINE bignat_sub #-} -bignat_sub mwa wa wb s = - case ioWord# (c_mpn_sub mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of - (# s', 1## #) -> (# s', 0# #) -- underflow - (# s', _ #) -> (# s', 1# #) -- no underflow - -bignat_sub_word - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Bool# #) -{-# INLINE bignat_sub_word #-} -bignat_sub_word mwa wa b s = - case ioWord# (c_mpn_sub_1 mwa wa (wordArraySize# wa) b) s of - (# s', 1## #) -> (# s', 0# #) -- underflow - (# s', _ #) -> (# s', 1# #) -- no underflow - -bignat_mul - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_mul #-} -bignat_mul mwa wa wb s = do - case ioWord# (c_mpn_mul mwa wa (wordArraySize# wa) wb (wordArraySize# wb)) s of - (# s', _msl #) -> s' -- we don't care about the most-significant - -- limb. The caller shrink the mwa if - -- necessary anyway. - -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_mul_word #-} -bignat_mul_word mwa wa b s = - case ioWord# (c_mpn_mul_1 mwa wa (wordArraySize# wa) b) s of - (# s', c #) -> mwaWriteMostSignificant mwa c s' - -bignat_popcount :: WordArray# -> Word# -{-# INLINE bignat_popcount #-} -bignat_popcount wa = c_mpn_popcount wa (wordArraySize# wa) - - -bignat_shiftl - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_shiftl #-} -bignat_shiftl mwa wa n s = - case ioWord# (c_mpn_lshift mwa wa (wordArraySize# wa) n) s of - (# s', _msl #) -> s' -- we don't care about the most-significant - -- limb. The caller shrink the mwa if - -- necessary anyway. - -bignat_shiftr - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_shiftr #-} -bignat_shiftr mwa wa n s = - case ioWord# (c_mpn_rshift mwa wa (wordArraySize# wa) n) s of - (# s', _msl #) -> s' -- we don't care about the most-significant - -- limb. The caller shrink the mwa if - -- necessary anyway. - -bignat_or - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_or #-} -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 - -- nx >= ny - go wx nx wy ny s = case ioVoid (c_mpn_ior_n mwa wx wy ny) s of - s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' - -bignat_xor - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_xor #-} -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 - -- nx >= ny - go wx nx wy ny s = case ioVoid (c_mpn_xor_n mwa wx wy ny) s of - s' -> mwaArrayCopy# mwa ny wx ny (nx -# ny) s' - -bignat_and - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and #-} -bignat_and mwa wa wb s = ioVoid (c_mpn_and_n mwa wa wb sz) s - where - !szA = wordArraySize# wa - !szB = wordArraySize# wb - !sz = minI# szA szB - -bignat_and_not - :: MutableWordArray# RealWorld -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -{-# INLINE bignat_and_not #-} -bignat_and_not mwa wa wb s = - case ioVoid (c_mpn_andn_n mwa wa wb n) s of - s' -> mwaArrayCopy# mwa szB wa szB (szA -# szB) s' - where - !szA = wordArraySize# wa - !szB = wordArraySize# wb - !n = minI# szA szB - -bignat_quotrem - :: MutableWordArray# RealWorld - -> MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quotrem mwq mwr wa wb s = - ioVoid (c_mpn_tdiv_qr mwq mwr 0# wa szA wb szB) s - where - szA = wordArraySize# wa - szB = wordArraySize# wb - -bignat_quot - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_quot mwq wa wb s = - ioVoid (c_mpn_tdiv_q mwq wa szA wb szB) s - where - szA = wordArraySize# wa - szB = wordArraySize# wb - -bignat_rem - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_rem mwr wa wb s = - ioVoid (c_mpn_tdiv_r mwr wa szA wb szB) s - where - szA = wordArraySize# wa - szB = wordArraySize# wb - -bignat_quotrem_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> (# State# RealWorld, Word# #) -bignat_quotrem_word mwq wa b s = - ioWord# (c_mpn_divrem_1 mwq 0# wa szA b) s - where - szA = wordArraySize# wa - -bignat_quot_word - :: MutableWordArray# RealWorld -- ^ Quotient - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_quot_word mwq wa b s = - case bignat_quotrem_word mwq wa b s of - (# s', _ #) -> s' - -bignat_rem_word - :: WordArray# - -> Word# - -> Word# -bignat_rem_word wa b = - c_mpn_mod_1 wa (wordArraySize# wa) b - - -bignat_gcd - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_gcd mwr wa wb s = - -- wa > wb - case ioInt# (c_mpn_gcd# mwr wa (wordArraySize# wa) wb (wordArraySize# wb)) s of - (# s', sz #) -> mwaSetSize# mwr (narrowGmpSize# sz) s' - -bignat_gcd_word - :: WordArray# - -> Word# - -> Word# -bignat_gcd_word wa b = c_mpn_gcd_1# wa (wordArraySize# wa) b - -bignat_gcd_word_word - :: Word# - -> Word# - -> Word# -bignat_gcd_word_word = integer_gmp_gcd_word - - -bignat_encode_double :: WordArray# -> Int# -> Double# -bignat_encode_double wa e = c_mpn_get_d wa (wordArraySize# wa) e - -bignat_shiftr_neg - :: MutableWordArray# RealWorld - -> WordArray# - -> Word# - -> State# RealWorld - -> State# RealWorld -bignat_shiftr_neg mwa wa n s = - ioVoid (c_mpn_rshift_2c mwa wa (wordArraySize# wa) n) s - -bignat_powmod_word - :: WordArray# - -> WordArray# - -> Word# - -> Word# -bignat_powmod_word b e m = - integer_gmp_powm1# b (wordArraySize# b) e (wordArraySize# e) m - -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words = integer_gmp_powm_word - -bignat_powmod - :: MutableWordArray# RealWorld - -> WordArray# - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_powmod r b e m s = - case ioInt# (integer_gmp_powm# r b (wordArraySize# b) e (wordArraySize# e) m (wordArraySize# m)) s of - (# s', n #) -> mwaSetSize# r (narrowGmpSize# n) s' - - ----------------------------------------------------------------------- --- FFI ccall imports - -foreign import ccall unsafe "integer_gmp_gcd_word" - integer_gmp_gcd_word :: GmpLimb# -> GmpLimb# -> GmpLimb# - -foreign import ccall unsafe "integer_gmp_mpn_gcd_1" - c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# - -foreign import ccall unsafe "integer_gmp_mpn_gcd" - c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - -foreign import ccall unsafe "integer_gmp_gcdext" - integer_gmp_gcdext# :: MutableByteArray# s -> MutableByteArray# s - -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - --- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_add_1" - c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_sub_1" - c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, --- mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_mul_1" - c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# - -> IO GmpLimb - --- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_add" - c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpLimb - --- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_sub" - c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO GmpLimb - --- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, --- const mp_limb_t *s2p, mp_size_t s2n) -foreign import ccall unsafe "gmp.h __gmpn_mul" - c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO GmpLimb - --- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) -foreign import ccall unsafe "gmp.h __gmpn_cmp" - c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> Int# - --- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, --- const mp_limb_t *np, mp_size_t nn, --- const mp_limb_t *dp, mp_size_t dn) -foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" - c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () - -foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" - c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO () - -foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" - c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# - -> GmpSize# -> IO () - --- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, --- mp_size_t s2n, mp_limb_t s3limb) -foreign import ccall unsafe "gmp.h __gmpn_divrem_1" - c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# - -> GmpLimb# -> IO GmpLimb - --- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) -foreign import ccall unsafe "gmp.h __gmpn_mod_1" - c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# - --- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_rshift" - c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# - -> IO GmpLimb - --- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" - c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# - -> IO GmpLimb - --- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], --- mp_size_t sn, mp_bitcnt_t count) -foreign import ccall unsafe "integer_gmp_mpn_lshift" - c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> Word# - -> IO GmpLimb - --- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_and_n" - c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_andn_n" - c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_ior_n" - c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, --- mp_size_t n) -foreign import ccall unsafe "integer_gmp_mpn_xor_n" - c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# - -> IO () - --- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) -foreign import ccall unsafe "gmp.h __gmpn_popcount" - c_mpn_popcount :: ByteArray# -> GmpSize# -> Word# - --- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) -foreign import ccall unsafe "integer_gmp_mpn_get_d" - c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# - -foreign import ccall unsafe "integer_gmp_powm" - integer_gmp_powm# :: MutableByteArray# RealWorld - -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> ByteArray# -> GmpSize# -> IO GmpSize - -foreign import ccall unsafe "integer_gmp_powm_word" - integer_gmp_powm_word :: GmpLimb# -> GmpLimb# -> GmpLimb# -> GmpLimb# - -foreign import ccall unsafe "integer_gmp_powm1" - integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# - -> GmpLimb# -> GmpLimb# diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs deleted file mode 100644 index 5c1baa4398..0000000000 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat/Native.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BinaryLiterals #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - -module GHC.Num.BigNat.Native where - -#include "MachDeps.h" -#include "WordSize.h" - -#if defined(BIGNUM_NATIVE) || defined(BIGNUM_CHECK) -import {-# SOURCE #-} GHC.Num.BigNat -import {-# SOURCE #-} GHC.Num.Natural -#else -import GHC.Num.BigNat -import GHC.Num.Natural -#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 -- ^ Result - -> 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 - - -- we have four cases: - -- 1) we have a digit in A and in B + a potential carry - -- => perform triple addition - -- => result in (carry,word) - -- 2) we have a digit only in A or B and a carry - -- => perform double addition from a single array - -- => result in (carry,word) - -- 3) we have a digit only in A or B and no carry - -- => perform array copy and shrink the array - -- 4) We only have a potential carry - -- => write the carry or shrink the array - - 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 - = -- copy the remaining words and remove the word allocated for the - -- potential 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 -- ^ Result - -> 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# #) -- no underflow - - | True - = case subWordC# (indexWordArray# wa i) carry of - (# 0##, 0# #) - | isTrue# (i ==# sz) -> case mwaShrink# mwa 1# s of - s' -> (# s', 1# #) -- no underflow - - (# l , c #) -> case mwaWrite# mwa i l s of - s1 -> go (int2Word# c) (i +# 1#) s1 - -bignat_mul_word - :: MutableWordArray# RealWorld -- ^ Result - -> 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 -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_mul mwa wa wb s1 = - -- initialize the resulting WordArray - case mwaFill# mwa 0## 0## (int2Word# sz) s1 of - s' -> mulEachB ctzB s' -- loop on b Words - where - !szA = wordArraySize# wa - !szB = wordArraySize# wb - !sz = szA +# szB - - !ctzA = word2Int# (bigNatCtzWord# wa) - !ctzB = word2Int# (bigNatCtzWord# wb) - - -- multiply a single bj Word# to the whole wa WordArray - mul bj j i carry s - | isTrue# (i ==# szA) - -- write the carry - = 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' - - -- for each bj in wb, call `mul bj wa` - mulEachB i s - | isTrue# (i ==# szB) = s - | True = case indexWordArray# wb i of - -- detect bj == 0## and skip the loop - 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 = - -- initialize the resulting WordArray - -- Note: we could avoid the copy by subtracting the first non-zero - -- less-significant word of b... - 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 = - -- set the lower words to 0 - 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 - - -- Bit granularity (c is the carry from the previous shift) - mwaBitShift i c s - -- write the carry - | 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 - - -- Bit granularity (c is the carry from the previous shift) - 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 - -- initialize higher limb - = case mwaWrite# mwa (szA -# 1#) 0## s1 of - s2 -> case bignat_shiftr mwa wa n s2 of - s3 -> if nz_shifted_out - -- round if non-zero bits were shifted out - then mwaAddInplaceWord# mwa 0# 1## s3 - else s3 - where - !szA = wordArraySize# wa - !(# nw, nb #) = count_words_bits_int n - - -- non-zero bits are shifted out? - nz_shifted_out - -- test nb bits - | isTrue# ( - (nb /=# 0#) - &&# (indexWordArray# wa nw `uncheckedShiftL#` - (WORD_SIZE_IN_BITS# -# nb) `neWord#` 0##)) - = True - -- test nw words - | 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 -- ^ Result - -> 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 - -- nx >= ny - 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 -- ^ Result - -> 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 - -- nx >= ny - 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 -- ^ Result - -> WordArray# - -> WordArray# - -> State# RealWorld - -> State# RealWorld -bignat_and mwa wa wb s = mwaInitArrayBinOp mwa wa wb and# s - -bignat_and_not - :: MutableWordArray# RealWorld -- ^ Result - -> 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 = - -- Normalization consists in left-shifting bits in B and A so that the - -- most-significant bit of the most-significant word of B is 1. It makes - -- quotient prediction much more efficient as we only use the two most - -- significant words of A and the most significant word of B to make the - -- prediction. - - -- we will left-shift A and B of "clzb" bits for normalization - let !clzb = clz# (indexWordArray# uwb (wordArraySize# uwb -# 1#)) - - -- we use a single array initially containing A (normalized) and - -- returning the remainder (normalized): mnwa (for "mutable normalized - -- wordarray A") - -- - -- We allocate it here with an additionnal Word compared to A because - -- normalizing can left shift at most (N-1) bits (on N-bit arch). - in case newWordArray# (wordArraySize# uwa +# 1#) s0 of { (# s1, mnwa #) -> - - -- normalized A in mnwa - let normalizeA s = case mwaWrite# mnwa (wordArraySize# uwa) 0## s of -- init potential carry - s -> case bignat_shiftl mnwa uwa clzb s of -- left shift - s -> mwaTrimZeroes# mnwa s -- remove null carry if any - in case normalizeA s1 of { s2 -> - - -- normalize B. We don't do it in a MutableWordArray because it will remain - -- constant during the whole computation. - let !nwb = bigNatShiftL# uwb clzb in - - -- perform quotrem on normalized inputs - case bignat_quotrem_normalized mwq mnwa nwb s2 of { s3 -> - - -- denormalize the remainder now stored in mnwa. We just have to right shift - -- of "clzb" bits. We copy the result into "mwr" array. - 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 = - -- allocate a temporary array for the remainder and call quotrem - 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 = - -- allocate a temporary array for the quotient and call quotrem - -- (we could avoid allocating it as it is not used to compute the result but - -- it would require non trivial modification of bignat_quotrem) - 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 - --- | Perform quotRem on normalized inputs: --- * highest bit of B is set --- * A is trimmed --- * A >= B --- * B > 1 -bignat_quotrem_normalized - :: MutableWordArray# s - -> MutableWordArray# s - -> WordArray# - -> State# s - -> State# s -bignat_quotrem_normalized mwq mwa b s0 = - - -- n is the size of B - let !n = wordArraySize# b - - -- m+n is the size of A (m >= 0) - in case mwaSize# mwa s0 of { (# s1, szA #) -> - let !m = szA -# n in - - -- Definitions: - -- MSW(x) is the most-significant word of x - -- MSB(x) the most-significant bit of x - - -- We first compute MSW(Q). Thanks to the normalization of B, MSW(Q) can - -- only be 0 or 1 so we only have to perform a prefix comparison to compute - -- MSW(Q). - -- - -- Proof MSW(Q) < 2: - -- * MSB(MSW(B)) = 1 thanks to normalization. - -- * MSW(B) * MSW(Q) <= MSW(A) by definition - -- * suppose MSW(Q) >= 2: - -- MSW(B) * MSW(Q) >= MSW(B) << 1 { MSW(Q) >= 2 } - -- > MAX_WORD_VALUE { MSB(MSW(B)) = 1 } - -- > MSW(A) { MSW(A) <= MAX_WORD_VALUE } - -- contradiction. - -- - -- If A >= (B << m words) - -- then Qm = 1 - -- A := A - (B << m words) - -- else Qm = 0 - -- A unchanged - 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 -- write Qj - s | 0## <- qj -> s - | True -> case mwaSubInplaceArray mwa j qjb s of -- subtract (qjB << j words) - (# s, _ #) -> s - - -- update the highest word of Q - updateQm s = case computeQm s of - (# s, qm #) -> updateQj m qm b s - - -- the size of Q is szA+szB+1 BEFORE normalization. Normalization may add - -- an additional higher word to A. - -- * If A has an additional limb: - -- * MSW(A) < MSW(B). Because MSB(MSW(A)) can't be set (it would - -- mean that we shifted a whole word, which we didn't) - -- * hence MSW(Q) = 0 but we don't have to write it (and we mustn't) - -- because of the size of Q - -- * If A has no additional limb: - -- * We have to check if MSW(A) >= MSW(B) and to adjust A and MSW(Q) - -- accordingly - -- - -- We detect if A has an additional limb by comparing the size of Q with m - updateQmMaybe s = case mwaSize# mwq s of - (# s, szQ #) | isTrue# (m <# szQ) -> updateQm s - | True -> s - - in case updateQmMaybe s1 of { s2 -> - - - -- main loop: for j from (m-1) downto 0 - -- We estimate a one Word quotient qj: - -- e1e0 <- a(n+j)a(n+j-1) `div` b(n-1) - -- qj | e1 == 0 = e0 - -- | otherwise = maxBound - -- We loop until we find the real quotient: - -- while (A < ((qj*B) << j words)) qj-- - -- We update A and Qj: - -- Qj := qj - -- A := A - (qj*B << j words) - - let bmsw = wordArrayLast# b -- most significant word of 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## #) - - -- we perform the qj*B multiplication once and then we subtract B from - -- qj*B as much as needed until (qj'*B << j words) <= A - 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 - -- TODO: we could do the sub inplace to - -- reduce allocations - (# 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 -- ^ Quotient - -> 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 -- ^ Quotient - -> 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) - --- | This operation doesn't really belongs here, but GMP's one is much faster --- than this simple implementation (basic Euclid algorithm). --- --- Ideally we should make an implementation as fast as GMP's one and put it into --- GHC.Num.Primitives. -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#) -- FIXME: we assume that e doesn't overflow... - (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## -- slightly faster than "e `div` 2" - -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## -- slightly faster than "e `div` 2" - -bignat_powmod_words - :: Word# - -> Word# - -> Word# - -> Word# -bignat_powmod_words b e m = - bignat_powmod_word (wordArrayFromWord# b) - (wordArrayFromWord# e) - m -- cgit v1.2.1