/* -----------------------------------------------------------------------------
 *
 * (c) The GHC Team, 1998-2004
 *
 * 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"

#ifdef __PIC__
#ifndef mingw32_HOST_OS
import __gmpz_init;
import __gmpz_add;
import __gmpz_sub;
import __gmpz_mul;
import __gmpz_gcd;
import __gmpn_gcd_1;
import __gmpn_cmp;
import __gmpz_tdiv_q;
import __gmpz_tdiv_r;
import __gmpz_tdiv_qr;
import __gmpz_fdiv_qr;
import __gmpz_divexact;
import __gmpz_and;
import __gmpz_xor;
import __gmpz_ior;
import __gmpz_com;
#endif
#endif

/* -----------------------------------------------------------------------------
   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.
   -------------------------------------------------------------------------- */

integer_cmm_int2Integerzh
{
   /* arguments: R1 = Int# */

   W_ val, s, p; /* to avoid aliasing */

   val = R1;
   ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_int2Integerzh );

   p = Hp - SIZEOF_StgArrWords;
   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
   StgArrWords_words(p) = 1;

   /* 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#
               #)
   */
   RET_NP(s,p);
}

integer_cmm_word2Integerzh
{
   /* arguments: R1 = Word# */

   W_ val, s, p; /* to avoid aliasing */

   val = R1;

   ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_word2Integerzh);

   p = Hp - SIZEOF_StgArrWords;
   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
   StgArrWords_words(p) = 1;

   if (val != 0) {
        s = 1;
        W_[Hp] = val;
   } else {
        s = 0;
   }

   /* returns (# size  :: Int#,
                 data  :: ByteArray# #)
   */
   RET_NP(s,p);
}


/*
 * 'long long' primops for converting to/from Integers.
 */

#if WORD_SIZE_IN_BITS < 64

integer_cmm_int64ToIntegerzh
{
   /* arguments: L1 = Int64# */

   L_ val;
   W_ hi, lo, s, neg, words_needed, p;

   val = L1;
   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),
               NO_PTRS, integer_cmm_int64ToIntegerzh );

   p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
   StgArrWords_words(p) = 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# #)
   */
   RET_NP(s,p);
}
integer_cmm_word64ToIntegerzh
{
   /* arguments: L1 = Word64# */

   L_ val;
   W_ hi, lo, s, words_needed, p;

   val = L1;
   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),
               NO_PTRS, integer_cmm_word64ToIntegerzh );

   p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
   StgArrWords_words(p) = 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# #)
   */
   RET_NP(s,p);
}

#endif /* WORD_SIZE_IN_BITS < 64 */

#define GMP_TAKE2_RET1(name,mp_fun)                                     \
name                                                                    \
{                                                                       \
  CInt s1, s2;                                                          \
  W_ d1, d2;                                                            \
  W_ mp_tmp1;                                                           \
  W_ mp_tmp2;                                                           \
  W_ mp_result1;                                                        \
                                                                        \
  /* call doYouWantToGC() */                                            \
  MAYBE_GC(R2_PTR & R4_PTR, name);                                      \
                                                                        \
  STK_CHK_GEN( 3 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );              \
                                                                        \
  s1 = W_TO_INT(R1);                                                    \
  d1 = R2;                                                              \
  s2 = W_TO_INT(R3);                                                    \
  d2 = R4;                                                              \
                                                                        \
  mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
  mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                  \
  mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                  \
  MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1));          \
  MP_INT__mp_size(mp_tmp1)  = (s1);                                     \
  MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);                         \
  MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2));          \
  MP_INT__mp_size(mp_tmp2)  = (s2);                                     \
  MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);                         \
                                                                        \
  foreign "C" __gmpz_init(mp_result1 "ptr") [];                         \
                                                                        \
  /* Perform the operation */                                           \
  foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1  "ptr",mp_tmp2  "ptr") []; \
                                                                        \
  RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
         MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
}

