integer-gmp-0.5.1.0: cbits/gmp-wrappers.cmm
/* -----------------------------------------------------------------------------
*
* (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)