X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fruntime%2Fprims%2FPrimArith.lc;fp=ghc%2Fruntime%2Fprims%2FPrimArith.lc;h=0000000000000000000000000000000000000000;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=22646ef73b8ec259e519c7baea846082187d82ce;hpb=967cc47f37cb93a5e2b6df7822c9a646f0428247;p=ghc-hetmet.git diff --git a/ghc/runtime/prims/PrimArith.lc b/ghc/runtime/prims/PrimArith.lc deleted file mode 100644 index 22646ef..0000000 --- a/ghc/runtime/prims/PrimArith.lc +++ /dev/null @@ -1,427 +0,0 @@ -%---------------------------------------------------------------* -% -\section{Executable code for arithmetic primitives} -% -%---------------------------------------------------------------* - -\begin{code} -/* basic definitions, just as if this were a module */ - -/* - Sigh, ieee-flpt.h (which we need here) uses - __GLASGOW_HASKELL__ in a place or two to check - whether it is being included in a Haskell source file - or not. This is no longer the case! __GLASGOW_HASKELL__ - is also defined when compiling .c files (C code that - depend on the RTS API needs to know this). - - An unfortunate state of affairs, but since this is - the only place where the two uses of __GLASGOW_HASKELL__ - clash, we hack around and undefine it before including - the header file. -- sof 8/98 -*/ -#ifdef __GLASGOW_HASKELL__ -#undef __GLASGOW_HASKELL__ -#endif - -#include "rtsdefs.h" -\end{code} - -%************************************************************************ -%* * -\subsection[rts-prims-int]{Things for Int} -%* * -%************************************************************************ - -Well, really just one little devil: - -\begin{code} -I_ -stg_div(a, b) - I_ a, b; -{ - if (b >= 0) { - if (a >= 0) { return( a / b ); } - else { return( ((a+1) / b) - 1 ); } - } else { - if (a > 0) { return( ((a-1) / b) - 1 ); } - else { return( a / b ); } - /* ToDo: something for division by zero? */ - } -} -\end{code} - -%************************************************************************ -%* * -\subsection[rts-prims-float]{Things for floating-point} -%* * -%************************************************************************ - -%************************************************************************ -%* * -\subsubsection[rts-mving-float]{Moving floatish things around} -%* * -%************************************************************************ - -See \tr{imports/StgMacros.h} for more about these things. -\begin{code} -#if defined(FLOAT_ALIGNMENT_TROUBLES) && ! defined(__STG_GCC_REGS__) -/* Not all machines suffer from these (e.g., m68k). */ -/* If we are registerizing, we must *not* have this code! */ - -STG_INLINE -void -ASSIGN_DBL(W_ p_dest[], StgDouble src) -{ - double_thing y; - y.d = src; - p_dest[0] = y.du.dhi; - p_dest[1] = y.du.dlo; -} - -STG_INLINE -StgDouble -PK_DBL(W_ p_src[]) -{ - double_thing y; - y.du.dhi = p_src[0]; - y.du.dlo = p_src[1]; - return(y.d); -} - -STG_INLINE -void -ASSIGN_FLT(W_ p_dest[], StgFloat src) -{ - float_thing y; - y.f = src; - *p_dest = y.fu; -} - -STG_INLINE -StgFloat -PK_FLT(W_ p_src[]) -{ - float_thing y; - y.fu = *p_src; - return(y.f); -} - -#endif /* FLOAT_ALIGNMENT_TROUBLES and not registerizing */ -\end{code} - -%************************************************************************ -%* * -\subsubsection[rts-coding-floats]{Encoding/decoding float-ish things} -%* * -%************************************************************************ - -Encoding and decoding Doubles. Code based on the HBC code -(lib/fltcode.c). - -\begin{code} -#define GMP_BASE 4294967296.0 -#if alpha_TARGET_ARCH -#define DNBIGIT 1 /* mantissa of a double will fit in one long */ -#else -#define DNBIGIT 2 /* mantissa of a double will fit in two longs */ -#endif -#define FNBIGIT 1 /* for float, one long */ - -#if IEEE_FLOATING_POINT -#define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) -/* DMINEXP is defined in values.h on Linux (for example) */ -#define DHIGHBIT 0x00100000 -#define DMSBIT 0x80000000 - -#define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1) -#define FHIGHBIT 0x00800000 -#define FMSBIT 0x80000000 -#endif - -#ifdef BIGENDIAN -#define L 1 -#define H 0 -#else -#define L 0 -#define H 1 -#endif -\end{code} - -\begin{code} -StgDouble -__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */ -{ - StgDouble r; - I_ i; -/* char *temp; */ - - /* Convert MP_INT to a double; knows a lot about internal rep! */ - i = __abs(s->size)-1; - if (i < 0) { - r = 0.0; - } else { - for(r = s->d[i], i--; i >= 0; i--) - r = r * GMP_BASE + s->d[i]; - } - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (s->size < 0) - r = -r; - -/* - temp = stgMallocBytes(mpz_sizeinbase(s,10)+2); - fprintf(stderr, "__encodeDouble(%s, %ld) => %g\n", mpz_get_str(temp,10,s), e, r); -*/ - - return r; -} - -#if ! alpha_TARGET_ARCH - /* On the alpha, Stg{Floats,Doubles} are the same */ -StgFloat -__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */ -{ - StgFloat r; - I_ i; - - /* Convert MP_INT to a float; knows a lot about internal rep! */ - for(r = 0.0, i = __abs(s->size)-1; i >= 0; i--) - r = (r * GMP_BASE) + s->d[i]; - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (s->size < 0) - r = -r; - - return r; -} -#endif /* alpha */ - -void -__decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) -{ -#if ! IEEE_FLOATING_POINT - fprintf(stderr, "__decodeDouble: non-IEEE not yet supported\n"); - abort(); - -#else /* IEEE fl-pt */ - /* Do some bit fiddling on IEEE */ - unsigned int low, high; /* assuming 32 bit ints */ - int sign, iexp; - union { double d; int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ -/* char *temp; */ - - u.d = dbl; /* grab chunks of the double */ - low = u.i[L]; - high = u.i[H]; - - /* we know the MP_INT* passed in has size zero, so we realloc - no matter what. - */ - man->alloc = DNBIGIT; - - if (low == 0 && (high & ~DMSBIT) == 0) { - man->size = 0; - *exp = 0L; - } else { - man->size = DNBIGIT; - iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; - sign = high; - /* fprintf(stderr, "decode %g %08x %08x %d\n", u.d, high, low, iexp); */ - - high &= DHIGHBIT-1; - if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ - high |= DHIGHBIT; - else { - iexp++; - /* A denorm, normalize the mantissa */ - while (! (high & DHIGHBIT)) { - high <<= 1; - if (low & DMSBIT) - high++; - low <<= 1; - iexp--; - } - } - *exp = (I_) iexp; -#if DNBIGIT == 2 - man->d[0] = low; - man->d[1] = high; -#else -#if DNBIGIT == 1 - man->d[0] = ((unsigned long)high) << 32 | (unsigned long)low; -#else - error : error : error : Cannae cope with DNBIGIT -#endif -#endif - if (sign < 0) - man->size = -man->size; - } - -/* - temp = stgMallocBytes(mpz_sizeinbase(man,10)+2); - fprintf(stderr, "__decodeDouble(%g) => %s, %ld\n", dbl, mpz_get_str(temp,10,man), *exp); -*/ - -#endif /* IEEE fl-pt */ -} - -#if ! alpha_TARGET_ARCH - /* Again, on the alpha we do not have separate "StgFloat" routines */ -void -__decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) -{ -#if ! IEEE_FLOATING_POINT - fprintf(stderr, "__decodeFloat: non-IEEE not yet supported\n"); - abort(); - -#else /* IEEE fl-pt */ - /* Do some bit fiddling on IEEE */ - int high, sign; /* assuming 32 bit ints */ - union { float f; int i; } u; /* assuming 32 bit float and int */ - - u.f = flt; /* grab the float */ - high = u.i; - - /* we know the MP_INT* passed in has size zero, so we realloc - no matter what. - */ - man->alloc = FNBIGIT; - - if ((high & ~FMSBIT) == 0) { - man->size = 0; - *exp = 0; - } else { - man->size = FNBIGIT; - *exp = ((high >> 23) & 0xff) + MY_FMINEXP; - sign = high; - - high &= FHIGHBIT-1; - if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */ - high |= FHIGHBIT; - else { - (*exp)++; - /* A denorm, normalize the mantissa */ - while (! (high & FHIGHBIT)) { - high <<= 1; - (*exp)--; - } - } -#if FNBIGIT == 1 - man->d[0] = high; -#else - error : error : error : Cannae cope with FNBIGIT -#endif - if (sign < 0) - man->size = -man->size; - } - -#endif /* IEEE fl-pt */ -} -#endif /* alpha */ -\end{code} - -%************************************************************************ -%* * -\subsection[rts-prims-integer]{Things for Integers (using GNU MP pkg)} -%* * -%************************************************************************ - -See ghc/compiler/prelude/TyInteger.lhs for the comment on this stuff. - -%************************************************************************ -%* * -\subsubsection[rts-gmp-alloc]{Our custom memory allocation routines} -%* * -%************************************************************************ - -The GMP documentation says what these must do. - -\begin{code} -#ifdef ALLOC_DEBUG -StgInt DEBUG_GMPAllocBudget = 0; - /* # of _words_ known to be available for stgAllocForGMP */ -#endif - -void * -stgAllocForGMP (size_in_bytes) - size_t size_in_bytes; -{ - void *stuff_ptr; - I_ data_size_in_words, total_size_in_words; - - /* the new object will be "DATA_HS + BYTES_TO_STGWORDS(size_in_bytes)" words - */ - data_size_in_words = BYTES_TO_STGWORDS(size_in_bytes); - total_size_in_words = DATA_HS + data_size_in_words; -#ifdef ALLOC_DEBUG - /* Check that we are within the current budget */ - if (DEBUG_GMPAllocBudget < total_size_in_words) { - fprintf(stderr, "stgAllocForGMP: budget error: %ld %ld\n", - DEBUG_GMPAllocBudget, total_size_in_words); - abort(); - } - else { - DEBUG_GMPAllocBudget -= total_size_in_words; - } -#endif - - /* if it's a DATA thingy, we'd better fill it in. - */ - SET_DATA_HDR(SAVE_Hp+1,ArrayOfData_info,CCC,DATA_VHS+data_size_in_words,0); - - /* we're gonna return a pointer to the non-hdr part of the beast - */ - stuff_ptr = (void *) (SAVE_Hp + 1 + DATA_HS); - - /* move the heap pointer right along... - (tell [ticky-ticky and regular] profiling about it, too) - */ - SAVE_Hp += total_size_in_words; - - ALLOC_HEAP(total_size_in_words); /* ticky-ticky profiling */ -/* ALLOC_CON(DATA_HS,data_size_in_words,0); */ - ALLOC_PRIM(DATA_HS,data_size_in_words,0,total_size_in_words); - - CC_ALLOC(CCC,total_size_in_words,CON_K); /* cc profiling */ - /* NB: HACK WARNING: The above line will do The WRONG THING - if the CurrCostCentre reg is ever put in a Real Machine Register (TM). - */ - - /* and return what we said we would */ - return(stuff_ptr); -} - -void * -stgReallocForGMP (ptr, old_size, new_size) - void *ptr; - size_t old_size, new_size; -{ - void *new_stuff_ptr = stgAllocForGMP(new_size); - unsigned int i = 0; - char *p = (char *) ptr; - char *q = (char *) new_stuff_ptr; - - for (; i < old_size; i++, p++, q++) { - *q = *p; - } - - return(new_stuff_ptr); -} - -void -stgDeallocForGMP (ptr, size) - void *ptr; - size_t size; -{ - /* easy for us: the garbage collector does the dealloc'n */ -} -\end{code}