Add divInteger and modInteger functions
[packages/integer-gmp.git] / cbits / gmp-wrappers.cmm
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-2004
4  *
5  * Out-of-line primitive operations
6  *
7  * This file contains the implementations of all the primitive
8  * operations ("primops") which are not expanded inline.  See
9  * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
10  * this file contains code for most of those with the attribute
11  * out_of_line=True.
12  *
13  * Entry convention: the entry convention for a primop is that all the
14  * args are in Stg registers (R1, R2, etc.).  This is to make writing
15  * the primops easier.  (see compiler/codeGen/CgCallConv.hs).
16  *
17  * Return convention: results from a primop are generally returned
18  * using the ordinary unboxed tuple return convention.  The C-- parser
19  * implements the RET_xxxx() macros to perform unboxed-tuple returns
20  * based on the prevailing return convention.
21  *
22  * This file is written in a subset of C--, extended with various
23  * features specific to GHC.  It is compiled by GHC directly.  For the
24  * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
25  *
26  * ---------------------------------------------------------------------------*/
27
28 #include "Cmm.h"
29 #include "GmpDerivedConstants.h"
30
31 import "integer-gmp" __gmpz_init;
32 import "integer-gmp" __gmpz_add;
33 import "integer-gmp" __gmpz_sub;
34 import "integer-gmp" __gmpz_mul;
35 import "integer-gmp" __gmpz_mul_2exp;
36 import "integer-gmp" __gmpz_fdiv_q_2exp;
37 import "integer-gmp" __gmpz_gcd;
38 import "integer-gmp" __gmpn_gcd_1;
39 import "integer-gmp" __gmpn_cmp;
40 import "integer-gmp" __gmpz_tdiv_q;
41 import "integer-gmp" __gmpz_tdiv_r;
42 import "integer-gmp" __gmpz_tdiv_qr;
43 import "integer-gmp" __gmpz_fdiv_qr;
44 import "integer-gmp" __gmpz_divexact;
45 import "integer-gmp" __gmpz_and;
46 import "integer-gmp" __gmpz_xor;
47 import "integer-gmp" __gmpz_ior;
48 import "integer-gmp" __gmpz_com;
49
50 import "integer-gmp" integer_cbits_decodeDouble;
51
52 /* -----------------------------------------------------------------------------
53    Arbitrary-precision Integer operations.
54
55    There are some assumptions in this code that mp_limb_t == W_.  This is
56    the case for all the platforms that GHC supports, currently.
57    -------------------------------------------------------------------------- */
58
59 integer_cmm_int2Integerzh
60 {
61    /* arguments: R1 = Int# */
62
63    W_ val, s, p; /* to avoid aliasing */
64
65    val = R1;
66    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_int2Integerzh );
67
68    p = Hp - SIZEOF_StgArrWords;
69    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
70    StgArrWords_bytes(p) = SIZEOF_W;
71
72    /* mpz_set_si is inlined here, makes things simpler */
73    if (%lt(val,0)) {
74         s  = -1;
75         Hp(0) = -val;
76    } else {
77      if (%gt(val,0)) {
78         s = 1;
79         Hp(0) = val;
80      } else {
81         s = 0;
82      }
83   }
84
85    /* returns (# size  :: Int#,
86                  data  :: ByteArray#
87                #)
88    */
89    RET_NP(s,p);
90 }
91
92 integer_cmm_word2Integerzh
93 {
94    /* arguments: R1 = Word# */
95
96    W_ val, s, p; /* to avoid aliasing */
97
98    val = R1;
99
100    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_word2Integerzh);
101
102    p = Hp - SIZEOF_StgArrWords;
103    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
104    StgArrWords_bytes(p) = SIZEOF_W;
105
106    if (val != 0) {
107         s = 1;
108         W_[Hp] = val;
109    } else {
110         s = 0;
111    }
112
113    /* returns (# size  :: Int#,
114                  data  :: ByteArray# #)
115    */
116    RET_NP(s,p);
117 }
118
119
120 /*
121  * 'long long' primops for converting to/from Integers.
122  */
123
124 #if WORD_SIZE_IN_BITS < 64
125
126 integer_cmm_int64ToIntegerzh
127 {
128    /* arguments: L1 = Int64# */
129
130    L_ val;
131    W_ hi, lo, s, neg, words_needed, p;
132
133    val = L1;
134    neg = 0;
135
136    hi = TO_W_(val >> 32);
137    lo = TO_W_(val);
138
139    if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) )  {
140        // minimum is one word
141        words_needed = 1;
142    } else {
143        words_needed = 2;
144    }
145
146    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
147                NO_PTRS, integer_cmm_int64ToIntegerzh );
148
149    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
150    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
151    StgArrWords_bytes(p) = WDS(words_needed);
152
153    if ( %lt(hi,0) ) {
154      neg = 1;
155      lo = -lo;
156      if(lo == 0) {
157        hi = -hi;
158      } else {
159        hi = -hi - 1;
160      }
161    }
162
163    if ( words_needed == 2 )  {
164       s = 2;
165       Hp(-1) = lo;
166       Hp(0) = hi;
167    } else {
168        if ( lo != 0 ) {
169            s = 1;
170            Hp(0) = lo;
171        } else /* val==0 */  {
172            s = 0;
173        }
174    }
175    if ( neg != 0 ) {
176         s = -s;
177    }
178
179    /* returns (# size  :: Int#,
180                  data  :: ByteArray# #)
181    */
182    RET_NP(s,p);
183 }
184 integer_cmm_word64ToIntegerzh
185 {
186    /* arguments: L1 = Word64# */
187
188    L_ val;
189    W_ hi, lo, s, words_needed, p;
190
191    val = L1;
192    hi = TO_W_(val >> 32);
193    lo = TO_W_(val);
194
195    if ( hi != 0 ) {
196       words_needed = 2;
197    } else {
198       words_needed = 1;
199    }
200
201    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
202                NO_PTRS, integer_cmm_word64ToIntegerzh );
203
204    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
205    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
206    StgArrWords_bytes(p) = WDS(words_needed);
207
208    if ( hi != 0 ) {
209      s = 2;
210      Hp(-1) = lo;
211      Hp(0)  = hi;
212    } else {
213       if ( lo != 0 ) {
214         s = 1;
215         Hp(0) = lo;
216      } else /* val==0 */  {
217       s = 0;
218      }
219   }
220
221    /* returns (# size  :: Int#,
222                  data  :: ByteArray# #)
223    */
224    RET_NP(s,p);
225 }
226
227 #endif /* WORD_SIZE_IN_BITS < 64 */
228
229 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
230 name                                                                    \
231 {                                                                       \
232   CInt s1, s2;                                                          \
233   W_ d1, d2;                                                            \
234   W_ mp_tmp1;                                                           \
235   W_ mp_tmp2;                                                           \
236   W_ mp_result1;                                                        \
237                                                                         \
238   /* call doYouWantToGC() */                                            \
239   MAYBE_GC(R2_PTR & R4_PTR, name);                                      \
240                                                                         \
241   STK_CHK_GEN( 3 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );              \
242                                                                         \
243   s1 = W_TO_INT(R1);                                                    \
244   d1 = R2;                                                              \
245   s2 = W_TO_INT(R3);                                                    \
246   d2 = R4;                                                              \
247                                                                         \
248   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
249   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                  \
250   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                  \
251   MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(BYTE_ARR_WDS(d1));               \
252   MP_INT__mp_size(mp_tmp1)  = (s1);                                     \
253   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);                         \
254   MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(BYTE_ARR_WDS(d2));               \
255   MP_INT__mp_size(mp_tmp2)  = (s2);                                     \
256   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);                         \
257                                                                         \
258   foreign "C" __gmpz_init(mp_result1 "ptr") [];                         \
259                                                                         \
260   /* Perform the operation */                                           \
261   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1  "ptr",mp_tmp2  "ptr") []; \
262                                                                         \
263   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
264          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
265 }
266
267 #define GMP_TAKE1_UL1_RET1(name,mp_fun)                                 \
268 name                                                                    \
269 {                                                                       \
270   CInt s1;                                                              \
271   W_ d1;                                                                \
272   CInt ul;                                                              \
273   W_ mp_tmp;                                                            \
274   W_ mp_result;                                                         \
275                                                                         \
276   /* call doYouWantToGC() */                                            \
277   MAYBE_GC(R2_PTR, name);                                               \
278                                                                         \
279   STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name );                       \
280                                                                         \
281   s1 = W_TO_INT(R1);                                                    \
282   d1 = R2;                                                              \
283   ul = W_TO_INT(R3);                                                    \
284                                                                         \
285   mp_tmp     = Sp - 1 * SIZEOF_MP_INT;                                  \
286   mp_result  = Sp - 2 * SIZEOF_MP_INT;                                  \
287   MP_INT__mp_alloc(mp_tmp) = W_TO_INT(BYTE_ARR_WDS(d1));                \
288   MP_INT__mp_size(mp_tmp)  = (s1);                                      \
289   MP_INT__mp_d(mp_tmp)     = BYTE_ARR_CTS(d1);                          \
290                                                                         \
291   foreign "C" __gmpz_init(mp_result "ptr") [];                          \
292                                                                         \
293   /* Perform the operation */                                           \
294   foreign "C" mp_fun(mp_result "ptr",mp_tmp "ptr", ul) [];              \
295                                                                         \
296   RET_NP(TO_W_(MP_INT__mp_size(mp_result)),                             \
297          MP_INT__mp_d(mp_result) - SIZEOF_StgArrWords);                 \
298 }
299
300 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
301 name                                                                    \
302 {                                                                       \
303   CInt s1;                                                              \
304   W_ d1;                                                                \
305   W_ mp_tmp1;                                                           \
306   W_ mp_result1;                                                        \
307                                                                         \
308   /* call doYouWantToGC() */                                            \
309   MAYBE_GC(R2_PTR, name);                                               \
310                                                                         \
311   STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name );                       \
312                                                                         \
313   d1 = R2;                                                              \
314   s1 = W_TO_INT(R1);                                                    \
315                                                                         \
316   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
317   mp_result1 = Sp - 2 * SIZEOF_MP_INT;                                  \
318   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(BYTE_ARR_WDS(d1));           \
319   MP_INT__mp_size(mp_tmp1)      = (s1);                                 \
320   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                     \
321                                                                         \
322   foreign "C" __gmpz_init(mp_result1 "ptr") [];                         \
323                                                                         \
324   /* Perform the operation */                                           \
325   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr") [];                \
326                                                                         \
327   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
328          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
329 }
330
331 #define GMP_TAKE2_RET2(name,mp_fun)                                                     \
332 name                                                                                    \
333 {                                                                                       \
334   CInt s1, s2;                                                                          \
335   W_ d1, d2;                                                                            \
336   W_ mp_tmp1;                                                                           \
337   W_ mp_tmp2;                                                                           \
338   W_ mp_result1;                                                                        \
339   W_ mp_result2;                                                                        \
340                                                                                         \
341   /* call doYouWantToGC() */                                                            \
342   MAYBE_GC(R2_PTR & R4_PTR, name);                                                      \
343                                                                                         \
344   STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );                              \
345                                                                                         \
346   s1 = W_TO_INT(R1);                                                                    \
347   d1 = R2;                                                                              \
348   s2 = W_TO_INT(R3);                                                                    \
349   d2 = R4;                                                                              \
350                                                                                         \
351   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                                  \
352   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                                  \
353   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                                  \
354   mp_result2 = Sp - 4 * SIZEOF_MP_INT;                                                  \
355   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(BYTE_ARR_WDS(d1));                           \
356   MP_INT__mp_size(mp_tmp1)      = (s1);                                                 \
357   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                                     \
358   MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(BYTE_ARR_WDS(d2));                           \
359   MP_INT__mp_size(mp_tmp2)      = (s2);                                                 \
360   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);                                     \
361                                                                                         \
362   foreign "C" __gmpz_init(mp_result1 "ptr") [];                                         \
363   foreign "C" __gmpz_init(mp_result2 "ptr") [];                                         \
364                                                                                         \
365   /* Perform the operation */                                                           \
366   foreign "C" mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") []; \
367                                                                                         \
368   RET_NPNP(TO_W_(MP_INT__mp_size(mp_result1)),                                          \
369            MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords,                               \
370            TO_W_(MP_INT__mp_size(mp_result2)),                                          \
371            MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords);                              \
372 }
373
374 GMP_TAKE2_RET1(integer_cmm_plusIntegerzh,     __gmpz_add)
375 GMP_TAKE2_RET1(integer_cmm_minusIntegerzh,    __gmpz_sub)
376 GMP_TAKE2_RET1(integer_cmm_timesIntegerzh,    __gmpz_mul)
377 GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh,      __gmpz_gcd)
378 GMP_TAKE2_RET1(integer_cmm_quotIntegerzh,     __gmpz_tdiv_q)
379 GMP_TAKE2_RET1(integer_cmm_remIntegerzh,      __gmpz_tdiv_r)
380 GMP_TAKE2_RET1(integer_cmm_divIntegerzh,      __gmpz_fdiv_q)
381 GMP_TAKE2_RET1(integer_cmm_modIntegerzh,      __gmpz_fdiv_r)
382 GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact)
383 GMP_TAKE2_RET1(integer_cmm_andIntegerzh,      __gmpz_and)
384 GMP_TAKE2_RET1(integer_cmm_orIntegerzh,       __gmpz_ior)
385 GMP_TAKE2_RET1(integer_cmm_xorIntegerzh,      __gmpz_xor)
386 GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh, __gmpz_mul_2exp)
387 GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh, __gmpz_fdiv_q_2exp)
388 GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com)
389
390 GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr)
391 GMP_TAKE2_RET2(integer_cmm_divModIntegerzh,  __gmpz_fdiv_qr)
392
393 integer_cmm_gcdIntzh
394 {
395     /* R1 = the first Int#; R2 = the second Int# */
396     W_ r;
397     W_ mp_tmp_w;
398
399     STK_CHK_GEN( 1 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_gcdIntzh );
400
401     mp_tmp_w = Sp - 1 * SIZEOF_MP_INT;
402
403     W_[mp_tmp_w] = R1;
404     (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
405
406     R1 = r;
407     /* Result parked in R1, return via info-pointer at TOS */
408     jump %ENTRY_CODE(Sp(0));
409 }
410
411
412 integer_cmm_gcdIntegerIntzh
413 {
414     /* R1 = s1; R2 = d1; R3 = the int */
415     W_ s1;
416     (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
417     R1 = s1;
418
419     /* Result parked in R1, return via info-pointer at TOS */
420     jump %ENTRY_CODE(Sp(0));
421 }
422
423
424 integer_cmm_cmpIntegerIntzh
425 {
426     /* R1 = s1; R2 = d1; R3 = the int */
427     W_ usize, vsize, v_digit, u_digit;
428
429     usize = R1;
430     vsize = 0;
431     v_digit = R3;
432
433     // paraphrased from __gmpz_cmp_si() in the GMP sources
434     if (%gt(v_digit,0)) {
435         vsize = 1;
436     } else {
437         if (%lt(v_digit,0)) {
438             vsize = -1;
439             v_digit = -v_digit;
440         }
441     }
442
443     if (usize != vsize) {
444         R1 = usize - vsize;
445         jump %ENTRY_CODE(Sp(0));
446     }
447
448     if (usize == 0) {
449         R1 = 0;
450         jump %ENTRY_CODE(Sp(0));
451     }
452
453     u_digit = W_[BYTE_ARR_CTS(R2)];
454
455     if (u_digit == v_digit) {
456         R1 = 0;
457         jump %ENTRY_CODE(Sp(0));
458     }
459
460     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
461         R1 = usize;
462     } else {
463         R1 = -usize;
464     }
465
466     jump %ENTRY_CODE(Sp(0));
467 }
468
469 integer_cmm_cmpIntegerzh
470 {
471     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
472     W_ usize, vsize, size, up, vp;
473     CInt cmp;
474
475     // paraphrased from __gmpz_cmp() in the GMP sources
476     usize = R1;
477     vsize = R3;
478
479     if (usize != vsize) {
480         R1 = usize - vsize;
481         jump %ENTRY_CODE(Sp(0));
482     }
483
484     if (usize == 0) {
485         R1 = 0;
486         jump %ENTRY_CODE(Sp(0));
487     }
488
489     if (%lt(usize,0)) { // NB. not <, which is unsigned
490         size = -usize;
491     } else {
492         size = usize;
493     }
494
495     up = BYTE_ARR_CTS(R2);
496     vp = BYTE_ARR_CTS(R4);
497
498     (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];
499
500     if (cmp == 0 :: CInt) {
501         R1 = 0;
502         jump %ENTRY_CODE(Sp(0));
503     }
504
505     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
506         R1 = 1;
507     } else {
508         R1 = (-1);
509     }
510     /* Result parked in R1, return via info-pointer at TOS */
511     jump %ENTRY_CODE(Sp(0));
512 }
513
514 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
515 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
516
517 integer_cmm_decodeDoublezh
518 {
519     D_ arg;
520     W_ p;
521     W_ mp_tmp1;
522     W_ mp_tmp_w;
523
524     STK_CHK_GEN( 2 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_decodeDoublezh );
525
526     mp_tmp1  = Sp - 1 * SIZEOF_MP_INT;
527     mp_tmp_w = Sp - 2 * SIZEOF_MP_INT;
528
529     /* arguments: D1 = Double# */
530     arg = D1;
531
532     ALLOC_PRIM( ARR_SIZE, NO_PTRS, integer_cmm_decodeDoublezh );
533
534     /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble
535        where mantissa.d can be put (it does not care about the rest) */
536     p = Hp - ARR_SIZE + WDS(1);
537     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
538     StgArrWords_bytes(p) = DOUBLE_MANTISSA_SIZE;
539     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
540
541     /* Perform the operation */
542     foreign "C" integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) [];
543
544     /* returns: (Int# (expn), Int#, ByteArray#) */
545     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
546 }