Created
August 9, 2011 20:29
-
-
Save jacobstanley/1135110 to your computer and use it in GitHub Desktop.
IEEE754 conversion comparison
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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