/* ----------------------------------------------------------------------------- * * (c) The GHC Team, 1998-2012 * * Out-of-line primitive operations * * This file contains the implementations of all the primitive * operations ("primops") which are not expanded inline. See * ghc/compiler/prelude/primops.txt.pp for a list of all the primops; * this file contains code for most of those with the attribute * out_of_line=True. * * Entry convention: the entry convention for a primop is that all the * args are in Stg registers (R1, R2, etc.). This is to make writing * the primops easier. (see compiler/codeGen/CgCallConv.hs). * * Return convention: results from a primop are generally returned * using the ordinary unboxed tuple return convention. The C-- parser * implements the RET_xxxx() macros to perform unboxed-tuple returns * based on the prevailing return convention. * * This file is written in a subset of C--, extended with various * features specific to GHC. It is compiled by GHC directly. For the * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. * * ---------------------------------------------------------------------------*/ #include "Cmm.h" #include "GmpDerivedConstants.h" #include "HsIntegerGmp.h" import "integer-gmp" __gmpz_add; import "integer-gmp" __gmpz_add_ui; import "integer-gmp" __gmpz_sub; import "integer-gmp" __gmpz_sub_ui; import "integer-gmp" __gmpz_mul; import "integer-gmp" __gmpz_mul_2exp; import "integer-gmp" __gmpz_mul_si; import "integer-gmp" __gmpz_tstbit; import "integer-gmp" __gmpz_fdiv_q_2exp; import "integer-gmp" __gmpz_gcd; import "integer-gmp" __gmpz_gcdext; import "integer-gmp" __gmpn_gcd_1; import "integer-gmp" __gmpn_cmp; import "integer-gmp" __gmpz_tdiv_q; import "integer-gmp" __gmpz_tdiv_q_ui; import "integer-gmp" __gmpz_tdiv_r; import "integer-gmp" __gmpz_tdiv_r_ui; import "integer-gmp" __gmpz_fdiv_q; import "integer-gmp" __gmpz_fdiv_q_ui; import "integer-gmp" __gmpz_fdiv_r; import "integer-gmp" __gmpz_fdiv_r_ui; import "integer-gmp" __gmpz_tdiv_qr; import "integer-gmp" __gmpz_tdiv_qr_ui; import "integer-gmp" __gmpz_fdiv_qr; import "integer-gmp" __gmpz_fdiv_qr_ui; import "integer-gmp" __gmpz_divexact; import "integer-gmp" __gmpz_divexact_ui; import "integer-gmp" __gmpz_and; import "integer-gmp" __gmpz_xor; import "integer-gmp" __gmpz_ior; import "integer-gmp" __gmpz_com; import "integer-gmp" __gmpz_pow_ui; import "integer-gmp" __gmpz_powm; #if HAVE_SECURE_POWM == 1 import "integer-gmp" __gmpz_powm_sec; #endif import "integer-gmp" __gmpz_invert; import "integer-gmp" __gmpz_nextprime; import "integer-gmp" __gmpz_probab_prime_p; import "integer-gmp" __gmpz_sizeinbase; import "integer-gmp" __gmpz_import; import "integer-gmp" __gmpz_export; import "integer-gmp" integer_cbits_decodeDouble; import "rts" stg_INTLIKE_closure; /* ----------------------------------------------------------------------------- Arbitrary-precision Integer operations. There are some assumptions in this code that mp_limb_t == W_. This is the case for all the platforms that GHC supports, currently. -------------------------------------------------------------------------- */ #if SIZEOF_MP_LIMB_T != SIZEOF_W #error "sizeof(mp_limb_t) != sizeof(W_)" #endif /* This is used when a dummy pointer is needed for a ByteArray# return value Ideally this would be a statically allocated 'ByteArray#' containing SIZEOF_W 0-bytes. However, since in those cases when a dummy value is needed, the 'ByteArray#' is not supposed to be accessed anyway, this is should be a tolerable hack. */ #define DUMMY_BYTE_ARR (stg_INTLIKE_closure+1) /* set mpz_t from Int#/ByteArray# */ #define MP_INT_SET_FROM_BA(mp_ptr,i,ba) \ MP_INT__mp_alloc(mp_ptr) = W_TO_INT(BYTE_ARR_WDS(ba)); \ MP_INT__mp_size(mp_ptr) = W_TO_INT(i); \ MP_INT__mp_d(mp_ptr) = BYTE_ARR_CTS(ba) /* convert mpz_t to Int#/ByteArray# return pair */ #define MP_INT_AS_PAIR(mp_ptr) \ TO_W_(MP_INT__mp_size(mp_ptr)),(MP_INT__mp_d(mp_ptr)-SIZEOF_StgArrWords) #define MP_INT_TO_BA(mp_ptr) \ (MP_INT__mp_d(mp_ptr)-SIZEOF_StgArrWords) /* Size of mpz_t with single limb */ #define SIZEOF_MP_INT_1LIMB (SIZEOF_MP_INT+WDS(1)) /* Initialize 0-valued single-limb mpz_t at mp_ptr */ #define MP_INT_1LIMB_INIT0(mp_ptr) \ MP_INT__mp_alloc(mp_ptr) = W_TO_INT(1); \ MP_INT__mp_size(mp_ptr) = W_TO_INT(0); \ MP_INT__mp_d(mp_ptr) = (mp_ptr+SIZEOF_MP_INT) /* return mpz_t as (# s::Int#, d::ByteArray#, l1::Word# #) tuple * * semantics: * * (# 0, _, 0 #) -> value = 0 * (# 1, _, w #) -> value = w * (# -1, _, w #) -> value = -w * (# s, d, 0 #) -> value = J# s d * */ #define MP_INT_1LIMB_RETURN(mp_ptr) \ CInt __mp_s; \ __mp_s = MP_INT__mp_size(mp_ptr); \ \ if (__mp_s == W_TO_INT(0)) \ { \ return (0,DUMMY_BYTE_ARR,0); \ } \ \ if (__mp_s == W_TO_INT(-1) || __mp_s == W_TO_INT(1)) \ { \ return (TO_W_(__mp_s),DUMMY_BYTE_ARR,W_[MP_INT__mp_d(mp_ptr)]); \ } \ \ return (TO_W_(__mp_s),MP_INT_TO_BA(mp_ptr),0) /* Helper macro used by MP_INT_1LIMB_RETURN2 */ #define MP_INT_1LIMB_AS_TUP3(s,d,w,mp_ptr) \ CInt s; P_ d; W_ w; \ s = MP_INT__mp_size(mp_ptr); \ \ if (s == W_TO_INT(0)) \ { \ d = DUMMY_BYTE_ARR; w = 0; \ } else { \ if (s == W_TO_INT(-1) || s == W_TO_INT(1)) \ { \ d = DUMMY_BYTE_ARR; w = W_[MP_INT__mp_d(mp_ptr)]; \ } else { \ d = MP_INT_TO_BA(mp_ptr); w = 0; \ } \ } #define MP_INT_1LIMB_RETURN2(mp_ptr1,mp_ptr2) \ MP_INT_1LIMB_AS_TUP3(__r1s,__r1d,__r1w,mp_ptr1); \ MP_INT_1LIMB_AS_TUP3(__r2s,__r2d,__r2w,mp_ptr2); \ return (TO_W_(__r1s),__r1d,__r1w, TO_W_(__r2s),__r2d,__r2w) /* :: ByteArray# -> Word# -> Word# -> Int# -> (# Int#, ByteArray#, Word# #) */ integer_cmm_importIntegerFromByteArrayzh (P_ ba, W_ of, W_ sz, W_ e) { W_ src_ptr; W_ mp_result; again: STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB); MAYBE_GC(again); mp_result = Sp - SIZEOF_MP_INT_1LIMB; MP_INT_1LIMB_INIT0(mp_result); src_ptr = BYTE_ARR_CTS(ba) + of; ccall __gmpz_import(mp_result "ptr", sz, W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, src_ptr "ptr"); MP_INT_1LIMB_RETURN(mp_result); } /* :: Addr# -> Word# -> Int# -> State# s -> (# State# s, Int#, ByteArray#, Word# #) */ integer_cmm_importIntegerFromAddrzh (W_ src_ptr, W_ sz, W_ e) { W_ mp_result; again: STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB); MAYBE_GC(again); mp_result = Sp - SIZEOF_MP_INT_1LIMB; MP_INT_1LIMB_INIT0(mp_result); ccall __gmpz_import(mp_result "ptr", sz, W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, src_ptr "ptr"); MP_INT_1LIMB_RETURN(mp_result); } /* :: Int# -> ByteArray# -> MutableByteArray# s -> Word# -> Int# -> State# s -> (# State# s, Word# #) */ integer_cmm_exportIntegerToMutableByteArrayzh (W_ ws1, P_ d1, P_ mba, W_ of, W_ e) { W_ dst_ptr; W_ mp_tmp; W_ cnt_result; again: STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); MAYBE_GC(again); mp_tmp = Sp - SIZEOF_MP_INT; MP_INT_SET_FROM_BA(mp_tmp, ws1, d1); cnt_result = Sp - (SIZEOF_MP_INT + SIZEOF_W); W_[cnt_result] = 0; dst_ptr = BYTE_ARR_CTS(mba) + of; ccall __gmpz_export(dst_ptr "ptr", cnt_result "ptr", W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, mp_tmp "ptr"); return (W_[cnt_result]); } /* :: Int# -> ByteArray# -> Addr# -> Int# -> State# s -> (# State# s, Word# #) */ integer_cmm_exportIntegerToAddrzh (W_ ws1, P_ d1, W_ dst_ptr, W_ e) { W_ mp_tmp; W_ cnt_result; again: STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); MAYBE_GC(again); mp_tmp = Sp - SIZEOF_MP_INT; MP_INT_SET_FROM_BA(mp_tmp, ws1, d1); cnt_result = Sp - (SIZEOF_MP_INT + SIZEOF_W); W_[cnt_result] = 0; ccall __gmpz_export(dst_ptr "ptr", cnt_result "ptr", W_TO_INT(e), W_TO_INT(1), W_TO_INT(0), 0, mp_tmp "ptr"); return (W_[cnt_result]); } integer_cmm_int2Integerzh (W_ val) { W_ s, p; /* to avoid aliasing */ ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_int2Integerzh, val); p = Hp - SIZEOF_StgArrWords; SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(p) = SIZEOF_W; /* mpz_set_si is inlined here, makes things simpler */ if (%lt(val,0)) { s = -1; Hp(0) = -val; } else { if (%gt(val,0)) { s = 1; Hp(0) = val; } else { s = 0; } } /* returns (# size :: Int#, data :: ByteArray# #) */ return (s,p); } integer_cmm_word2Integerzh (W_ val) { W_ s, p; /* to avoid aliasing */ ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_word2Integerzh, val); p = Hp - SIZEOF_StgArrWords; SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(p) = SIZEOF_W; if (val != 0) { s = 1; W_[Hp] = val; } else { s = 0; } /* returns (# size :: Int#, data :: ByteArray# #) */ return (s,p); } /* * 'long long' primops for converting to/from Integers. */ #if WORD_SIZE_IN_BITS < 64 integer_cmm_int64ToIntegerzh (L_ val) { W_ hi, lo, s, neg, words_needed, p; neg = 0; hi = TO_W_(val >> 32); lo = TO_W_(val); if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) ) { // minimum is one word words_needed = 1; } else { words_needed = 2; } ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed)); p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(p) = WDS(words_needed); if ( %lt(hi,0) ) { neg = 1; lo = -lo; if(lo == 0) { hi = -hi; } else { hi = -hi - 1; } } if ( words_needed == 2 ) { s = 2; Hp(-1) = lo; Hp(0) = hi; } else { if ( lo != 0 ) { s = 1; Hp(0) = lo; } else /* val==0 */ { s = 0; } } if ( neg != 0 ) { s = -s; } /* returns (# size :: Int#, data :: ByteArray# #) */ return (s,p); } integer_cmm_word64ToIntegerzh (L_ val) { W_ hi, lo, s, words_needed, p; hi = TO_W_(val >> 32); lo = TO_W_(val); if ( hi != 0 ) { words_needed = 2; } else { words_needed = 1; } ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed)); p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(p) = WDS(words_needed); if ( hi != 0 ) { s = 2; Hp(-1) = lo; Hp(0) = hi; } else { if ( lo != 0 ) { s = 1; Hp(0) = lo; } else /* val==0 */ { s = 0; } } /* returns (# size :: Int#, data :: ByteArray# #) */ return (s,p); } #endif /* WORD_SIZE_IN_BITS < 64 */ #define GMP_TAKE2_RET1(name,mp_fun) \ name (W_ ws1, P_ d1, W_ ws2, P_ d2) \ { \ W_ mp_tmp1; \ W_ mp_tmp2; \ W_ mp_result1; \ \ again: \ STK_CHK_GEN_N (2*SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ mp_result1 = Sp - 2*SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ \ MP_INT_1LIMB_INIT0(mp_result1); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result1 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr"); \ \ MP_INT_1LIMB_RETURN(mp_result1); \ } #define GMP_TAKE3_RET1(name,mp_fun) \ name (W_ ws1, P_ d1, W_ ws2, P_ d2, W_ ws3, P_ d3) \ { \ W_ mp_tmp1; \ W_ mp_tmp2; \ W_ mp_tmp3; \ W_ mp_result1; \ \ again: \ STK_CHK_GEN_N (3*SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ mp_tmp3 = Sp - 3*SIZEOF_MP_INT; \ mp_result1 = Sp - 3*SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ MP_INT_SET_FROM_BA(mp_tmp3,ws3,d3); \ \ MP_INT_1LIMB_INIT0(mp_result1); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result1 "ptr", \ mp_tmp1 "ptr", mp_tmp2 "ptr", mp_tmp3 "ptr"); \ \ MP_INT_1LIMB_RETURN(mp_result1); \ } #define GMP_TAKE1_UL1_RET1(name,mp_fun) \ name (W_ ws1, P_ d1, W_ wul) \ { \ W_ mp_tmp; \ W_ mp_result; \ \ /* call doYouWantToGC() */ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp = Sp - SIZEOF_MP_INT; \ mp_result = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ \ MP_INT_1LIMB_INIT0(mp_result); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(wul)); \ \ MP_INT_1LIMB_RETURN(mp_result); \ } #define GMP_TAKE1_I1_RETI1(name,mp_fun) \ name (W_ ws1, P_ d1, W_ wi) \ { \ CInt res; \ W_ mp_tmp; \ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT); \ MAYBE_GC(again); \ \ mp_tmp = Sp - 1 * SIZEOF_MP_INT; \ MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ \ /* Perform the operation */ \ (res) = ccall mp_fun(mp_tmp "ptr", W_TO_INT(wi)); \ \ return (TO_W_(res)); \ } #define GMP_TAKE1_UL1_RETI1(name,mp_fun) \ name (W_ ws1, P_ d1, W_ wul) \ { \ CInt res; \ W_ mp_tmp; \ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT); \ MAYBE_GC(again); \ \ mp_tmp = Sp - 1 * SIZEOF_MP_INT; \ MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ \ /* Perform the operation */ \ (res) = ccall mp_fun(mp_tmp "ptr", W_TO_LONG(wul)); \ \ return (TO_W_(res)); \ } #define GMP_TAKE1_RET1(name,mp_fun) \ name (W_ ws1, P_ d1) \ { \ W_ mp_tmp1; \ W_ mp_result1; \ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp1 = Sp - SIZEOF_MP_INT; \ mp_result1 = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ \ MP_INT_1LIMB_INIT0(mp_result1); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result1 "ptr",mp_tmp1 "ptr"); \ \ MP_INT_1LIMB_RETURN(mp_result1); \ } #define GMP_TAKE2_RET2(name,mp_fun) \ name (W_ ws1, P_ d1, W_ ws2, P_ d2) \ { \ W_ mp_tmp1; \ W_ mp_tmp2; \ W_ mp_result1; \ W_ mp_result2; \ \ again: \ STK_CHK_GEN_N (2*SIZEOF_MP_INT + 2*SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp1 = Sp - 1*SIZEOF_MP_INT; \ mp_tmp2 = Sp - 2*SIZEOF_MP_INT; \ mp_result1 = Sp - 2*SIZEOF_MP_INT - 1*SIZEOF_MP_INT_1LIMB; \ mp_result2 = Sp - 2*SIZEOF_MP_INT - 2*SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ MP_INT_SET_FROM_BA(mp_tmp2,ws2,d2); \ \ MP_INT_1LIMB_INIT0(mp_result1); \ MP_INT_1LIMB_INIT0(mp_result2); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result1 "ptr", mp_result2 "ptr", \ mp_tmp1 "ptr", mp_tmp2 "ptr"); \ \ MP_INT_1LIMB_RETURN2(mp_result1, mp_result2); \ } #define GMP_TAKE1_UL1_RET2(name,mp_fun) \ name (W_ ws1, P_ d1, W_ wul2) \ { \ W_ mp_tmp1; \ W_ mp_result1; \ W_ mp_result2; \ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT + 2*SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp1 = Sp - SIZEOF_MP_INT; \ mp_result1 = Sp - SIZEOF_MP_INT - 1*SIZEOF_MP_INT_1LIMB; \ mp_result2 = Sp - SIZEOF_MP_INT - 2*SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp1,ws1,d1); \ \ MP_INT_1LIMB_INIT0(mp_result1); \ MP_INT_1LIMB_INIT0(mp_result2); \ \ /* Perform the operation */ \ ccall mp_fun(mp_result1 "ptr", mp_result2 "ptr", \ mp_tmp1 "ptr", W_TO_LONG(wul2)); \ \ MP_INT_1LIMB_RETURN2(mp_result1, mp_result2); \ } GMP_TAKE2_RET1(integer_cmm_plusIntegerzh, __gmpz_add) GMP_TAKE2_RET1(integer_cmm_minusIntegerzh, __gmpz_sub) GMP_TAKE2_RET1(integer_cmm_timesIntegerzh, __gmpz_mul) GMP_TAKE1_UL1_RET1(integer_cmm_timesIntegerIntzh, __gmpz_mul_si) GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh, __gmpz_gcd) #define CMM_GMPZ_GCDEXT(g,s,a,b) __gmpz_gcdext(g,s,NULL,a,b) GMP_TAKE2_RET2(integer_cmm_gcdExtIntegerzh, CMM_GMPZ_GCDEXT) GMP_TAKE2_RET1(integer_cmm_quotIntegerzh, __gmpz_tdiv_q) GMP_TAKE1_UL1_RET1(integer_cmm_quotIntegerWordzh, __gmpz_tdiv_q_ui) GMP_TAKE2_RET1(integer_cmm_remIntegerzh, __gmpz_tdiv_r) GMP_TAKE1_UL1_RET1(integer_cmm_remIntegerWordzh, __gmpz_tdiv_r_ui) GMP_TAKE2_RET1(integer_cmm_divIntegerzh, __gmpz_fdiv_q) GMP_TAKE1_UL1_RET1(integer_cmm_divIntegerWordzh, __gmpz_fdiv_q_ui) GMP_TAKE2_RET1(integer_cmm_modIntegerzh, __gmpz_fdiv_r) GMP_TAKE1_UL1_RET1(integer_cmm_modIntegerWordzh, __gmpz_fdiv_r_ui) GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact) GMP_TAKE1_UL1_RET1(integer_cmm_divExactIntegerWordzh, __gmpz_divexact_ui) GMP_TAKE2_RET1(integer_cmm_andIntegerzh, __gmpz_and) GMP_TAKE2_RET1(integer_cmm_orIntegerzh, __gmpz_ior) GMP_TAKE2_RET1(integer_cmm_xorIntegerzh, __gmpz_xor) GMP_TAKE1_UL1_RETI1(integer_cmm_testBitIntegerzh, __gmpz_tstbit) GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh, __gmpz_mul_2exp) GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh, __gmpz_fdiv_q_2exp) GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com) GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr) GMP_TAKE1_UL1_RET2(integer_cmm_quotRemIntegerWordzh,__gmpz_tdiv_qr_ui) GMP_TAKE2_RET2(integer_cmm_divModIntegerzh, __gmpz_fdiv_qr) GMP_TAKE1_UL1_RET2(integer_cmm_divModIntegerWordzh, __gmpz_fdiv_qr_ui) GMP_TAKE3_RET1(integer_cmm_powModIntegerzh, __gmpz_powm) #if HAVE_SECURE_POWM == 1 GMP_TAKE3_RET1(integer_cmm_powModSecIntegerzh, __gmpz_powm_sec) #else GMP_TAKE3_RET1(integer_cmm_powModSecIntegerzh, __gmpz_powm) #endif GMP_TAKE2_RET1(integer_cmm_recipModIntegerzh, __gmpz_invert) GMP_TAKE1_UL1_RET1(integer_cmm_powIntegerzh, __gmpz_pow_ui) GMP_TAKE1_RET1(integer_cmm_nextPrimeIntegerzh, __gmpz_nextprime) GMP_TAKE1_I1_RETI1(integer_cmm_testPrimeIntegerzh, __gmpz_probab_prime_p) GMP_TAKE1_I1_RETI1(integer_cmm_sizeInBasezh, __gmpz_sizeinbase) integer_cmm_gcdIntzh (W_ int1, W_ int2) { W_ r; W_ mp_tmp_w; STK_CHK_GEN_N (1 * SIZEOF_W); mp_tmp_w = Sp - 1 * SIZEOF_W; W_[mp_tmp_w] = int1; (r) = ccall __gmpn_gcd_1(mp_tmp_w "ptr", 1, int2); return (r); } integer_cmm_gcdIntegerIntzh (W_ s1, P_ d1, W_ int) { W_ r; (r) = ccall __gmpn_gcd_1 (BYTE_ARR_CTS(d1) "ptr", s1, int); return (r); } integer_cmm_cmpIntegerIntzh (W_ usize, P_ d1, W_ v_digit) { W_ vsize, u_digit; vsize = 0; // paraphrased from __gmpz_cmp_si() in the GMP sources if (%gt(v_digit,0)) { vsize = 1; } else { if (%lt(v_digit,0)) { vsize = -1; v_digit = -v_digit; } } if (usize != vsize) { return (usize - vsize); } if (usize == 0) { return (0); } u_digit = W_[BYTE_ARR_CTS(d1)]; if (u_digit == v_digit) { return (0); } if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's return (usize); } else { return (-usize); } } integer_cmm_cmpIntegerzh (W_ usize, P_ d1, W_ vsize, P_ d2) { W_ size, up, vp; CInt cmp; // paraphrased from __gmpz_cmp() in the GMP sources if (usize != vsize) { return (usize - vsize); } if (usize == 0) { return (0); } if (%lt(usize,0)) { // NB. not <, which is unsigned size = -usize; } else { size = usize; } up = BYTE_ARR_CTS(d1); vp = BYTE_ARR_CTS(d2); (cmp) = ccall __gmpn_cmp(up "ptr", vp "ptr", size); if (cmp == 0 :: CInt) { return (0); } if (%lt(cmp,0 :: CInt) == %lt(usize,0)) { return (1); } else { return (-1); } } #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE) integer_cmm_decodeDoublezh (D_ arg) { W_ mp_tmp1; W_ mp_tmp_w; #if SIZEOF_DOUBLE != SIZEOF_W W_ p; STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_W); ALLOC_PRIM (ARR_SIZE); mp_tmp1 = Sp - SIZEOF_MP_INT; mp_tmp_w = Sp - SIZEOF_MP_INT - SIZEOF_W; /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble where mantissa.d can be put (it does not care about the rest) */ p = Hp - ARR_SIZE + WDS(1); SET_HDR(p, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(p) = DOUBLE_MANTISSA_SIZE; MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p); #else /* When SIZEOF_DOUBLE == SIZEOF_W == 8, the result will fit into a single 8-byte limb, and so we avoid allocating on the Heap and use only the Stack instead */ STK_CHK_GEN_N (SIZEOF_MP_INT_1LIMB + SIZEOF_W); mp_tmp1 = Sp - SIZEOF_MP_INT_1LIMB; mp_tmp_w = Sp - SIZEOF_MP_INT_1LIMB - SIZEOF_W; MP_INT_1LIMB_INIT0(mp_tmp1); #endif /* Perform the operation */ ccall integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr", arg); /* returns: (Int# (expn), MPZ#) */ MP_INT_1LIMB_AS_TUP3(r1s, r1d, r1w, mp_tmp1); return (W_[mp_tmp_w], TO_W_(r1s), r1d, r1w); } /* :: Int# -> ByteArray# -> Int# -> (# Int#, ByteArray#, Word# #) */ #define GMPX_TAKE1_UL1_RET1(name,pos_arg_fun,neg_arg_fun) \ name(W_ ws1, P_ d1, W_ wl) \ { \ W_ mp_tmp; \ W_ mp_result; \ \ again: \ STK_CHK_GEN_N (SIZEOF_MP_INT + SIZEOF_MP_INT_1LIMB); \ MAYBE_GC(again); \ \ mp_tmp = Sp - SIZEOF_MP_INT; \ mp_result = Sp - SIZEOF_MP_INT - SIZEOF_MP_INT_1LIMB; \ \ MP_INT_SET_FROM_BA(mp_tmp,ws1,d1); \ \ MP_INT_1LIMB_INIT0(mp_result); \ \ if(%lt(wl,0)) { \ ccall neg_arg_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(-wl)); \ } else { \ ccall pos_arg_fun(mp_result "ptr", mp_tmp "ptr", W_TO_LONG(wl)); \ } \ \ MP_INT_1LIMB_RETURN(mp_result); \ } /* NB: We need both primitives as we can't express 'minusIntegerInt#' in terms of 'plusIntegerInt#' for @minBound :: Int@ */ GMPX_TAKE1_UL1_RET1(integer_cmm_plusIntegerIntzh,__gmpz_add_ui,__gmpz_sub_ui) GMPX_TAKE1_UL1_RET1(integer_cmm_minusIntegerIntzh,__gmpz_sub_ui,__gmpz_add_ui)