[commit: ghc] master: Implement `decodeDouble_Int64#` primop (b62bd5e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b62bd5ecf3be421778e4835010b6b334e95c5a56/ghc

>---------------------------------------------------------------

commit b62bd5ecf3be421778e4835010b6b334e95c5a56
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Wed Sep 17 17:54:20 2014 +0200

    Implement `decodeDouble_Int64#` primop
    
    The existing `decodeDouble_2Int#` primop is rather inconvenient to use
    (and in fact is not even used by `integer-gmp`) as the mantissa is split
    into 3 components which would actually fit in an `Int64#` value.
    
    However, `decodeDouble_Int64#` is to be used by the new `integer-gmp2`
    re-implementation (see #9281).
    
    Moreover, `decodeDouble_2Int#` performs direct bit-wise operations on the
    IEEE representation which can be replaced by a combination of the
    portable standard C99 `scalbn(3)` and `frexp(3)` functions.
    
    Differential Revision: https://phabricator.haskell.org/D160


>---------------------------------------------------------------

b62bd5ecf3be421778e4835010b6b334e95c5a56
 compiler/prelude/primops.txt.pp |  5 +++++
 includes/stg/MiscClosures.h     |  1 +
 rts/Linker.c                    |  1 +
 rts/PrimOps.cmm                 | 17 +++++++++++++++++
 rts/StgPrimFloat.c              | 18 ++++++++++++++++++
 rts/StgPrimFloat.h              |  1 +
 6 files changed, 43 insertions(+)

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index b78bc95..a3c15a9 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -606,6 +606,11 @@ primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp
     respectively, and the last is the exponent.}
    with out_of_line = True
 
+primop   DoubleDecode_Int64Op   "decodeDouble_Int64#" GenPrimOp
+   Double# -> (# INT64, Int# #)
+   {Decode {\tt Double\#} into mantissa and base-2 exponent.}
+   with out_of_line = True
+
 ------------------------------------------------------------------------
 section "Float#"
         {Operations on single-precision (32-bit) floating-point numbers.}
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index d2b933d..0d323e2 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -341,6 +341,7 @@ RTS_FUN_DECL(StgReturn);
 
 RTS_FUN_DECL(stg_decodeFloatzuIntzh);
 RTS_FUN_DECL(stg_decodeDoublezu2Intzh);
+RTS_FUN_DECL(stg_decodeDoublezuInt64zh);
 
 RTS_FUN_DECL(stg_unsafeThawArrayzh);
 RTS_FUN_DECL(stg_casArrayzh);
diff --git a/rts/Linker.c b/rts/Linker.c
index dba346e..63cf981 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1108,6 +1108,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(cmp_thread)                                         \
       SymI_HasProto(createAdjustor)                                     \
       SymI_HasProto(stg_decodeDoublezu2Intzh)                           \
+      SymI_HasProto(stg_decodeDoublezuInt64zh)                          \
       SymI_HasProto(stg_decodeFloatzuIntzh)                             \
       SymI_HasProto(defaultsHook)                                       \
       SymI_HasProto(stg_delayzh)                                        \
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index ee50f7f..cb4cd5e 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -22,6 +22,7 @@
  * ---------------------------------------------------------------------------*/
 
 #include "Cmm.h"
+#include "MachDeps.h"
 
 #ifdef __PIC__
 import pthread_mutex_lock;
@@ -807,6 +808,22 @@ stg_decodeDoublezu2Intzh ( D_ arg )
     return (r1, r2, r3, r4);
 }
 
+/* Double# -> (# Int64#, Int# #) */
+stg_decodeDoublezuInt64zh ( D_ arg )
+{
+    CInt exp;
+    I64  mant;
+    W_   mant_ptr;
+
+    STK_CHK_GEN_N (SIZEOF_INT64);
+    reserve BYTES_TO_WDS(SIZEOF_INT64) = mant_ptr {
+        (exp) = ccall __decodeDouble_Int64(mant_ptr "ptr", arg);
+        mant = I64[mant_ptr];
+    }
+
+    return (mant, TO_W_(exp));
+}
+
 /* -----------------------------------------------------------------------------
  * Concurrency primitives
  * -------------------------------------------------------------------------- */
diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c
index 123e77b..6e78546 100644
--- a/rts/StgPrimFloat.c
+++ b/rts/StgPrimFloat.c
@@ -17,6 +17,10 @@
 
 #define IEEE_FLOATING_POINT 1
 
+#if FLT_RADIX != 2
+# error FLT_RADIX != 2 not supported
+#endif
+
 /*
  * Encoding and decoding Doubles.  Code based on the HBC code
  * (lib/fltcode.c).
@@ -158,6 +162,20 @@ __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble
     }
 }
 
+/* This is expected to replace uses of __decodeDouble_2Int() in the long run */
+StgInt
+__decodeDouble_Int64 (StgInt64 *const mantissa, const StgDouble dbl)
+{
+    if (dbl) {
+        int exp = 0;
+        *mantissa = (StgInt64)scalbn(frexp(dbl, &exp), DBL_MANT_DIG);
+        return exp-DBL_MANT_DIG;
+    } else {
+        *mantissa = 0;
+        return 0;
+    }
+}
+
 /* Convenient union types for checking the layout of IEEE 754 types -
    based on defs in GNU libc <ieee754.h>
 */
diff --git a/rts/StgPrimFloat.h b/rts/StgPrimFloat.h
index 57e9db1..d3911a1 100644
--- a/rts/StgPrimFloat.h
+++ b/rts/StgPrimFloat.h
@@ -12,6 +12,7 @@
 #include "BeginPrivate.h"
 
 /* grimy low-level support functions defined in StgPrimFloat.c */
+StgInt    __decodeDouble_Int64 (StgInt64 *mantissa, StgDouble dbl);
 void      __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl);
 void      __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt);