diff options
Diffstat (limited to 'libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs')
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs | 456 |
1 files changed, 456 insertions, 0 deletions
diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs new file mode 100644 index 0000000000..aad7d903ff --- /dev/null +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-} + +-- | 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# -> case unexpectedValue of I# x -> x + _ -> 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 + (# 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 + _ -> 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 #) + _ -> case (ra ==# 1#) of -- don't compare MWAs if overflow signaled! + 1# -> (# s, ra #) + _ -> 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 #) + _ -> (# 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 #) + _ -> (# 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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> gr + +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 + _ -> case unexpectedValue of + W# e -> e + +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 + _ -> case unexpectedValue of + W# e -> e |