#define GMP_TAKE1_UL1_RET1(name,mp_fun)                                 \
name                                                                    \
{                                                                       \
  CInt s1;                                                              \
  W_ d1;                                                                \
  CLong ul;                                                             \
  W_ mp_tmp;                                                            \
  W_ mp_result;                                                         \
                                                                        \
  /* call doYouWantToGC() */                                            \
  MAYBE_GC(R2_PTR, name);                                               \
                                                                        \
  STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name );                       \
                                                                        \
  s1 = W_TO_INT(R1);                                                    \
  d1 = R2;                                                              \
  ul = R3;                                                              \
                                                                        \
  mp_tmp     = Sp - 1 * SIZEOF_MP_INT;                                  \
  mp_result  = Sp - 2 * SIZEOF_MP_INT;                                  \
  MP_INT__mp_alloc(mp_tmp) = W_TO_INT(StgArrWords_words(d1));           \
  MP_INT__mp_size(mp_tmp)  = (s1);                                      \
  MP_INT__mp_d(mp_tmp)     = BYTE_ARR_CTS(d1);                          \
                                                                        \
  foreign "C" __gmpz_init(mp_result "ptr") [];                          \
                                                                        \
  /* Perform the operation */                                           \
  foreign "C" mp_fun(mp_result "ptr",mp_tmp "ptr", ul) [];              \
                                                                        \
  RET_NP(TO_W_(MP_INT__mp_size(mp_result)),                             \
         MP_INT__mp_d(mp_result) - SIZEOF_StgArrWords);                 \
}

#define GMP_TAKE1_RET1(name,mp_fun)                                     \
name                                                                    \
{                                                                       \
  CInt s1;                                                              \
  W_ d1;                                                                \
  W_ mp_tmp1;                                                           \
  W_ mp_result1;                                                        \
                                                                        \
  /* call doYouWantToGC() */                                            \
  MAYBE_GC(R2_PTR, name);                                               \
                                                                        \
  STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name );                       \
                                                                        \
  d1 = R2;                                                              \
  s1 = W_TO_INT(R1);                                                    \
                                                                        \
  mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                  \
  mp_result1 = Sp - 2 * SIZEOF_MP_INT;                                  \
  MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));      \
  MP_INT__mp_size(mp_tmp1)      = (s1);                                 \
  MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                     \
                                                                        \
  foreign "C" __gmpz_init(mp_result1 "ptr") [];                         \
                                                                        \
  /* Perform the operation */                                           \
  foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr") [];                \
                                                                        \
  RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
         MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
}

#define GMP_TAKE2_RET2(name,mp_fun)                                                     \
name                                                                                    \
{                                                                                       \
  CInt s1, s2;                                                                          \
  W_ d1, d2;                                                                            \
  W_ mp_tmp1;                                                                           \
  W_ mp_tmp2;                                                                           \
  W_ mp_result1;                                                                        \
  W_ mp_result2;                                                                        \
                                                                                        \
  /* call doYouWantToGC() */                                                            \
  MAYBE_GC(R2_PTR & R4_PTR, name);                                                      \
                                                                                        \
  STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name );                              \
                                                                                        \
  s1 = W_TO_INT(R1);                                                                    \
  d1 = R2;                                                                              \
  s2 = W_TO_INT(R3);                                                                    \
  d2 = R4;                                                                              \
                                                                                        \
  mp_tmp1    = Sp - 1 * SIZEOF_MP_INT;                                                  \
  mp_tmp2    = Sp - 2 * SIZEOF_MP_INT;                                                  \
  mp_result1 = Sp - 3 * SIZEOF_MP_INT;                                                  \
  mp_result2 = Sp - 4 * SIZEOF_MP_INT;                                                  \
  MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));                      \
  MP_INT__mp_size(mp_tmp1)      = (s1);                                                 \
  MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                                     \
  MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(StgArrWords_words(d2));                      \
  MP_INT__mp_size(mp_tmp2)      = (s2);                                                 \
  MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);                                     \
                                                                                        \
  foreign "C" __gmpz_init(mp_result1 "ptr") [];                                         \
  foreign "C" __gmpz_init(mp_result2 "ptr") [];                                         \
                                                                                        \
  /* Perform the operation */                                                           \
  foreign "C" mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") []; \
                                                                                        \
  RET_NPNP(TO_W_(MP_INT__mp_size(mp_result1)),                                          \
           MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords,                               \
           TO_W_(MP_INT__mp_size(mp_result2)),                                          \
           MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords);                              \
}

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_TAKE2_RET1(integer_cmm_gcdIntegerzh,      __gmpz_gcd)
GMP_TAKE2_RET1(integer_cmm_quotIntegerzh,     __gmpz_tdiv_q)
GMP_TAKE2_RET1(integer_cmm_remIntegerzh,      __gmpz_tdiv_r)
GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact)
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_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_TAKE2_RET2(integer_cmm_divModIntegerzh,  __gmpz_fdiv_qr)

