Fix conversions between Double/Float and simple-integer

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 9f6bbc6..b83a07e 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -765,6 +765,7 @@ stmtMacros = listToUFM [
   ( 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_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
   ( 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 471cba1..d4fd608 100644 (file)
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -619,10 +619,11 @@ primop   DoubleDecodeOp   "decodeDouble#" GenPrimOp
    with out_of_line = True
 
 primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp    
-   Double# -> (# Int#, Int#, Int# #)
+   Double# -> (# Int#, Word#, Word#, 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.}
+    First component of the result is -1 or 1, indicating the sign of the
+    mantissa. The next two are the high and low 32 bits of the mantissa
+    respectively, and the last is the exponent.}
    with out_of_line = True
 
 ------------------------------------------------------------------------

diff --git a/includes/Rts.h b/includes/Rts.h
index 610cd70..5aff979 100644 (file)
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -206,7 +206,7 @@ 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      __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl);
 extern void      __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt);
 
 #if defined(WANT_DOTNET_SUPPORT)

diff --git a/includes/RtsExternal.h b/includes/RtsExternal.h
index f0e7b75..b952761 100644 (file)
--- a/includes/RtsExternal.h
+++ b/includes/RtsExternal.h
@@ -50,8 +50,10 @@ extern unsigned int n_capabilities;
 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 StgDouble __word_encodeDouble (W_ j, I_ e);
 extern StgFloat  __encodeFloat (I_ size, StgByteArray arr, I_ e);
 extern StgFloat  __int_encodeFloat (I_ j, I_ e);
+extern StgFloat  __word_encodeFloat (W_ j, I_ e);
 extern StgInt    isDoubleNaN(StgDouble d);
 extern StgInt    isDoubleInfinite(StgDouble d);
 extern StgInt    isDoubleDenormalized(StgDouble d);

diff --git a/rts/Linker.c b/rts/Linker.c
index bca6026..db495dd 100644 (file)
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -537,8 +537,10 @@ typedef struct _RtsSymbolVal {
       SymX(addDLL)                             \
       GMP_SYMS                                 \
       SymX(__int_encodeDouble)                 \
+      SymX(__word_encodeDouble)                        \
       SymX(__2Int_encodeDouble)                        \
       SymX(__int_encodeFloat)                  \
+      SymX(__word_encodeFloat)                 \
       SymX(andIntegerzh_fast)                  \
       SymX(atomicallyzh_fast)                  \
       SymX(barf)                               \

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index c3ab788..c7c3727 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -928,16 +928,20 @@ decodeDoublezu2Intzh_fast
     W_ p;
     FETCH_MP_TEMP(mp_tmp1);
     FETCH_MP_TEMP(mp_tmp2);
-    FETCH_MP_TEMP(mp_tmp_w);
+    FETCH_MP_TEMP(mp_result1);
+    FETCH_MP_TEMP(mp_result2);
 
     /* 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]);
+    foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
+                                    mp_result1 "ptr", mp_result2 "ptr",
+                                    arg) [];
+
+    /* returns:
+       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
+    RET_NNNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
 }
 
 /* -----------------------------------------------------------------------------

diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c
index 80f10e1..436236d 100644 (file)
--- a/rts/StgPrimFloat.c
+++ b/rts/StgPrimFloat.c
@@ -103,6 +103,21 @@ __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e)
   return r;
 }
 
+/* Special version for words */
+StgDouble
+__word_encodeDouble (W_ j, I_ e)
+{
+  StgDouble r;
+  
+  r = (StgDouble)j;
+  
+  /* Now raise to the exponent */
+  if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+    r = ldexp(r, e);
+  
+  return r;
+}
+
 /* Special version for small Integers */
 StgDouble
 __int_encodeDouble (I_ j, I_ e)
@@ -163,6 +178,21 @@ __int_encodeFloat (I_ j, I_ e)
   return r;
 }
 
+/* Special version for small positive Integers */
+StgFloat
+__word_encodeFloat (W_ j, I_ e)
+{
+  StgFloat r;
+  
+  r = (StgFloat)j;
+  
+  /* Now raise to the exponent */
+  if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+    r = ldexp(r, e);
+  
+  return r;
+}
+
 /* This only supports IEEE floating point */
 
 void
@@ -226,7 +256,7 @@ __decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
 }
 
 void
-__decodeDouble_2Int (I_ *man_high, I_ *man_low, I_ *exp, StgDouble dbl)
+__decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl)
 {
     /* Do some bit fiddling on IEEE */
     unsigned int low, high;            /* assuming 32 bit ints */
@@ -266,9 +296,7 @@ __decodeDouble_2Int (I_ *man_high, I_ *man_low, I_ *exp, StgDouble dbl)
         *exp = (I_) iexp;
        *man_low = low;
        *man_high = high;
-       if (sign < 0) {
-           *man_high = - *man_high;
-        }
+       *man_sign = (sign < 0) ? -1 : 1;
     }
 }