002aa04599ee6f4f7fc3dd09bbcfa84c86039e17
[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   CLong 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_divExactIntegerzh, __gmpz_divexact)
381 GMP_TAKE2_RET1(integer_cmm_andIntegerzh,      __gmpz_and)
382 GMP_TAKE2_RET1(integer_cmm_orIntegerzh,       __gmpz_ior)
383 GMP_TAKE2_RET1(integer_cmm_xorIntegerzh,      __gmpz_xor)
384 GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh, __gmpz_mul_2exp)
385 GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh, __gmpz_fdiv_q_2exp)
386 GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com)
387
388 GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr)
389 GMP_TAKE2_RET2(integer_cmm_divModIntegerzh,  __gmpz_fdiv_qr)
390
391 integer_cmm_gcdIntzh
392 {
393     /* R1 = the first Int#; R2 = the second Int# */
394     W_ r;
395     W_ mp_tmp_w;
396
397     STK_CHK_GEN( 1 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_gcdIntzh );
398
399     mp_tmp_w = Sp - 1 * SIZEOF_MP_INT;
400
401     W_[mp_tmp_w] = R1;
402     (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
403
404     R1 = r;
405     /* Result parked in R1, return via info-pointer at TOS */
406     jump %ENTRY_CODE(Sp(0));
407 }
408
409
410 integer_cmm_gcdIntegerIntzh
411 {
412     /* R1 = s1; R2 = d1; R3 = the int */
413     W_ s1;
414     (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
415     R1 = s1;
416
417     /* Result parked in R1, return via info-pointer at TOS */
418     jump %ENTRY_CODE(Sp(0));
419 }
420
421
422 integer_cmm_cmpIntegerIntzh
423 {
424     /* R1 = s1; R2 = d1; R3 = the int */
425     W_ usize, vsize, v_digit, u_digit;
426
427     usize = R1;
428     vsize = 0;
429     v_digit = R3;
430
431     // paraphrased from __gmpz_cmp_si() in the GMP sources
432     if (%gt(v_digit,0)) {
433         vsize = 1;
434     } else {
435         if (%lt(v_digit,0)) {
436             vsize = -1;
437             v_digit = -v_digit;
438         }
439     }
440
441     if (usize != vsize) {
442         R1 = usize - vsize;
443         jump %ENTRY_CODE(Sp(0));
444     }
445
446     if (usize == 0) {
447         R1 = 0;
448         jump %ENTRY_CODE(Sp(0));
449     }
450
451     u_digit = W_[BYTE_ARR_CTS(R2)];
452
453     if (u_digit == v_digit) {
454         R1 = 0;
455         jump %ENTRY_CODE(Sp(0));
456     }
457
458     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
459         R1 = usize;
460     } else {
461         R1 = -usize;
462     }
463
464     jump %ENTRY_CODE(Sp(0));
465 }
466
467 integer_cmm_cmpIntegerzh
468 {
469     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
470     W_ usize, vsize, size, up, vp;
471     CInt cmp;
472
473     // paraphrased from __gmpz_cmp() in the GMP sources
474     usize = R1;
475     vsize = R3;
476
477     if (usize != vsize) {
478         R1 = usize - vsize;
479         jump %ENTRY_CODE(Sp(0));
480     }
481
482     if (usize == 0) {
483         R1 = 0;
484         jump %ENTRY_CODE(Sp(0));
485     }
486
487     if (%lt(usize,0)) { // NB. not <, which is unsigned
488         size = -usize;
489     } else {
490         size = usize;
491     }
492
493     up = BYTE_ARR_CTS(R2);
494     vp = BYTE_ARR_CTS(R4);
495
496     (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];
497
498     if (cmp == 0 :: CInt) {
499         R1 = 0;
500         jump %ENTRY_CODE(Sp(0));
501     }
502
503     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
504         R1 = 1;
505     } else {
506         R1 = (-1);
507     }
508     /* Result parked in R1, return via info-pointer at TOS */
509     jump %ENTRY_CODE(Sp(0));
510 }
511
512 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
513 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
514
515 integer_cmm_decodeDoublezh
516 {
517     D_ arg;
518     W_ p;
519     W_ mp_tmp1;
520     W_ mp_tmp_w;
521
522     STK_CHK_GEN( 2 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_decodeDoublezh );
523
524     mp_tmp1  = Sp - 1 * SIZEOF_MP_INT;
525     mp_tmp_w = Sp - 2 * SIZEOF_MP_INT;
526
527     /* arguments: D1 = Double# */
528     arg = D1;
529
530     ALLOC_PRIM( ARR_SIZE, NO_PTRS, integer_cmm_decodeDoublezh );
531
532     /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble
533        where mantissa.d can be put (it does not care about the rest) */
534     p = Hp - ARR_SIZE + WDS(1);
535     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
536     StgArrWords_bytes(p) = DOUBLE_MANTISSA_SIZE;
537     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
538
539     /* Perform the operation */
540     foreign "C" integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) [];
541
542     /* returns: (Int# (expn), Int#, ByteArray#) */
543     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
544 }