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