X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FStgPrimFloat.c;h=a0cc95dce54c2a1632da5d465e2acb729363cab8;hb=50afb3c579d9eba76f4433881f3a8c67c11fa8bc;hp=111cccea5efc6a3d8a866e99831ca17543f6db76;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/rts/StgPrimFloat.c b/ghc/rts/StgPrimFloat.c index 111ccce..a0cc95d 100644 --- a/ghc/rts/StgPrimFloat.c +++ b/ghc/rts/StgPrimFloat.c @@ -1,24 +1,42 @@ /* ----------------------------------------------------------------------------- - * $Id: StgPrimFloat.c,v 1.2 1998/12/02 13:28:53 simonm Exp $ + * $Id: StgPrimFloat.c,v 1.9 2002/07/17 09:21:51 simonmar Exp $ + * + * (c) The GHC Team, 1998-2000 * * Miscellaneous support for floating-point primitives * * ---------------------------------------------------------------------------*/ +#include "PosixSource.h" #include "Rts.h" +#include + /* * Encoding and decoding Doubles. Code based on the HBC code * (lib/fltcode.c). */ +#ifdef _SHORT_LIMB +#define SIZEOF_LIMB_T SIZEOF_UNSIGNED_INT +#else +#ifdef _LONG_LONG_LIMB +#define SIZEOF_LIMB_T SIZEOF_UNSIGNED_LONG_LONG +#else +#define SIZEOF_LIMB_T SIZEOF_UNSIGNED_LONG +#endif +#endif + +#if SIZEOF_LIMB_T == 4 #define GMP_BASE 4294967296.0 -#if FLOATS_AS_DOUBLES /* defined in StgTypes.h */ -#define DNBIGIT 1 /* mantissa of a double will fit in one long */ +#elif SIZEOF_LIMB_T == 8 +#define GMP_BASE 18446744073709551616.0 #else -#define DNBIGIT 2 /* mantissa of a double will fit in two longs */ +#error Cannot cope with SIZEOF_LIMB_T -- please add definition of GMP_BASE #endif -#define FNBIGIT 1 /* for float, one long */ + +#define DNBIGIT ((SIZEOF_DOUBLE+SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T) +#define FNBIGIT ((SIZEOF_FLOAT +SIZEOF_LIMB_T-1)/SIZEOF_LIMB_T) #if IEEE_FLOATING_POINT #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) @@ -42,53 +60,86 @@ #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) StgDouble -__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */ +__encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ { StgDouble r; + const mp_limb_t *const arr = (const mp_limb_t *)ba; I_ i; /* Convert MP_INT to a double; knows a lot about internal rep! */ - i = __abs(s->_mp_size)-1; - if (i < 0) { - r = 0.0; - } else { - for (r = s->_mp_d[i], i--; i >= 0; i--) - r = r * GMP_BASE + s->_mp_d[i]; - } + for(r = 0.0, i = __abs(size)-1; i >= 0; i--) + r = (r * GMP_BASE) + arr[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->_mp_size < 0) + if (size < 0) r = -r; return r; } -#if ! FLOATS_AS_DOUBLES +/* Special version for small Integers */ +StgDouble +__int_encodeDouble (I_ j, I_ e) +{ + StgDouble r; + + r = (StgDouble)__abs(j); + + /* 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 (j < 0) + r = -r; + + return r; +} + StgFloat -__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */ +__encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ { StgFloat r; + const mp_limb_t *arr = (const mp_limb_t *)ba; I_ i; /* Convert MP_INT to a float; knows a lot about internal rep! */ - for(r = 0.0, i = __abs(s->_mp_size)-1; i >= 0; i--) - r = (r * GMP_BASE) + s->_mp_d[i]; + for(r = 0.0, i = __abs(size)-1; i >= 0; i--) + r = (r * GMP_BASE) + arr[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->_mp_size < 0) + if (size < 0) r = -r; return r; } -#endif /* FLOATS_AS_DOUBLES */ + +/* Special version for small Integers */ +StgFloat +__int_encodeFloat (I_ j, I_ e) +{ + StgFloat r; + + r = (StgFloat)__abs(j); + + /* 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 (j < 0) + r = -r; + + return r; +} /* This only supports IEEE floating point */ @@ -96,9 +147,14 @@ void __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) { /* Do some bit fiddling on IEEE */ - nat low, high; /* assuming 32 bit ints */ + 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 */ + union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ + + ASSERT(sizeof(unsigned int ) == 4 ); + ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE); + ASSERT(sizeof(man->_mp_d[0]) == SIZEOF_LIMB_T); + ASSERT(DNBIGIT*SIZEOF_LIMB_T >= SIZEOF_DOUBLE); u.d = dbl; /* grab chunks of the double */ low = u.i[L]; @@ -133,13 +189,13 @@ __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) } *exp = (I_) iexp; #if DNBIGIT == 2 - man->_mp_d[0] = low; - man->_mp_d[1] = high; + man->_mp_d[0] = (mp_limb_t)low; + man->_mp_d[1] = (mp_limb_t)high; #else #if DNBIGIT == 1 - man->_mp_d[0] = ((unsigned long)high) << 32 | (unsigned long)low; + man->_mp_d[0] = ((mp_limb_t)high) << 32 | (mp_limb_t)low; #else - error : error : error : Cannae cope with DNBIGIT +#error Cannot cope with DNBIGIT #endif #endif if (sign < 0) @@ -147,7 +203,6 @@ __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) } } -#if ! FLOATS_AS_DOUBLES void __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) { @@ -155,6 +210,11 @@ __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) int high, sign; /* assuming 32 bit ints */ union { float f; int i; } u; /* assuming 32 bit float and int */ + ASSERT(sizeof(int ) == 4 ); + ASSERT(sizeof(flt ) == SIZEOF_FLOAT ); + ASSERT(sizeof(man->_mp_d[0]) == SIZEOF_LIMB_T); + ASSERT(FNBIGIT*SIZEOF_LIMB_T >= SIZEOF_FLOAT ); + u.f = flt; /* grab the float */ high = u.i; @@ -183,15 +243,14 @@ __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) } } #if FNBIGIT == 1 - man->_mp_d[0] = high; + man->_mp_d[0] = (mp_limb_t)high; #else - error : error : error : Cannae cope with FNBIGIT +#error Cannot cope with FNBIGIT #endif if (sign < 0) man->_mp_size = -man->_mp_size; } } -#endif /* FLOATS_AS_DOUBLES */ /* Convenient union types for checking the layout of IEEE 754 types - based on defs in GNU libc @@ -284,8 +343,7 @@ union stg_ieee754_dbl #ifdef IEEE_FLOATING_POINT StgInt -isDoubleNaN(d) -StgDouble d; +isDoubleNaN(StgDouble d) { union stg_ieee754_dbl u; @@ -299,8 +357,7 @@ StgDouble d; } StgInt -isDoubleInfinite(d) -StgDouble d; +isDoubleInfinite(StgDouble d) { union stg_ieee754_dbl u; @@ -315,8 +372,7 @@ StgDouble d; } StgInt -isDoubleDenormalized(d) -StgDouble d; +isDoubleDenormalized(StgDouble d) { union stg_ieee754_dbl u; @@ -338,8 +394,7 @@ StgDouble d; } StgInt -isDoubleNegativeZero(d) -StgDouble d; +isDoubleNegativeZero(StgDouble d) { union stg_ieee754_dbl u; @@ -366,12 +421,8 @@ StgDouble d; StgInt -isFloatNaN(f) -StgFloat f; +isFloatNaN(StgFloat f) { -# ifdef FLOATS_AS_DOUBLES - return (isDoubleNaN(f)); -# else union stg_ieee754_flt u; u.f = f; @@ -380,17 +431,11 @@ StgFloat f; return ( u.ieee.exponent == 255 /* 2^8 - 1 */ && u.ieee.mantissa != 0); - -# endif /* !FLOATS_AS_DOUBLES */ } StgInt -isFloatInfinite(f) -StgFloat f; +isFloatInfinite(StgFloat f) { -# ifdef FLOATS_AS_DOUBLES - return (isDoubleInfinite(f)); -# else union stg_ieee754_flt u; u.f = f; @@ -399,16 +444,11 @@ StgFloat f; return ( u.ieee.exponent == 255 /* 2^8 - 1 */ && u.ieee.mantissa == 0); -# endif /* !FLOATS_AS_DOUBLES */ } StgInt -isFloatDenormalized(f) -StgFloat f; +isFloatDenormalized(StgFloat f) { -# ifdef FLOATS_AS_DOUBLES - return (isDoubleDenormalized(f)); -# else union stg_ieee754_flt u; u.f = f; @@ -422,16 +462,11 @@ StgFloat f; return ( u.ieee.exponent == 0 && u.ieee.mantissa != 0); -#endif /* !FLOATS_AS_DOUBLES */ } StgInt -isFloatNegativeZero(f) -StgFloat f; +isFloatNegativeZero(StgFloat f) { -#ifdef FLOATS_AS_DOUBLES - return (isDoubleNegativeZero(f)); -# else union stg_ieee754_flt u; u.f = f; @@ -440,7 +475,6 @@ StgFloat f; u.ieee.negative && u.ieee.exponent == 0 && u.ieee.mantissa == 0); -# endif /* !FLOATS_AS_DOUBLES */ } #else /* ! IEEE_FLOATING_POINT */