Skip to content

@jystic /1-ieee754.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
IEEE754 conversion comparison
{-# LANGUAGE FlexibleContexts #-}
import Data.Word (Word32, Word64)
import Data.Array.ST (newArray, castSTUArray, readArray, MArray, STUArray)
import GHC.ST (runST, ST)
import qualified Foreign as F
main :: IO ()
main = do
let f = floatToWord 1.0
d = doubleToWord 1.0
print $ wordToFloat f
print $ wordToFloat' f
print $ wordToDouble d
print $ wordToDouble' d
wordToFloat :: Word32 -> Float
wordToFloat x = runST (cast x)
wordToFloat' :: Word32 -> Float
wordToFloat' = toFloat
wordToDouble :: Word64 -> Double
wordToDouble x = runST (cast x)
wordToDouble' :: Word64 -> Double
wordToDouble' = toFloat
floatToWord :: Float -> Word32
floatToWord x = runST (cast x)
doubleToWord :: Double -> Word64
doubleToWord x = runST (cast x)
{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s),
MArray (STUArray s) b (ST s)) => a -> ST s b
cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
toFloat :: (F.Storable word, F.Storable float) => word -> float
toFloat word = F.unsafePerformIO $ F.alloca $ \buf -> do
F.poke (F.castPtr buf) word
F.peek buf
main4
:: forall s_aT8.
State# s_aT8
-> (# State# s_aT8, Word64 #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 8 3}]
main4 =
\ (@ s_aT8) (s_a188 :: State# s_aT8) ->
case newByteArray# @ s_aT8 8 s_a188
of _ { (# s2#_a13Z, marr#_a140 #) ->
case writeDoubleArray# @ s_aT8 marr#_a140 0 1.0 s2#_a13Z
of s2#1_a178 { __DEFAULT ->
case readWord64Array# @ s_aT8 marr#_a140 0 s2#1_a178
of _ { (# s2#2_a19a, e#_a19b #) ->
(# s2#2_a19a, W64# e#_a19b #)
}
}
}
main_d :: Word64
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 2 0}]
main_d = runSTRep @ Word64 main4
main9
:: forall s_aTd.
State# s_aTd
-> (# State# s_aTd, Word32 #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 8 3}]
main9 =
\ (@ s_aTd) (s_a188 :: State# s_aTd) ->
case newByteArray# @ s_aTd 4 s_a188
of _ { (# s2#_a19K, marr#_a19L #) ->
case writeFloatArray#
@ s_aTd marr#_a19L 0 __float 1.0 s2#_a19K
of s2#1_a1ac { __DEFAULT ->
case readWord32Array# @ s_aTd marr#_a19L 0 s2#1_a1ac
of _ { (# s2#2_a1bb, e#_a1bc #) ->
(# s2#2_a1bb, W32# e#_a1bc #)
}
}
}
main_f :: Word32
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 2 0}]
main_f = runSTRep @ Word32 main9
main3
:: State# RealWorld
-> (# State# RealWorld, Double #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 17 3}]
main3 =
\ (s_aVG :: State# RealWorld) ->
case noDuplicate# s_aVG of s'_aVH { __DEFAULT ->
case newAlignedPinnedByteArray#
@ RealWorld 8 8 s'_aVH
of _ { (# s1_a1AS, mbarr#_a1AT #) ->
case unsafeFreezeByteArray#
@ RealWorld mbarr#_a1AT s1_a1AS
of _ { (# s2_a1AX, barr#_a1AY #) ->
case main_d of _ { W64# x_a11U ->
let {
addr_aW7 [Dmd=Just L] :: Addr#
addr_aW7 = byteArrayContents# barr#_a1AY } in
case writeWord64OffAddr#
@ RealWorld addr_aW7 0 x_a11U s2_a1AX
of s3_a11W { __DEFAULT ->
case readDoubleOffAddr#
@ RealWorld addr_aW7 0 s3_a11W
of _ { (# s4_a11G, x1_a11H #) ->
case touch# @ ByteArray# barr#_a1AY s4_a11G
of s5_a1B5 { __DEFAULT ->
(# s5_a1B5, D# x1_a11H #)
}
}
}
}
}
}
}
main2 :: String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 8 0}]
main2 =
case unsafeDupablePerformIO
@ Double
(main3
`cast` (sym (NTCo:IO Double)
:: (State# RealWorld
-> (# State# RealWorld, Double #))
~
IO Double))
of _ { D# ww_a1Bd ->
$w$sshowSignedFloat
$fShowDouble1
zeroInt
ww_a1Bd
([] @ Char)
}
main6
:: forall s_aTk.
State# s_aTk
-> (# State# s_aTk, Double #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 9 3}]
main6 =
\ (@ s_aTk) (s_a188 :: State# s_aTk) ->
case newByteArray# @ s_aTk 8 s_a188
of _ { (# s2#_a1x4, marr#_a1x5 #) ->
case main_d of _ { W64# e#_a1xu ->
case writeWord64Array#
@ s_aTk marr#_a1x5 0 e#_a1xu s2#_a1x4
of s2#1_a1xw { __DEFAULT ->
case readDoubleArray# @ s_aTk marr#_a1x5 0 s2#1_a1xw
of _ { (# s2#2_a1yu, e#1_a1yv #) ->
(# s2#2_a1yu, D# e#1_a1yv #)
}
}
}
}
main5 :: String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 8 0}]
main5 =
case runSTRep @ Double main6
of _ { D# ww_a1Bd ->
$w$sshowSignedFloat
$fShowDouble1
zeroInt
ww_a1Bd
([] @ Char)
}
main8
:: State# RealWorld
-> (# State# RealWorld, Float #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 17 3}]
main8 =
\ (s_aVG :: State# RealWorld) ->
case noDuplicate# s_aVG of s'_aVH { __DEFAULT ->
case newAlignedPinnedByteArray#
@ RealWorld 4 4 s'_aVH
of _ { (# s1_a1AS, mbarr#_a1AT #) ->
case unsafeFreezeByteArray#
@ RealWorld mbarr#_a1AT s1_a1AS
of _ { (# s2_a1AX, barr#_a1AY #) ->
case main_f of _ { W32# x_a11r ->
let {
addr_aW7 [Dmd=Just L] :: Addr#
addr_aW7 = byteArrayContents# barr#_a1AY } in
case writeWord32OffAddr#
@ RealWorld addr_aW7 0 x_a11r s2_a1AX
of s3_a11t { __DEFAULT ->
case readFloatOffAddr#
@ RealWorld addr_aW7 0 s3_a11t
of _ { (# s4_a10Z, x1_a110 #) ->
case touch# @ ByteArray# barr#_a1AY s4_a10Z
of s5_a1B5 { __DEFAULT ->
(# s5_a1B5, F# x1_a110 #)
}
}
}
}
}
}
}
main7 :: String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 8 0}]
main7 =
case unsafeDupablePerformIO
@ Float
(main8
`cast` (sym (NTCo:IO Float)
:: (State# RealWorld
-> (# State# RealWorld, Float #))
~
IO Float))
of _ { F# ww_a1zS ->
$w$sshowSignedFloat1
$fShowFloat1
zeroInt
ww_a1zS
([] @ Char)
}
main11
:: forall s_aTr.
State# s_aTr
-> (# State# s_aTr, Float #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 9 3}]
main11 =
\ (@ s_aTr) (s_a188 :: State# s_aTr) ->
case newByteArray# @ s_aTr 4 s_a188
of _ { (# s2#_a1uG, marr#_a1uH #) ->
case main_f of _ { W32# e#_a1v6 ->
case writeWord32Array#
@ s_aTr marr#_a1uH 0 e#_a1v6 s2#_a1uG
of s2#1_a1v8 { __DEFAULT ->
case readFloatArray# @ s_aTr marr#_a1uH 0 s2#1_a1v8
of _ { (# s2#2_a1w6, e#1_a1w7 #) ->
(# s2#2_a1w6, F# e#1_a1w7 #)
}
}
}
}
main10 :: String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 8 0}]
main10 =
case runSTRep @ Float main11
of _ { F# ww_a1zS ->
$w$sshowSignedFloat1
$fShowFloat1
zeroInt
ww_a1zS
([] @ Char)
}
main1
:: State# RealWorld
-> (# State# RealWorld, () #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 23 0}]
main1 =
\ (s_X12v :: State# RealWorld) ->
case Handle.Text.hPutStr2
Handle.FD.stdout main10 True s_X12v
of _ { (# new_s_a11f, _ #) ->
case Handle.Text.hPutStr2
Handle.FD.stdout main7 True new_s_a11f
of _ { (# new_s1_X12E, _ #) ->
case Handle.Text.hPutStr2
Handle.FD.stdout main5 True new_s1_X12E
of _ { (# new_s2_X12A, _ #) ->
Handle.Text.hPutStr2
Handle.FD.stdout main2 True new_s2_X12A
}
}
}
main :: IO ()
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
main =
main1
`cast` (sym (NTCo:IO ())
:: (State# RealWorld
-> (# State# RealWorld, () #))
~
IO ())
main12
:: State# RealWorld
-> (# State# RealWorld, () #)
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [] 2 6}]
main12 =
runMainIO1
@ ()
(main1
`cast` (sym (NTCo:IO ())
:: (State# RealWorld
-> (# State# RealWorld, () #))
~
IO ()))
:main :: IO ()
[GblId,
Arity=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
:main =
main12
`cast` (sym (NTCo:IO ())
:: (State# RealWorld
-> (# State# RealWorld, () #))
~
IO ())
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.