base: Implement bit casts between word and float types

Test Plan: Test on x86 and x86_64

Reviewers: duncan, trofi, simonmar, tibbe, hvr, austin, rwbarton,
bgamari

Reviewed By: duncan

Subscribers: Phyx, DemiMarie, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3358

6 files changed, 396 insertions, 3 deletions

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 8c936c6ac5..8c9cc92b9a 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2830,8 +2830,9 @@ pseudoop   "unsafeCoerce#"
 
          * Casting {\tt Any} back to the real type
 
-         * Casting an unboxed type to another unboxed type of the same size
-           (but not coercions between floating-point and integral types)
+         * Casting an unboxed type to another unboxed type of the same size.
+           (Casting between floating-point and integral types does not work.
+           See the {\tt GHC.Float} module for functions to do work.)
 
          * Casting between two types that have the same runtime representation.  One case is when
            the two types differ only in "phantom" type parameters, for example
diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs
index 64467b338e..c534bafa07 100644
--- a/libraries/base/GHC/Float.hs
+++ b/libraries/base/GHC/Float.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
+           , GHCForeignImportPrim
            , NoImplicitPrelude
            , MagicHash
            , UnboxedTuples
+           , UnliftedFFITypes
   #-}
 {-# LANGUAGE CApiFFI #-}
 -- We believe we could deorphan this module, by moving lots of things
@@ -21,11 +23,13 @@
 -- Stability   :  internal
 -- Portability :  non-portable (GHC Extensions)
 --
--- The types 'Float' and 'Double', and the classes 'Floating' and 'RealFloat'.
+-- The types 'Float' and 'Double', the classes 'Floating' and 'RealFloat' and
+-- casting between Word32 and Float and Word64 and Double.
 --
 -----------------------------------------------------------------------------
 
 #include "ieee-flpt.h"
+#include "MachDeps.h"
 
 module GHC.Float
    ( module GHC.Float
@@ -46,6 +50,7 @@ import GHC.Enum
 import GHC.Show
 import GHC.Num
 import GHC.Real
+import GHC.Word
 import GHC.Arr
 import GHC.Float.RealFracMethods
 import GHC.Float.ConversionUtils
@@ -1253,3 +1258,87 @@ exponents returned by decodeFloat.
 -}
 clamp :: Int -> Int -> Int
 clamp bd k = max (-bd) (min bd k)
+
+
+{-
+Note [Casting from integral to floating point types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To implement something like `reinterpret_cast` from C++ to go from a
+floating-point type to an integral type one might niavely think that the
+following should work:
+
+      cast :: Float -> Word32
+      cast (F# f#) = W32# (unsafeCoerce# f#)
+
+Unfortunately that is not the case, because all the `unsafeCoerce#` does is tell
+the compiler that the types have changed. When one does the above cast and
+tries to operate on the resulting `Word32` the code generator will generate code
+that performs an integer/word operation on a floating-point register, which
+results in a compile error.
+
+The correct way of implementing `reinterpret_cast` to implement a primpop, but
+that requires a unique implementation for all supported archetectures. The next
+best solution is to write the value from the source register to memory and then
+read it from memory into the destination register and the best way to do that
+is using CMM.
+-}
+
+-- | @'castWord32ToFloat' w@ does a bit-for-bit copy from an integral value
+-- to a floating-point value.
+--
+-- @since 4.10.0.0
+
+{-# INLINE castWord32ToFloat #-}
+castWord32ToFloat :: Word32 -> Float
+castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#)
+
+foreign import prim "stg_word32ToFloatzh"
+    stgWord32ToFloat :: Word# -> Float#
+
+
+-- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value
+-- to an integral value.
+--
+-- @since 4.10.0.0
+
+{-# INLINE castFloatToWord32 #-}
+castFloatToWord32 :: Float -> Word32
+castFloatToWord32 (F# f#) = W32# (stgFloatToWord32 f#)
+
+foreign import prim "stg_floatToWord32zh"
+    stgFloatToWord32 :: Float# -> Word#
+
+
+
+-- | @'castWord64ToDouble' w@ does a bit-for-bit copy from an integral value
+-- to a floating-point value.
+--
+-- @since 4.10.0.0
+
+{-# INLINE castWord64ToDouble #-}
+castWord64ToDouble :: Word64 -> Double
+castWord64ToDouble (W64# w) = D# (stgWord64ToDouble w)
+
+foreign import prim "stg_word64ToDoublezh"
+#if WORD_SIZE_IN_BITS == 64
+    stgWord64ToDouble :: Word# -> Double#
+#else
+    stgWord64ToDouble :: Word64# -> Double#
+#endif
+
+
+-- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value
+-- to an integral value.
+--
+-- @since 4.10.0.0
+
+{-# INLINE castDoubleToWord64 #-}
+castDoubleToWord64 :: Double -> Word64
+castDoubleToWord64 (D# d#) = W64# (stgDoubleToWord64 d#)
+
+foreign import prim "stg_doubleToWord64zh"
+#if WORD_SIZE_IN_BITS == 64
+    stgDoubleToWord64 :: Double# -> Word#
+#else
+    stgDoubleToWord64 :: Double# -> Word64#
+#endif
diff --git a/libraries/base/cbits/CastFloatWord.cmm b/libraries/base/cbits/CastFloatWord.cmm
new file mode 100644
index 0000000000..18d275f4af
--- /dev/null
+++ b/libraries/base/cbits/CastFloatWord.cmm
@@ -0,0 +1,69 @@
+#include "Cmm.h"
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS == 64
+#define DOUBLE_SIZE_WDS   1
+#else
+#define DOUBLE_SIZE_WDS   2
+#endif
+
+stg_word64ToDoublezh(I64 w)
+{
+    D_ d;
+    P_ ptr;
+
+    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);
+
+    reserve DOUBLE_SIZE_WDS = ptr {
+        I64[ptr] = w;
+        d = D_[ptr];
+    }
+
+    return (d);
+}
+
+stg_doubleToWord64zh(D_ d)
+{
+    I64 w;
+    P_ ptr;
+
+    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);
+
+    reserve DOUBLE_SIZE_WDS = ptr {
+        D_[ptr] = d;
+        w = I64[ptr];
+    }
+
+    return (w);
+}
+
+stg_word32ToFloatzh(W_ w)
+{
+    F_ f;
+    P_ ptr;
+
+    STK_CHK_GEN_N (1);
+
+    reserve 1 = ptr {
+        I32[ptr] = %lobits32(w);
+        f = F_[ptr];
+    }
+
+    return (f);
+}
+
+stg_floatToWord32zh(F_ f)
+{
+    W_ w;
+    P_ ptr;
+
+    STK_CHK_GEN_N (1);
+
+    reserve 1 = ptr {
+        F_[ptr] = f;
+        w = TO_W_(I32[ptr]);
+    }
+
+    return (w);
+}
+
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 9f334cf298..6318341abb 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -155,4 +155,6 @@ test('T9577', [ unless(arch('x86_64') or arch('i386'),skip),
                 when(opsys('darwin'), expect_broken(12937)),
                 when(opsys('mingw32'), expect_broken(12965)),
                 only_ways(['normal']) ], compile_and_run, [''])
+
 test('T13425', normal, compile_and_run, ['-O'])
+test('castFloatWord', normal, compile_and_run, ['-dcmm-lint'])
diff --git a/testsuite/tests/codeGen/should_run/castFloatWord.hs b/testsuite/tests/codeGen/should_run/castFloatWord.hs
new file mode 100644
index 0000000000..9c10aa84fc
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/castFloatWord.hs
@@ -0,0 +1,28 @@
+import Data.Bits
+import GHC.Float
+import GHC.Word
+import Numeric
+
+main :: IO ()
+main = do
+    putStrLn "Float"
+    mapM_ print floats
+    putStrLn "\nDouble"
+    mapM_ print doubles
+    putStrLn "\nWord32"
+    mapM_ (printHex32 . castFloatToWord32) floats
+    putStrLn "\nWord64"
+    mapM_ (printHex64 . castDoubleToWord64) doubles
+    putStrLn "Done!"
+
+floats :: [Float]
+floats = map castWord32ToFloat $ 0 : map (2^) [ 0 .. 31 ]
+
+doubles :: [Double]
+doubles = map castWord64ToDouble $ 0 : map (2^) [ 0 .. 63 ]
+
+printHex32 :: Word32 -> IO ()
+printHex32 w = putStrLn $ "0x" ++ showHex (0xffffffff .&. w) ""
+
+printHex64 :: Word64 -> IO ()
+printHex64 w = putStrLn $ "0x" ++ showHex w ""
diff --git a/testsuite/tests/codeGen/should_run/castFloatWord.stdout b/testsuite/tests/codeGen/should_run/castFloatWord.stdout
new file mode 100644
index 0000000000..930f2fec02
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/castFloatWord.stdout
@@ -0,0 +1,204 @@
+Float
+0.0
+1.0e-45
+3.0e-45
+6.0e-45
+1.1e-44
+2.2e-44
+4.5e-44
+9.0e-44
+1.8e-43
+3.59e-43
+7.17e-43
+1.435e-42
+2.87e-42
+5.74e-42
+1.148e-41
+2.2959e-41
+4.5918e-41
+9.1835e-41
+1.83671e-40
+3.67342e-40
+7.34684e-40
+1.469368e-39
+2.938736e-39
+5.877472e-39
+1.1754944e-38
+2.3509887e-38
+9.403955e-38
+1.5046328e-36
+3.85186e-34
+2.524355e-29
+1.0842022e-19
+2.0
+-0.0
+
+Double
+0.0
+5.0e-324
+1.0e-323
+2.0e-323
+4.0e-323
+8.0e-323
+1.6e-322
+3.16e-322
+6.3e-322
+1.265e-321
+2.53e-321
+5.06e-321
+1.012e-320
+2.0237e-320
+4.0474e-320
+8.095e-320
+1.61895e-319
+3.2379e-319
+6.4758e-319
+1.295163e-318
+2.590327e-318
+5.180654e-318
+1.036131e-317
+2.0722615e-317
+4.144523e-317
+8.289046e-317
+1.6578092e-316
+3.3156184e-316
+6.63123685e-316
+1.32624737e-315
+2.65249474e-315
+5.304989477e-315
+1.0609978955e-314
+2.121995791e-314
+4.243991582e-314
+8.487983164e-314
+1.69759663277e-313
+3.39519326554e-313
+6.7903865311e-313
+1.35807730622e-312
+2.716154612436e-312
+5.43230922487e-312
+1.086461844974e-311
+2.1729236899484e-311
+4.345847379897e-311
+8.691694759794e-311
+1.73833895195875e-310
+3.4766779039175e-310
+6.953355807835e-310
+1.390671161567e-309
+2.781342323134e-309
+5.562684646268003e-309
+1.1125369292536007e-308
+2.2250738585072014e-308
+4.450147717014403e-308
+1.7800590868057611e-307
+2.848094538889218e-306
+7.291122019556398e-304
+4.778309726736481e-299
+2.0522684006491881e-289
+3.785766995733679e-270
+1.2882297539194267e-231
+1.4916681462400413e-154
+2.0
+-0.0
+
+Word32
+0x0
+0x1
+0x2
+0x4
+0x8
+0x10
+0x20
+0x40
+0x80
+0x100
+0x200
+0x400
+0x800
+0x1000
+0x2000
+0x4000
+0x8000
+0x10000
+0x20000
+0x40000
+0x80000
+0x100000
+0x200000
+0x400000
+0x800000
+0x1000000
+0x2000000
+0x4000000
+0x8000000
+0x10000000
+0x20000000
+0x40000000
+0x80000000
+
+Word64
+0x0
+0x1
+0x2
+0x4
+0x8
+0x10
+0x20
+0x40
+0x80
+0x100
+0x200
+0x400
+0x800
+0x1000
+0x2000
+0x4000
+0x8000
+0x10000
+0x20000
+0x40000
+0x80000
+0x100000
+0x200000
+0x400000
+0x800000
+0x1000000
+0x2000000
+0x4000000
+0x8000000
+0x10000000
+0x20000000
+0x40000000
+0x80000000
+0x100000000
+0x200000000
+0x400000000
+0x800000000
+0x1000000000
+0x2000000000
+0x4000000000
+0x8000000000
+0x10000000000
+0x20000000000
+0x40000000000
+0x80000000000
+0x100000000000
+0x200000000000
+0x400000000000
+0x800000000000
+0x1000000000000
+0x2000000000000
+0x4000000000000
+0x8000000000000
+0x10000000000000
+0x20000000000000
+0x40000000000000
+0x80000000000000
+0x100000000000000
+0x200000000000000
+0x400000000000000
+0x800000000000000
+0x1000000000000000
+0x2000000000000000
+0x4000000000000000
+0x8000000000000000
+Done!