diff options
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 5 | ||||
| -rw-r--r-- | libraries/base/GHC/Float.hs | 91 | ||||
| -rw-r--r-- | libraries/base/cbits/CastFloatWord.cmm | 69 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/all.T | 2 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/castFloatWord.hs | 28 | ||||
| -rw-r--r-- | testsuite/tests/codeGen/should_run/castFloatWord.stdout | 204 |
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! |