1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE BangPatterns #-}
module Basement.Floating
( integerToDouble
, naturalToDouble
, doubleExponant
, integerToFloat
, naturalToFloat
, wordToFloat
, floatToWord
, wordToDouble
, doubleToWord
) where
import GHC.Types
import GHC.Prim
import GHC.Float
import GHC.Word
import GHC.ST
import Basement.Compat.Base
import Basement.Compat.Natural
import qualified Prelude (fromInteger, toInteger, (^^))
integerToDouble :: Integer -> Double
integerToDouble = Prelude.fromInteger
-- this depends on integer-gmp
--integerToDouble i = D# (doubleFromInteger i)
naturalToDouble :: Natural -> Double
naturalToDouble = integerToDouble . Prelude.toInteger
doubleExponant :: Double -> Int -> Double
doubleExponant = (Prelude.^^)
integerToFloat :: Integer -> Float
integerToFloat = Prelude.fromInteger
naturalToFloat :: Natural -> Float
naturalToFloat = integerToFloat . Prelude.toInteger
wordToFloat :: Word32 -> Float
wordToFloat (W32# x) = runST $ ST $ \s1 ->
case newByteArray# 4# s1 of { (# s2, mbarr #) ->
case writeWord32Array# mbarr 0# x s2 of { s3 ->
case readFloatArray# mbarr 0# s3 of { (# s4, f #) ->
(# s4, F# f #) }}}
{-# INLINE wordToFloat #-}
floatToWord :: Float -> Word32
floatToWord (F# x) = runST $ ST $ \s1 ->
case newByteArray# 4# s1 of { (# s2, mbarr #) ->
case writeFloatArray# mbarr 0# x s2 of { s3 ->
case readWord32Array# mbarr 0# s3 of { (# s4, w #) ->
(# s4, W32# w #) }}}
{-# INLINE floatToWord #-}
wordToDouble :: Word64 -> Double
wordToDouble (W64# x) = runST $ ST $ \s1 ->
case newByteArray# 8# s1 of { (# s2, mbarr #) ->
case writeWord64Array# mbarr 0# x s2 of { s3 ->
case readDoubleArray# mbarr 0# s3 of { (# s4, f #) ->
(# s4, D# f #) }}}
{-# INLINE wordToDouble #-}
doubleToWord :: Double -> Word64
doubleToWord (D# x) = runST $ ST $ \s1 ->
case newByteArray# 8# s1 of { (# s2, mbarr #) ->
case writeDoubleArray# mbarr 0# x s2 of { s3 ->
case readWord64Array# mbarr 0# s3 of { (# s4, w #) ->
(# s4, W64# w #) }}}
{-# INLINE doubleToWord #-}
|
