1 %---------------------------------------------------------------*
3 \section{Executable code for arithmetic primitives}
5 %---------------------------------------------------------------*
8 /* basic definitions, just as if this were a module */
13 %************************************************************************
15 \subsection[rts-prims-int]{Things for Int}
17 %************************************************************************
19 Well, really just one little devil:
27 if (a >= 0) { return( a / b ); }
28 else { return( ((a+1) / b) - 1 ); }
30 if (a > 0) { return( ((a-1) / b) - 1 ); }
31 else { return( a / b ); }
32 /* ToDo: something for division by zero? */
37 %************************************************************************
39 \subsection[rts-prims-float]{Things for floating-point}
41 %************************************************************************
43 %************************************************************************
45 \subsubsection[rts-mving-float]{Moving floatish things around}
47 %************************************************************************
49 See \tr{imports/StgMacros.h} for more about these things.
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! */
57 ASSIGN_DBL(W_ p_dest[], StgDouble src)
77 ASSIGN_FLT(W_ p_dest[], StgFloat src)
93 #endif /* FLOAT_ALIGNMENT_TROUBLES and not registerizing */
96 %************************************************************************
98 \subsubsection[rts-coding-floats]{Encoding/decoding float-ish things}
100 %************************************************************************
102 Encoding and decoding Doubles. Code based on the HBC 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 */
110 #define DNBIGIT 2 /* mantissa of a double will fit in two longs */
112 #define FNBIGIT 1 /* for float, one long */
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
120 #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1)
121 #define FHIGHBIT 0x00800000
122 #define FMSBIT 0x80000000
136 __encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
142 /* Convert MP_INT to a double; knows a lot about internal rep! */
143 i = __abs(s->size)-1;
147 for(r = s->d[i], i--; i >= 0; i--)
148 r = r * GMP_BASE + s->d[i];
151 /* Now raise to the exponent */
152 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
155 /* sign is encoded in the size */
160 temp = stgMallocBytes(mpz_sizeinbase(s,10)+2);
161 fprintf(stderr, "__encodeDouble(%s, %ld) => %g\n", mpz_get_str(temp,10,s), e, r);
167 #if ! alpha_TARGET_ARCH
168 /* On the alpha, Stg{Floats,Doubles} are the same */
170 __encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
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];
179 /* Now raise to the exponent */
180 if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
183 /* sign is encoded in the size */
192 __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
194 #if ! IEEE_FLOATING_POINT
195 fprintf(stderr, "__decodeDouble: non-IEEE not yet supported\n");
198 #else /* IEEE fl-pt */
199 /* Do some bit fiddling on IEEE */
200 unsigned int low, high; /* assuming 32 bit ints */
202 union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */
205 u.d = dbl; /* grab chunks of the double */
209 /* we know the MP_INT* passed in has size zero, so we realloc
212 man->alloc = DNBIGIT;
214 if (low == 0 && (high & ~DMSBIT) == 0) {
219 iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP;
221 /* fprintf(stderr, "decode %g %08x %08x %d\n", u.d, high, low, iexp); */
224 if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */
228 /* A denorm, normalize the mantissa */
229 while (! (high & DHIGHBIT)) {
243 man->d[0] = ((unsigned long)high) << 32 | (unsigned long)low;
245 error : error : error : Cannae cope with DNBIGIT
249 man->size = -man->size;
253 temp = stgMallocBytes(mpz_sizeinbase(man,10)+2);
254 fprintf(stderr, "__decodeDouble(%g) => %s, %ld\n", dbl, mpz_get_str(temp,10,man), *exp);
257 #endif /* IEEE fl-pt */
260 #if ! alpha_TARGET_ARCH
261 /* Again, on the alpha we do not have separate "StgFloat" routines */
263 __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt)
265 #if ! IEEE_FLOATING_POINT
266 fprintf(stderr, "__decodeFloat: non-IEEE not yet supported\n");
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 */
274 u.f = flt; /* grab the float */
277 /* we know the MP_INT* passed in has size zero, so we realloc
280 man->alloc = FNBIGIT;
282 if ((high & ~FMSBIT) == 0) {
287 *exp = ((high >> 23) & 0xff) + MY_FMINEXP;
291 if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */
295 /* A denorm, normalize the mantissa */
296 while (! (high & FHIGHBIT)) {
304 error : error : error : Cannae cope with FNBIGIT
307 man->size = -man->size;
310 #endif /* IEEE fl-pt */
315 %************************************************************************
317 \subsection[rts-prims-integer]{Things for Integers (using GNU MP pkg)}
319 %************************************************************************
321 See ghc/compiler/prelude/TyInteger.lhs for the comment on this stuff.
323 %************************************************************************
325 \subsubsection[rts-gmp-alloc]{Our custom memory allocation routines}
327 %************************************************************************
329 The GMP documentation says what these must do.
333 StgInt DEBUG_GMPAllocBudget = 0;
334 /* # of _words_ known to be available for stgAllocForGMP */
338 stgAllocForGMP (size_in_bytes)
339 size_t size_in_bytes;
342 I_ data_size_in_words, total_size_in_words;
344 /* the new object will be "DATA_HS + BYTES_TO_STGWORDS(size_in_bytes)" words
346 data_size_in_words = BYTES_TO_STGWORDS(size_in_bytes);
347 total_size_in_words = DATA_HS + data_size_in_words;
349 /* Check that we are within the current budget */
350 if (DEBUG_GMPAllocBudget < total_size_in_words) {
351 fprintf(stderr, "stgAllocForGMP: budget error: %ld %ld\n",
352 DEBUG_GMPAllocBudget, total_size_in_words);
356 DEBUG_GMPAllocBudget -= total_size_in_words;
360 /* if it's a DATA thingy, we'd better fill it in.
362 SET_DATA_HDR(SAVE_Hp+1,ArrayOfData_info,CCC,DATA_VHS+data_size_in_words,0);
364 /* we're gonna return a pointer to the non-hdr part of the beast
366 stuff_ptr = (void *) (SAVE_Hp + 1 + DATA_HS);
368 /* move the heap pointer right along...
369 (tell [ticky-ticky and regular] profiling about it, too)
371 SAVE_Hp += total_size_in_words;
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);
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).
382 /* and return what we said we would */
387 stgReallocForGMP (ptr, old_size, new_size)
389 size_t old_size, new_size;
391 void *new_stuff_ptr = stgAllocForGMP(new_size);
393 char *p = (char *) ptr;
394 char *q = (char *) new_stuff_ptr;
396 for (; i < old_size; i++, p++, q++) {
400 return(new_stuff_ptr);
404 stgDeallocForGMP (ptr, size)
408 /* easy for us: the garbage collector does the dealloc'n */