integer_cmm_gcdIntzh
{
    /* R1 = the first Int#; R2 = the second Int# */
    W_ r;
    W_ mp_tmp_w;

    STK_CHK_GEN( 1 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_gcdIntzh );

    mp_tmp_w = Sp - 1 * SIZEOF_MP_INT;

    W_[mp_tmp_w] = R1;
    (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];

    R1 = r;
    /* Result parked in R1, return via info-pointer at TOS */
    jump %ENTRY_CODE(Sp(0));
}


integer_cmm_gcdIntegerIntzh
{
    /* R1 = s1; R2 = d1; R3 = the int */
    W_ s1;
    (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
    R1 = s1;

    /* Result parked in R1, return via info-pointer at TOS */
    jump %ENTRY_CODE(Sp(0));
}


integer_cmm_cmpIntegerIntzh
{
    /* R1 = s1; R2 = d1; R3 = the int */
    W_ usize, vsize, v_digit, u_digit;

    usize = R1;
    vsize = 0;
    v_digit = R3;

    // 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) {
        R1 = usize - vsize;
        jump %ENTRY_CODE(Sp(0));
    }

    if (usize == 0) {
        R1 = 0;
        jump %ENTRY_CODE(Sp(0));
    }

    u_digit = W_[BYTE_ARR_CTS(R2)];

    if (u_digit == v_digit) {
        R1 = 0;
        jump %ENTRY_CODE(Sp(0));
    }

    if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
        R1 = usize;
    } else {
        R1 = -usize;
    }

    jump %ENTRY_CODE(Sp(0));
}

integer_cmm_cmpIntegerzh
{
    /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
    W_ usize, vsize, size, up, vp;
    CInt cmp;

    // paraphrased from __gmpz_cmp() in the GMP sources
    usize = R1;
    vsize = R3;

    if (usize != vsize) {
        R1 = usize - vsize;
        jump %ENTRY_CODE(Sp(0));
    }

    if (usize == 0) {
        R1 = 0;
        jump %ENTRY_CODE(Sp(0));
    }

    if (%lt(usize,0)) { // NB. not <, which is unsigned
        size = -usize;
    } else {
        size = usize;
    }

    up = BYTE_ARR_CTS(R2);
    vp = BYTE_ARR_CTS(R4);

    (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];

    if (cmp == 0 :: CInt) {
        R1 = 0;
        jump %ENTRY_CODE(Sp(0));
    }

    if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
        R1 = 1;
    } else {
        R1 = (-1);
    }
    /* Result parked in R1, return via info-pointer at TOS */
    jump %ENTRY_CODE(Sp(0));
}

integer_cmm_integer2Intzh
{
    /* R1 = s; R2 = d */
    W_ r, s;

    s = R1;
    if (s == 0) {
        r = 0;
    } else {
        r = W_[R2 + SIZEOF_StgArrWords];
        if (%lt(s,0)) {
            r = -r;
        }
    }
    /* Result parked in R1, return via info-pointer at TOS */
    R1 = r;
    jump %ENTRY_CODE(Sp(0));
}

integer_cmm_integer2Wordzh
{
  /* R1 = s; R2 = d */
  W_ r, s;

  s = R1;
  if (s == 0) {
    r = 0;
  } else {
    r = W_[R2 + SIZEOF_StgArrWords];
    if (%lt(s,0)) {
        r = -r;
    }
  }
  /* Result parked in R1, return via info-pointer at TOS */
  R1 = r;
  jump %ENTRY_CODE(Sp(0));
}

#define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
#define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)

integer_cmm_decodeDoublezh
{
    D_ arg;
    W_ p;
    W_ mp_tmp1;
    W_ mp_tmp_w;

    STK_CHK_GEN( 2 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_decodeDoublezh );

    mp_tmp1  = Sp - 1 * SIZEOF_MP_INT;
    mp_tmp_w = Sp - 2 * SIZEOF_MP_INT;

    /* arguments: D1 = Double# */
    arg = D1;

    ALLOC_PRIM( ARR_SIZE, NO_PTRS, integer_cmm_decodeDoublezh );

    /* 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, W_[CCCS]);
    StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
    MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);

    /* Perform the operation */
    foreign "C" integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) [];

    /* returns: (Int# (expn), Int#, ByteArray#) */
    RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
}