diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index d387bf0465ea..37e17ca55d7d 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -763,6 +763,7 @@ stmtMacros = listToUFM [ ( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]), ( FSLIT("RET_NPP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]), ( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), + ( FSLIT("RET_NNN"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]), ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]), ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)]) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 57abb7d3c768..61a696463ede 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -618,6 +618,13 @@ represent an {\tt Integer\#} holding the mantissa.} with out_of_line = True +primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp + Double# -> (# Int#, Int#, Int# #) + {Convert to arbitrary-precision integer. + First {\tt Int\#} in result is the high 32 bits of the mantissa, and the + second is the low 32. The third is the exponent.} + with out_of_line = True + ------------------------------------------------------------------------ section "Float#" {Operations on single-precision (32-bit) floating-point numbers.} @@ -724,6 +731,12 @@ represent an {\tt Integer\#} holding the mantissa.} with out_of_line = True +primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp + Float# -> (# Int#, Int# #) + {Convert to arbitrary-precision integer. + First {\tt Int\#} in result is the mantissa; second is the exponent.} + with out_of_line = True + ------------------------------------------------------------------------ section "Arrays" {Operations on {\tt Array\#}.} diff --git a/includes/Rts.h b/includes/Rts.h index cec93e68b0db..610cd701b3e3 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -206,6 +206,8 @@ extern void stackOverflow(void); extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl); extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt); +extern void __decodeDouble_2Int (I_ *man_high, I_ *man_low, I_ *exp, StgDouble dbl); +extern void __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt); #if defined(WANT_DOTNET_SUPPORT) #include "DNInvoke.h" diff --git a/includes/RtsExternal.h b/includes/RtsExternal.h index 24dace2b14a6..f0e7b75f8cbf 100644 --- a/includes/RtsExternal.h +++ b/includes/RtsExternal.h @@ -48,6 +48,7 @@ extern unsigned int n_capabilities; /* grimy low-level support functions defined in StgPrimFloat.c */ extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e); +extern StgDouble __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e); extern StgDouble __int_encodeDouble (I_ j, I_ e); extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e); extern StgFloat __int_encodeFloat (I_ j, I_ e); diff --git a/includes/StgMiscClosures.h b/includes/StgMiscClosures.h index 10e4638ca457..1d2b32cb4700 100644 --- a/includes/StgMiscClosures.h +++ b/includes/StgMiscClosures.h @@ -526,7 +526,9 @@ RTS_FUN(int2Integerzh_fast); RTS_FUN(word2Integerzh_fast); RTS_FUN(decodeFloatzh_fast); +RTS_FUN(decodeFloatzuIntzh_fast); RTS_FUN(decodeDoublezh_fast); +RTS_FUN(decodeDoublezu2Intzh_fast); RTS_FUN(andIntegerzh_fast); RTS_FUN(orIntegerzh_fast); diff --git a/rts/Linker.c b/rts/Linker.c index ebca998df4b5..04f272ceb238 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -537,6 +537,7 @@ typedef struct _RtsSymbolVal { SymX(addDLL) \ GMP_SYMS \ SymX(__int_encodeDouble) \ + SymX(__2Int_encodeDouble) \ SymX(__int_encodeFloat) \ SymX(andIntegerzh_fast) \ SymX(atomicallyzh_fast) \ @@ -556,6 +557,8 @@ typedef struct _RtsSymbolVal { SymX(createAdjustor) \ SymX(decodeDoublezh_fast) \ SymX(decodeFloatzh_fast) \ + SymX(decodeDoublezu2Intzh_fast) \ + SymX(decodeFloatzuIntzh_fast) \ SymX(defaultsHook) \ SymX(delayzh_fast) \ SymX(deRefWeakzh_fast) \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 99d6475455c9..cbdfe67d93b1 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -876,6 +876,23 @@ decodeFloatzh_fast RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p); } +decodeFloatzuIntzh_fast +{ + W_ p; + F_ arg; + FETCH_MP_TEMP(mp_tmp1); + FETCH_MP_TEMP(mp_tmp_w); + + /* arguments: F1 = Float# */ + arg = F1; + + /* Perform the operation */ + foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) []; + + /* returns: (Int# (mantissa), Int# (exponent)) */ + RET_NN(W_[mp_tmp1], W_[mp_tmp_w]); +} + #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE) @@ -905,6 +922,24 @@ decodeDoublezh_fast RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p); } +decodeDoublezu2Intzh_fast +{ + D_ arg; + W_ p; + FETCH_MP_TEMP(mp_tmp1); + FETCH_MP_TEMP(mp_tmp2); + FETCH_MP_TEMP(mp_tmp_w); + + /* arguments: D1 = Double# */ + arg = D1; + + /* Perform the operation */ + foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr", mp_tmp_w "ptr", arg) []; + + /* returns: (Int# (mant high), Int# (mant low), Int# (expn)) */ + RET_NNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_tmp_w]); +} + /* ----------------------------------------------------------------------------- * Concurrency primitives * -------------------------------------------------------------------------- */ diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c index 95210948872e..21ba9dc41c5c 100644 --- a/rts/StgPrimFloat.c +++ b/rts/StgPrimFloat.c @@ -80,6 +80,29 @@ __encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ return r; } +StgDouble +__2Int_encodeDouble (I_ j_high, I_ j_low, I_ e) +{ + StgDouble r; + + /* assuming 32 bit ints */ + ASSERT(sizeof(int ) == 4 ); + + r = (StgDouble)((unsigned int)j_high); + r *= exp2f(32); + r += (StgDouble)((unsigned int)j_low); + + /* 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_high < 0) + r = -r; + + return r; +} + /* Special version for small Integers */ StgDouble __int_encodeDouble (I_ j, I_ e) @@ -202,6 +225,53 @@ __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) } } +void +__decodeDouble_2Int (I_ *man_high, I_ *man_low, I_ *exp, StgDouble dbl) +{ + /* Do some bit fiddling on IEEE */ + unsigned int low, high; /* assuming 32 bit ints */ + int sign, iexp; + union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ + + ASSERT(sizeof(unsigned int ) == 4 ); + ASSERT(sizeof(dbl ) == 8 ); + ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE); + + u.d = dbl; /* grab chunks of the double */ + low = u.i[L]; + high = u.i[H]; + + if (low == 0 && (high & ~DMSBIT) == 0) { + *man_low = 0; + *man_high = 0; + *exp = 0L; + } else { + iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; + sign = high; + + 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; + *man_low = low; + *man_high = high; + if (sign < 0) { + *man_high = - *man_high; + } + } +} + void __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) { @@ -255,6 +325,44 @@ __decodeFloat (MP_INT *man, I_ *exp, StgFloat flt) based on defs in GNU libc */ +void +__decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt) +{ + /* 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 */ + + ASSERT(sizeof(int ) == 4 ); + ASSERT(sizeof(flt ) == 4 ); + ASSERT(sizeof(flt ) == SIZEOF_FLOAT ); + + u.f = flt; /* grab the float */ + high = u.i; + + if ((high & ~FMSBIT) == 0) { + *man = 0; + *exp = 0; + } else { + *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)--; + } + } + *man = high; + if (sign < 0) + *man = - *man; + } +} + union stg_ieee754_flt { float f;