ghc/runtime/prims/PrimArith.lc

   1 %---------------------------------------------------------------*
   2 %
   3 \section{Executable code for arithmetic primitives}
   4 %
   5 %---------------------------------------------------------------*
   6
   7 \begin{code}
   8 /* basic definitions, just as if this were a module */
   9
  10 #include "rtsdefs.h"
  11 \end{code}
  12
  13 %************************************************************************
  14 %*                                                                      *
  15 \subsection[rts-prims-int]{Things for Int}
  16 %*                                                                      *
  17 %************************************************************************
  18
  19 Well, really just one little devil:
  20
  21 \begin{code}
  22 I_
  23 stg_div(a, b)
  24   I_ a, b;
  25 {
  26     if (b >= 0) {
  27         if (a >= 0) { return( a / b ); }
  28         else        { return( ((a+1) / b) - 1 ); }
  29     } else {
  30         if (a > 0)  { return( ((a-1) / b) - 1 ); }
  31         else        { return( a / b ); }
  32         /* ToDo: something for division by zero? */
  33     }
  34 }
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[rts-prims-float]{Things for floating-point}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsubsection[rts-mving-float]{Moving floatish things around}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 See \tr{imports/StgMacros.h} for more about these things.
  50 \begin{code}
  51 #if defined(FLOAT_ALIGNMENT_TROUBLES) && ! defined(__STG_GCC_REGS__)
  52 /* Not all machines suffer from these (e.g., m68k). */
  53 /* If we are registerizing, we must *not* have this code! */
  54
  55 STG_INLINE
  56 void
  57 ASSIGN_DBL(W_ p_dest[], StgDouble src)
  58 {
  59     double_thing y;
  60     y.d = src;
  61     p_dest[0] = y.du.dhi;
  62     p_dest[1] = y.du.dlo;
  63 }
  64
  65 STG_INLINE
  66 StgDouble
  67 PK_DBL(W_ p_src[])
  68 {
  69     double_thing y;
  70     y.du.dhi = p_src[0];
  71     y.du.dlo = p_src[1];
  72     return(y.d);
  73 }
  74
  75 STG_INLINE
  76 void
  77 ASSIGN_FLT(W_ p_dest[], StgFloat src)
  78 {
  79     float_thing y;
  80     y.f = src;
  81     *p_dest = y.fu;
  82 }
  83
  84 STG_INLINE
  85 StgFloat
  86 PK_FLT(W_ p_src[])
  87 {
  88     float_thing y;
  89     y.fu = *p_src;
  90     return(y.f);
  91 }
  92
  93 #endif /* FLOAT_ALIGNMENT_TROUBLES and not registerizing */
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsubsection[rts-coding-floats]{Encoding/decoding float-ish things}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 Encoding and decoding Doubles.  Code based on the HBC code
 103 (lib/fltcode.c).
 104
 105 \begin{code}
 106 #define GMP_BASE 4294967296.0
 107 #if alpha_TARGET_ARCH
 108 #define DNBIGIT 1   /* mantissa of a double will fit in one long */
 109 #else
 110 #define DNBIGIT  2  /* mantissa of a double will fit in two longs */
 111 #endif
 112 #define FNBIGIT  1  /* for float, one long */
 113
 114 #if IEEE_FLOATING_POINT
 115 #define MY_DMINEXP  ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1)
 116 /* DMINEXP is defined in values.h on Linux (for example) */
 117 #define DHIGHBIT 0x00100000
 118 #define DMSBIT   0x80000000
 119
 120 #define MY_FMINEXP  ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
 121 #define FHIGHBIT 0x00800000
 122 #define FMSBIT   0x80000000
 123 #endif
 124
 125 #ifdef BIGENDIAN
 126 #define L 1
 127 #define H 0
 128 #else
 129 #define L 0
 130 #define H 1
 131 #endif
 132 \end{code}
 133
 134 \begin{code}
 135 StgDouble
 136 __encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
 137 {
 138     StgDouble r;
 139     I_ i;
 140 /*  char *temp; */
 141
 142     /* Convert MP_INT to a double; knows a lot about internal rep! */
 143     i = __abs(s->size)-1;
 144     if (i < 0) {
 145         r = 0.0;
 146     } else {
 147         for(r = s->d[i], i--; i >= 0; i--)
 148             r = r * GMP_BASE + s->d[i];
 149     }
 150
 151     /* Now raise to the exponent */
 152     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
 153         r = ldexp(r, e);
 154
 155     /* sign is encoded in the size */
 156     if (s->size < 0)
 157         r = -r;
 158
 159 /*
 160     temp = stgMallocBytes(mpz_sizeinbase(s,10)+2);
 161     fprintf(stderr, "__encodeDouble(%s, %ld) => %g\n", mpz_get_str(temp,10,s), e, r);
 162 */
 163
 164     return r;
 165 }
 166
 167 #if ! alpha_TARGET_ARCH
 168     /* On the alpha, Stg{Floats,Doubles} are the same */
 169 StgFloat
 170 __encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
 171 {
 172     StgFloat r;
 173     I_ i;
 174
 175     /* Convert MP_INT to a float; knows a lot about internal rep! */
 176     for(r = 0.0, i = __abs(s->size)-1; i >= 0; i--)
 177         r = (r * GMP_BASE) + s->d[i];
 178
 179     /* Now raise to the exponent */
 180     if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
 181         r = ldexp(r, e);
 182
 183     /* sign is encoded in the size */
 184     if (s->size < 0)
 185         r = -r;
 186
 187     return r;
 188 }
 189 #endif  /* alpha */
 190
 191 void
 192 __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
 193 {
 194 #if ! IEEE_FLOATING_POINT
 195     fprintf(stderr, "__decodeDouble: non-IEEE not yet supported\n");
 196     abort();
 197
 198 #else /* IEEE fl-pt */
 199     /* Do some bit fiddling on IEEE */
 200     unsigned int low, high;             /* assuming 32 bit ints */
 201     int sign, iexp;
 202     union { double d; int i[2]; } u;    /* assuming 32 bit ints, 64 bit double */
 203 /*  char *temp; */
 204
 205     u.d = dbl;      /* grab chunks of the double */
 206     low = u.i[L];
 207     high = u.i[H];
 208
 209     /* we know the MP_INT* passed in has size zero, so we realloc
 210         no matter what.
 211     */
 212     man->alloc = DNBIGIT;
 213
 214     if (low == 0 && (high & ~DMSBIT) == 0) {
 215         man->size = 0;
 216         *exp = 0L;
 217     } else {
 218         man->size = DNBIGIT;
 219         iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
 220         sign = high;
 221         /* fprintf(stderr, "decode %g %08x %08x %d\n", u.d, high, low, iexp); */
 222
 223         high &= DHIGHBIT-1;
 224         if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
 225             high |= DHIGHBIT;
 226         else {
 227             iexp++;
 228             /* A denorm, normalize the mantissa */
 229             while (! (high & DHIGHBIT)) {
 230                 high <<= 1;
 231                 if (low & DMSBIT)
 232                     high++;
 233                 low <<= 1;
 234                 iexp--;
 235             }
 236         }
 237         *exp = (I_) iexp;
 238 #if DNBIGIT == 2
 239         man->d[0] = low;
 240         man->d[1] = high;
 241 #else
 242 #if DNBIGIT == 1
 243         man->d[0] = ((unsigned long)high) << 32 | (unsigned long)low;
 244 #else
 245         error : error : error : Cannae cope with DNBIGIT
 246 #endif
 247 #endif
 248         if (sign < 0)
 249             man->size = -man->size;
 250     }
 251
 252 /*
 253     temp = stgMallocBytes(mpz_sizeinbase(man,10)+2);
 254     fprintf(stderr, "__decodeDouble(%g) => %s, %ld\n", dbl, mpz_get_str(temp,10,man), *exp);
 255 */
 256
 257 #endif /* IEEE fl-pt */
 258 }
 259
 260 #if ! alpha_TARGET_ARCH
 261     /* Again, on the alpha we do not have separate "StgFloat" routines */
 262 void
 263 __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt)
 264 {
 265 #if ! IEEE_FLOATING_POINT
 266     fprintf(stderr, "__decodeFloat: non-IEEE not yet supported\n");
 267     abort();
 268
 269 #else /* IEEE fl-pt */
 270     /* Do some bit fiddling on IEEE */
 271     int high, sign;                 /* assuming 32 bit ints */
 272     union { float f; int i; } u;    /* assuming 32 bit float and int */
 273
 274     u.f = flt;      /* grab the float */
 275     high = u.i;
 276
 277     /* we know the MP_INT* passed in has size zero, so we realloc
 278         no matter what.
 279     */
 280     man->alloc = FNBIGIT;
 281
 282     if ((high & ~FMSBIT) == 0) {
 283         man->size = 0;
 284         *exp = 0;
 285     } else {
 286         man->size = FNBIGIT;
 287         *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
 288         sign = high;
 289
 290         high &= FHIGHBIT-1;
 291         if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
 292             high |= FHIGHBIT;
 293         else {
 294             (*exp)++;
 295             /* A denorm, normalize the mantissa */
 296             while (! (high & FHIGHBIT)) {
 297                 high <<= 1;
 298                 (*exp)--;
 299             }
 300         }
 301 #if FNBIGIT == 1
 302         man->d[0] = high;
 303 #else
 304         error : error : error : Cannae cope with FNBIGIT
 305 #endif
 306         if (sign < 0)
 307             man->size = -man->size;
 308     }
 309
 310 #endif /* IEEE fl-pt */
 311 }
 312 #endif  /* alpha */
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection[rts-prims-integer]{Things for Integers (using GNU MP pkg)}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 See ghc/compiler/prelude/TyInteger.lhs for the comment on this stuff.
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 \subsubsection[rts-gmp-alloc]{Our custom memory allocation routines}
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 The GMP documentation says what these must do.
 330
 331 \begin{code}
 332 #ifdef ALLOC_DEBUG
 333 StgInt DEBUG_GMPAllocBudget = 0;
 334         /* # of _words_ known to be available for stgAllocForGMP */
 335 #endif
 336
 337 void *
 338 stgAllocForGMP (size_in_bytes)
 339   size_t size_in_bytes;
 340 {
 341     void   *stuff_ptr;
 342     I_  data_size_in_words, total_size_in_words;
 343
 344     /*  the new object will be "DATA_HS + BYTES_TO_STGWORDS(size_in_bytes)" words
 345     */
 346     data_size_in_words  = BYTES_TO_STGWORDS(size_in_bytes);
 347     total_size_in_words = DATA_HS + data_size_in_words;
 348
 349 #ifdef ALLOC_DEBUG
 350         /* Check that we are within the current budget */
 351     if (DEBUG_GMPAllocBudget < total_size_in_words) {
 352         fprintf(stderr, "stgAllocForGMP: budget error: %ld %ld\n",
 353                         DEBUG_GMPAllocBudget, total_size_in_words);
 354         abort();
 355     }
 356     else
 357         DEBUG_GMPAllocBudget -= total_size_in_words;
 358 #endif
 359
 360     /*  if it's a DATA thingy, we'd better fill it in.
 361     */
 362     SET_DATA_HDR(SAVE_Hp+1,ArrayOfData_info,CCC,DATA_VHS+data_size_in_words,0);
 363
 364     /*  we're gonna return a pointer to the non-hdr part of the beast
 365     */
 366     stuff_ptr = (void *) (SAVE_Hp + 1 + DATA_HS);
 367
 368     /*  move the heap pointer right along...
 369         (tell [ticky-ticky and regular] profiling about it, too)
 370     */
 371     SAVE_Hp += total_size_in_words;
 372
 373     ALLOC_HEAP(total_size_in_words); /* ticky-ticky profiling */
 374 /*  ALLOC_CON(DATA_HS,data_size_in_words,0); */
 375     ALLOC_PRIM(DATA_HS,data_size_in_words,0,total_size_in_words);
 376
 377     CC_ALLOC(CCC,total_size_in_words,CON_K); /* cc profiling */
 378     /* NB: HACK WARNING: The above line will do The WRONG THING
 379         if the CurrCostCentre reg is ever put in a Real Machine Register (TM).
 380     */
 381
 382     /* and return what we said we would */
 383     return(stuff_ptr);
 384 }
 385
 386 void *
 387 stgReallocForGMP (ptr, old_size, new_size)
 388   void *ptr;
 389   size_t   old_size, new_size;
 390 {
 391     void *new_stuff_ptr = stgAllocForGMP(new_size);
 392     unsigned int i = 0;
 393     char *p = (char *) ptr;
 394     char *q = (char *) new_stuff_ptr;
 395
 396     for (; i < old_size; i++, p++, q++) {
 397         *q = *p;
 398     }
 399
 400     return(new_stuff_ptr);
 401 }
 402
 403 void
 404 stgDeallocForGMP (ptr, size)
 405   void *ptr;
 406   size_t   size;
 407 {
 408     /* easy for us: the garbage collector does the dealloc'n */
 409 }
 410 \end{code}