Don't put "extra-libraries: gmp" in the cabal file; it comes from the buildinfo file
[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 #ifdef __PIC__
32 #ifndef mingw32_HOST_OS
33 import __gmpz_init;
34 import __gmpz_add;
35 import __gmpz_sub;
36 import __gmpz_mul;
37 import __gmpz_gcd;
38 import __gmpn_gcd_1;
39 import __gmpn_cmp;
40 import __gmpz_tdiv_q;
41 import __gmpz_tdiv_r;
42 import __gmpz_tdiv_qr;
43 import __gmpz_fdiv_qr;
44 import __gmpz_divexact;
45 import __gmpz_and;
46 import __gmpz_xor;
47 import __gmpz_ior;
48 import __gmpz_com;
49 #endif
50 #endif
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, W_[CCCS]);
70    StgArrWords_words(p) = 1;
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, W_[CCCS]);
104    StgArrWords_words(p) = 1;
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 #ifdef SUPPORT_LONG_LONGS
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, W_[CCCS]);
151    StgArrWords_words(p) = 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, W_[CCCS]);
206    StgArrWords_words(p) = 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 /* SUPPORT_LONG_LONGS */
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   W_ mp_result2;                                                        \
238                                                                         \
239   /* call doYouWantToGC() */                                            \
240   MAYBE_GC(R2_PTR & R4_PTR, name);                                      \
241                                                                         \
242   STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );              \
243                                                                         \
244   s1 = W_TO_INT(R1);                                                    \
245   d1 = R2;                                                              \
246   s2 = W_TO_INT(R3);                                                    \
247   d2 = R4;                                                              \
248                                                                         \
249   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
250   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                  \
251   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                  \
252   mp_result2 = Sp - 4 * SIZEOF_MP_INT;                                  \
253   MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1));          \
254   MP_INT__mp_size(mp_tmp1)  = (s1);                                     \
255   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);                         \
256   MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2));          \
257   MP_INT__mp_size(mp_tmp2)  = (s2);                                     \
258   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);                         \
259                                                                         \
260   foreign "C" __gmpz_init(mp_result1 "ptr") [];                            \
261                                                                         \
262   /* Perform the operation */                                           \
263   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1  "ptr",mp_tmp2  "ptr") []; \
264                                                                         \
265   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
266          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
267 }
268
269 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
270 name                                                                    \
271 {                                                                       \
272   CInt s1;                                                              \
273   W_ d1;                                                                \
274   W_ mp_tmp1;                                                           \
275   W_ mp_result1;                                                        \
276                                                                         \
277   /* call doYouWantToGC() */                                            \
278   MAYBE_GC(R2_PTR, name);                                               \
279                                                                         \
280   STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name );                       \
281                                                                         \
282   d1 = R2;                                                              \
283   s1 = W_TO_INT(R1);                                                    \
284                                                                         \
285   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
286   mp_result1 = Sp - 2 * SIZEOF_MP_INT;                                  \
287   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));      \
288   MP_INT__mp_size(mp_tmp1)      = (s1);                                 \
289   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                     \
290                                                                         \
291   foreign "C" __gmpz_init(mp_result1 "ptr") [];                            \
292                                                                         \
293   /* Perform the operation */                                           \
294   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr") [];                \
295                                                                         \
296   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
297          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
298 }
299
300 #define GMP_TAKE2_RET2(name,mp_fun)                                                     \
301 name                                                                                    \
302 {                                                                                       \
303   CInt s1, s2;                                                                          \
304   W_ d1, d2;                                                                            \
305   W_ mp_tmp1;                                                                           \
306   W_ mp_tmp2;                                                                           \
307   W_ mp_result1;                                                                        \
308   W_ mp_result2;                                                                        \
309                                                                                         \
310   /* call doYouWantToGC() */                                                            \
311   MAYBE_GC(R2_PTR & R4_PTR, name);                                                      \
312                                                                                         \
313   STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );                              \
314                                                                                         \
315   s1 = W_TO_INT(R1);                                                                    \
316   d1 = R2;                                                                              \
317   s2 = W_TO_INT(R3);                                                                    \
318   d2 = R4;                                                                              \
319                                                                                         \
320   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                                  \
321   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                                  \
322   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                                  \
323   mp_result2 = Sp - 4 * SIZEOF_MP_INT;                                                  \
324   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));                      \
325   MP_INT__mp_size(mp_tmp1)      = (s1);                                                 \
326   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                                     \
327   MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(StgArrWords_words(d2));                      \
328   MP_INT__mp_size(mp_tmp2)      = (s2);                                                 \
329   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);                                     \
330                                                                                         \
331   foreign "C" __gmpz_init(mp_result1 "ptr") [];                                               \
332   foreign "C" __gmpz_init(mp_result2 "ptr") [];                                               \
333                                                                                         \
334   /* Perform the operation */                                                           \
335   foreign "C" mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") [];    \
336                                                                                         \
337   RET_NPNP(TO_W_(MP_INT__mp_size(mp_result1)),                                          \
338            MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords,                               \
339            TO_W_(MP_INT__mp_size(mp_result2)),                                          \
340            MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords);                              \
341 }
342
343 GMP_TAKE2_RET1(integer_cmm_plusIntegerzh,     __gmpz_add)
344 GMP_TAKE2_RET1(integer_cmm_minusIntegerzh,    __gmpz_sub)
345 GMP_TAKE2_RET1(integer_cmm_timesIntegerzh,    __gmpz_mul)
346 GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh,      __gmpz_gcd)
347 GMP_TAKE2_RET1(integer_cmm_quotIntegerzh,     __gmpz_tdiv_q)
348 GMP_TAKE2_RET1(integer_cmm_remIntegerzh,      __gmpz_tdiv_r)
349 GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact)
350 GMP_TAKE2_RET1(integer_cmm_andIntegerzh,      __gmpz_and)
351 GMP_TAKE2_RET1(integer_cmm_orIntegerzh,       __gmpz_ior)
352 GMP_TAKE2_RET1(integer_cmm_xorIntegerzh,      __gmpz_xor)
353 GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com)
354
355 GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr)
356 GMP_TAKE2_RET2(integer_cmm_divModIntegerzh,  __gmpz_fdiv_qr)
357
358 integer_cmm_gcdIntzh
359 {
360     /* R1 = the first Int#; R2 = the second Int# */
361     W_ r;
362     W_ mp_tmp_w;
363
364     STK_CHK_GEN( 1 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_gcdIntzh );
365
366     mp_tmp_w = Sp - 1 * SIZEOF_MP_INT;
367
368     W_[mp_tmp_w] = R1;
369     (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
370
371     R1 = r;
372     /* Result parked in R1, return via info-pointer at TOS */
373     jump %ENTRY_CODE(Sp(0));
374 }
375
376
377 integer_cmm_gcdIntegerIntzh
378 {
379     /* R1 = s1; R2 = d1; R3 = the int */
380     W_ s1;
381     (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
382     R1 = s1;
383
384     /* Result parked in R1, return via info-pointer at TOS */
385     jump %ENTRY_CODE(Sp(0));
386 }
387
388
389 integer_cmm_cmpIntegerIntzh
390 {
391     /* R1 = s1; R2 = d1; R3 = the int */
392     W_ usize, vsize, v_digit, u_digit;
393
394     usize = R1;
395     vsize = 0;
396     v_digit = R3;
397
398     // paraphrased from __gmpz_cmp_si() in the GMP sources
399     if (%gt(v_digit,0)) {
400         vsize = 1;
401     } else {
402         if (%lt(v_digit,0)) {
403             vsize = -1;
404             v_digit = -v_digit;
405         }
406     }
407
408     if (usize != vsize) {
409         R1 = usize - vsize;
410         jump %ENTRY_CODE(Sp(0));
411     }
412
413     if (usize == 0) {
414         R1 = 0;
415         jump %ENTRY_CODE(Sp(0));
416     }
417
418     u_digit = W_[BYTE_ARR_CTS(R2)];
419
420     if (u_digit == v_digit) {
421         R1 = 0;
422         jump %ENTRY_CODE(Sp(0));
423     }
424
425     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
426         R1 = usize;
427     } else {
428         R1 = -usize;
429     }
430
431     jump %ENTRY_CODE(Sp(0));
432 }
433
434 integer_cmm_cmpIntegerzh
435 {
436     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
437     W_ usize, vsize, size, up, vp;
438     CInt cmp;
439
440     // paraphrased from __gmpz_cmp() in the GMP sources
441     usize = R1;
442     vsize = R3;
443
444     if (usize != vsize) {
445         R1 = usize - vsize;
446         jump %ENTRY_CODE(Sp(0));
447     }
448
449     if (usize == 0) {
450         R1 = 0;
451         jump %ENTRY_CODE(Sp(0));
452     }
453
454     if (%lt(usize,0)) { // NB. not <, which is unsigned
455         size = -usize;
456     } else {
457         size = usize;
458     }
459
460     up = BYTE_ARR_CTS(R2);
461     vp = BYTE_ARR_CTS(R4);
462
463     (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];
464
465     if (cmp == 0 :: CInt) {
466         R1 = 0;
467         jump %ENTRY_CODE(Sp(0));
468     }
469
470     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
471         R1 = 1;
472     } else {
473         R1 = (-1);
474     }
475     /* Result parked in R1, return via info-pointer at TOS */
476     jump %ENTRY_CODE(Sp(0));
477 }
478
479 integer_cmm_integer2Intzh
480 {
481     /* R1 = s; R2 = d */
482     W_ r, s;
483
484     s = R1;
485     if (s == 0) {
486         r = 0;
487     } else {
488         r = W_[R2 + SIZEOF_StgArrWords];
489         if (%lt(s,0)) {
490             r = -r;
491         }
492     }
493     /* Result parked in R1, return via info-pointer at TOS */
494     R1 = r;
495     jump %ENTRY_CODE(Sp(0));
496 }
497
498 integer_cmm_integer2Wordzh
499 {
500   /* R1 = s; R2 = d */
501   W_ r, s;
502
503   s = R1;
504   if (s == 0) {
505     r = 0;
506   } else {
507     r = W_[R2 + SIZEOF_StgArrWords];
508     if (%lt(s,0)) {
509         r = -r;
510     }
511   }
512   /* Result parked in R1, return via info-pointer at TOS */
513   R1 = r;
514   jump %ENTRY_CODE(Sp(0));
515 }
516
517 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
518 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
519
520 integer_cmm_decodeDoublezh
521 {
522     D_ arg;
523     W_ p;
524     W_ mp_tmp1;
525     W_ mp_tmp_w;
526
527     STK_CHK_GEN( 2 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_decodeDoublezh );
528
529     mp_tmp1  = Sp - 1 * SIZEOF_MP_INT;
530     mp_tmp_w = Sp - 2 * SIZEOF_MP_INT;
531
532     /* arguments: D1 = Double# */
533     arg = D1;
534
535     ALLOC_PRIM( ARR_SIZE, NO_PTRS, integer_cmm_decodeDoublezh );
536
537     /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble
538        where mantissa.d can be put (it does not care about the rest) */
539     p = Hp - ARR_SIZE + WDS(1);
540     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
541     StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
542     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
543
544     /* Perform the operation */
545     foreign "C" integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) [];
546
547     /* returns: (Int# (expn), Int#, ByteArray#) */
548     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
549 }