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