8a201f12d002a55a57796143adb7cc501bd15382
[packages/integer-gmp.git] / cbits / gmp-wrappers.cmm
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-2012
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_tstbit;
37 import "integer-gmp" __gmpz_fdiv_q_2exp;
38 import "integer-gmp" __gmpz_gcd;
39 import "integer-gmp" __gmpn_gcd_1;
40 import "integer-gmp" __gmpn_cmp;
41 import "integer-gmp" __gmpz_tdiv_q;
42 import "integer-gmp" __gmpz_tdiv_r;
43 import "integer-gmp" __gmpz_fdiv_q;
44 import "integer-gmp" __gmpz_fdiv_r;
45 import "integer-gmp" __gmpz_tdiv_qr;
46 import "integer-gmp" __gmpz_fdiv_qr;
47 import "integer-gmp" __gmpz_divexact;
48 import "integer-gmp" __gmpz_and;
49 import "integer-gmp" __gmpz_xor;
50 import "integer-gmp" __gmpz_ior;
51 import "integer-gmp" __gmpz_com;
52
53 import "integer-gmp" integer_cbits_decodeDouble;
54
55 /* -----------------------------------------------------------------------------
56    Arbitrary-precision Integer operations.
57
58    There are some assumptions in this code that mp_limb_t == W_.  This is
59    the case for all the platforms that GHC supports, currently.
60    -------------------------------------------------------------------------- */
61
62 integer_cmm_int2Integerzh (W_ val)
63 {
64    W_ s, p; /* to avoid aliasing */
65
66    ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_int2Integerzh, val);
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    return (s,p);
90 }
91
92 integer_cmm_word2Integerzh (W_ val)
93 {
94    W_ s, p; /* to avoid aliasing */
95
96    ALLOC_PRIM_N (SIZEOF_StgArrWords + WDS(1), integer_cmm_word2Integerzh, val);
97
98    p = Hp - SIZEOF_StgArrWords;
99    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
100    StgArrWords_bytes(p) = SIZEOF_W;
101
102    if (val != 0) {
103         s = 1;
104         W_[Hp] = val;
105    } else {
106         s = 0;
107    }
108
109    /* returns (# size  :: Int#,
110                  data  :: ByteArray# #)
111    */
112    return (s,p);
113 }
114
115
116 /*
117  * 'long long' primops for converting to/from Integers.
118  */
119
120 #if WORD_SIZE_IN_BITS < 64
121
122 integer_cmm_int64ToIntegerzh (L_ val)
123 {
124    W_ hi, lo, s, neg, words_needed, p;
125
126    neg = 0;
127
128    hi = TO_W_(val >> 32);
129    lo = TO_W_(val);
130
131    if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) )  {
132        // minimum is one word
133        words_needed = 1;
134    } else {
135        words_needed = 2;
136    }
137
138    ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed));
139
140    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
141    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
142    StgArrWords_bytes(p) = WDS(words_needed);
143
144    if ( %lt(hi,0) ) {
145      neg = 1;
146      lo = -lo;
147      if(lo == 0) {
148        hi = -hi;
149      } else {
150        hi = -hi - 1;
151      }
152    }
153
154    if ( words_needed == 2 )  {
155       s = 2;
156       Hp(-1) = lo;
157       Hp(0) = hi;
158    } else {
159        if ( lo != 0 ) {
160            s = 1;
161            Hp(0) = lo;
162        } else /* val==0 */  {
163            s = 0;
164        }
165    }
166    if ( neg != 0 ) {
167         s = -s;
168    }
169
170    /* returns (# size  :: Int#,
171                  data  :: ByteArray# #)
172    */
173    return (s,p);
174 }
175 integer_cmm_word64ToIntegerzh (L_ val)
176 {
177    W_ hi, lo, s, words_needed, p;
178
179    hi = TO_W_(val >> 32);
180    lo = TO_W_(val);
181
182    if ( hi != 0 ) {
183       words_needed = 2;
184    } else {
185       words_needed = 1;
186    }
187
188    ALLOC_PRIM (SIZEOF_StgArrWords + WDS(words_needed));
189
190    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
191    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
192    StgArrWords_bytes(p) = WDS(words_needed);
193
194    if ( hi != 0 ) {
195      s = 2;
196      Hp(-1) = lo;
197      Hp(0)  = hi;
198    } else {
199       if ( lo != 0 ) {
200         s = 1;
201         Hp(0) = lo;
202      } else /* val==0 */  {
203       s = 0;
204      }
205   }
206
207    /* returns (# size  :: Int#,
208                  data  :: ByteArray# #)
209    */
210    return (s,p);
211 }
212
213 #endif /* WORD_SIZE_IN_BITS < 64 */
214
215 #define GMP_TAKE2_RET1(name,mp_fun)                             \
216 name (W_ ws1, P_ d1, W_ ws2, P_ d2)                             \
217 {                                                               \
218   CInt s1, s2;                                                  \
219   W_ mp_tmp1;                                                   \
220   W_ mp_tmp2;                                                   \
221   W_ mp_result1;                                                \
222                                                                 \
223 again:                                                          \
224   STK_CHK_GEN_N (3 * SIZEOF_MP_INT);                            \
225   MAYBE_GC(again);                                              \
226                                                                 \
227   s1 = W_TO_INT(ws1);                                           \
228   s2 = W_TO_INT(ws2);                                           \
229                                                                 \
230   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                          \
231   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                          \
232   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                          \
233   MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(BYTE_ARR_WDS(d1));       \
234   MP_INT__mp_size(mp_tmp1)  = (s1);                             \
235   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);                 \
236   MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(BYTE_ARR_WDS(d2));       \
237   MP_INT__mp_size(mp_tmp2)  = (s2);                             \
238   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);                 \
239                                                                 \
240   ccall __gmpz_init(mp_result1 "ptr");                          \
241                                                                 \
242   /* Perform the operation */                                   \
243   ccall mp_fun(mp_result1 "ptr",mp_tmp1  "ptr",mp_tmp2  "ptr"); \
244                                                                 \
245   return (TO_W_(MP_INT__mp_size(mp_result1)),                   \
246          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);        \
247 }
248
249 #define GMP_TAKE1_UL1_RET1(name,mp_fun)                         \
250 name (W_ ws1, P_ d1, W_ wul)                                    \
251 {                                                               \
252   CInt s1;                                                      \
253   CLong ul;                                                     \
254   W_ mp_tmp;                                                    \
255   W_ mp_result;                                                 \
256                                                                 \
257   /* call doYouWantToGC() */                                    \
258 again:                                                          \
259   STK_CHK_GEN_N (2 * SIZEOF_MP_INT);                            \
260   MAYBE_GC(again);                                              \
261                                                                 \
262   s1 = W_TO_INT(ws1);                                           \
263   ul = W_TO_LONG(wul);                                          \
264                                                                 \
265   mp_tmp     = Sp - 1 * SIZEOF_MP_INT;                          \
266   mp_result  = Sp - 2 * SIZEOF_MP_INT;                          \
267   MP_INT__mp_alloc(mp_tmp) = W_TO_INT(BYTE_ARR_WDS(d1));        \
268   MP_INT__mp_size(mp_tmp)  = (s1);                              \
269   MP_INT__mp_d(mp_tmp)     = BYTE_ARR_CTS(d1);                  \
270                                                                 \
271   ccall __gmpz_init(mp_result "ptr");                           \
272                                                                 \
273   /* Perform the operation */                                   \
274   ccall mp_fun(mp_result "ptr",mp_tmp "ptr", ul);               \
275                                                                 \
276   return(TO_W_(MP_INT__mp_size(mp_result)),                     \
277          MP_INT__mp_d(mp_result) - SIZEOF_StgArrWords);         \
278 }
279
280 #define GMP_TAKE1_UL1_RETI1(name,mp_fun)                        \
281 name (W_ ws1, P_ d1, W_ wul)                                     \
282 {                                                               \
283   CInt s1, res;                                                 \
284   CLong ul;                                                     \
285   W_ mp_tmp;                                                    \
286                                                                 \
287 again:                                                          \
288   STK_CHK_GEN_N (SIZEOF_MP_INT);                                \
289   MAYBE_GC(again);                                              \
290                                                                 \
291   s1 = W_TO_INT(ws1);                                           \
292   ul = W_TO_LONG(wul);                                          \
293                                                                 \
294   mp_tmp     = Sp - 1 * SIZEOF_MP_INT;                          \
295   MP_INT__mp_alloc(mp_tmp) = W_TO_INT(BYTE_ARR_WDS(d1));        \
296   MP_INT__mp_size(mp_tmp)  = (s1);                              \
297   MP_INT__mp_d(mp_tmp)     = BYTE_ARR_CTS(d1);                  \
298                                                                 \
299   /* Perform the operation */                                   \
300   (res) = ccall mp_fun(mp_tmp "ptr", ul);                       \
301                                                                 \
302   return (TO_W_(res));                                          \
303 }
304
305 #define GMP_TAKE1_RET1(name,mp_fun)                             \
306 name (W_ ws1, P_ d1)                                            \
307 {                                                               \
308   CInt s1;                                                      \
309   W_ mp_tmp1;                                                   \
310   W_ mp_result1;                                                \
311                                                                 \
312 again:                                                          \
313   STK_CHK_GEN_N (2 * SIZEOF_MP_INT);                            \
314   MAYBE_GC(again);                                              \
315                                                                 \
316   s1 = W_TO_INT(ws1);                                           \
317                                                                 \
318   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                          \
319   mp_result1 = Sp - 2 * SIZEOF_MP_INT;                          \
320   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(BYTE_ARR_WDS(d1));   \
321   MP_INT__mp_size(mp_tmp1)      = (s1);                         \
322   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);             \
323                                                                 \
324   ccall __gmpz_init(mp_result1 "ptr");                          \
325                                                                 \
326   /* Perform the operation */                                   \
327   ccall mp_fun(mp_result1 "ptr",mp_tmp1 "ptr");                 \
328                                                                 \
329   return(TO_W_(MP_INT__mp_size(mp_result1)),                    \
330          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);        \
331 }
332
333 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
334 name (W_ ws1, P_ d1, W_ ws2, P_ d2)                                     \
335 {                                                                       \
336   CInt s1, s2;                                                          \
337   W_ mp_tmp1;                                                           \
338   W_ mp_tmp2;                                                           \
339   W_ mp_result1;                                                        \
340   W_ mp_result2;                                                        \
341                                                                         \
342 again:                                                                  \
343   STK_CHK_GEN_N (4 * SIZEOF_MP_INT);                                    \
344   MAYBE_GC(again);                                                      \
345                                                                         \
346   s1 = W_TO_INT(ws1);                                                   \
347   s2 = W_TO_INT(ws2);                                                   \
348                                                                         \
349   mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
350   mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                  \
351   mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                  \
352   mp_result2 = Sp - 4 * SIZEOF_MP_INT;                                  \
353   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(BYTE_ARR_WDS(d1));           \
354   MP_INT__mp_size(mp_tmp1)      = (s1);                                 \
355   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                     \
356   MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(BYTE_ARR_WDS(d2));           \
357   MP_INT__mp_size(mp_tmp2)      = (s2);                                 \
358   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);                     \
359                                                                         \
360   ccall __gmpz_init(mp_result1 "ptr");                                  \
361   ccall __gmpz_init(mp_result2 "ptr");                                  \
362                                                                         \
363   /* Perform the operation */                                           \
364   ccall mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr"); \
365                                                                         \
366   return (TO_W_(MP_INT__mp_size(mp_result1)),                           \
367            MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords,               \
368            TO_W_(MP_INT__mp_size(mp_result2)),                          \
369            MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords);              \
370 }
371
372 GMP_TAKE2_RET1(integer_cmm_plusIntegerzh,           __gmpz_add)
373 GMP_TAKE2_RET1(integer_cmm_minusIntegerzh,          __gmpz_sub)
374 GMP_TAKE2_RET1(integer_cmm_timesIntegerzh,          __gmpz_mul)
375 GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh,            __gmpz_gcd)
376 GMP_TAKE2_RET1(integer_cmm_quotIntegerzh,           __gmpz_tdiv_q)
377 GMP_TAKE2_RET1(integer_cmm_remIntegerzh,            __gmpz_tdiv_r)
378 GMP_TAKE2_RET1(integer_cmm_divIntegerzh,            __gmpz_fdiv_q)
379 GMP_TAKE2_RET1(integer_cmm_modIntegerzh,            __gmpz_fdiv_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_RETI1(integer_cmm_testBitIntegerzh,   __gmpz_tstbit)
385 GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh,    __gmpz_mul_2exp)
386 GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh,  __gmpz_fdiv_q_2exp)
387 GMP_TAKE1_RET1(integer_cmm_complementIntegerzh,     __gmpz_com)
388
389 GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh,        __gmpz_tdiv_qr)
390 GMP_TAKE2_RET2(integer_cmm_divModIntegerzh,         __gmpz_fdiv_qr)
391
392 integer_cmm_gcdIntzh (W_ int1, W_ int2)
393 {
394     W_ r;
395     W_ mp_tmp_w;
396
397     STK_CHK_GEN_N (1 * SIZEOF_W);
398
399     mp_tmp_w = Sp - 1 * SIZEOF_W;
400
401     W_[mp_tmp_w] = int1;
402     (r) = ccall __gmpn_gcd_1(mp_tmp_w "ptr", 1, int2);
403
404     return (r);
405 }
406
407
408 integer_cmm_gcdIntegerIntzh (W_ s1, P_ d1, W_ int)
409 {
410     W_ r;
411     (r) = ccall __gmpn_gcd_1 (BYTE_ARR_CTS(d1) "ptr", s1, int);
412     return (r);
413 }
414
415
416 integer_cmm_cmpIntegerIntzh (W_ usize, P_ d1, W_ v_digit)
417 {
418     W_ vsize, u_digit;
419
420     vsize = 0;
421
422     // paraphrased from __gmpz_cmp_si() in the GMP sources
423     if (%gt(v_digit,0)) {
424         vsize = 1;
425     } else {
426         if (%lt(v_digit,0)) {
427             vsize = -1;
428             v_digit = -v_digit;
429         }
430     }
431
432     if (usize != vsize) {
433         return (usize - vsize);
434     }
435
436     if (usize == 0) {
437         return (0);
438     }
439
440     u_digit = W_[BYTE_ARR_CTS(d1)];
441
442     if (u_digit == v_digit) {
443         return (0);
444     }
445
446     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
447         return (usize);
448     } else {
449         return (-usize);
450     }
451 }
452
453 integer_cmm_cmpIntegerzh (W_ usize, P_ d1, W_ vsize, P_ d2)
454 {
455     W_ size, up, vp;
456     CInt cmp;
457
458     // paraphrased from __gmpz_cmp() in the GMP sources
459
460     if (usize != vsize) {
461         return (usize - vsize);
462     }
463
464     if (usize == 0) {
465         return (0);
466     }
467
468     if (%lt(usize,0)) { // NB. not <, which is unsigned
469         size = -usize;
470     } else {
471         size = usize;
472     }
473
474     up = BYTE_ARR_CTS(d1);
475     vp = BYTE_ARR_CTS(d2);
476
477     (cmp) = ccall __gmpn_cmp(up "ptr", vp "ptr", size);
478
479     if (cmp == 0 :: CInt) {
480         return (0);
481     }
482
483     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
484         return (1);
485     } else {
486         return (-1);
487     }
488 }
489
490 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
491 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
492
493 integer_cmm_decodeDoublezh (D_ arg)
494 {
495     D_ arg;
496     W_ p;
497     W_ mp_tmp1;
498     W_ mp_tmp_w;
499
500     STK_CHK_GEN_N (2 * SIZEOF_MP_INT);
501     ALLOC_PRIM (ARR_SIZE);
502
503     mp_tmp1  = Sp - 1 * SIZEOF_MP_INT;
504     mp_tmp_w = Sp - 2 * SIZEOF_MP_INT;
505
506     /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble
507        where mantissa.d can be put (it does not care about the rest) */
508     p = Hp - ARR_SIZE + WDS(1);
509     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
510     StgArrWords_bytes(p) = DOUBLE_MANTISSA_SIZE;
511     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
512
513     /* Perform the operation */
514     ccall integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg);
515
516     /* returns: (Int# (expn), Int#, ByteArray#) */
517     return (W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
518 }