IEEE754 conversion comparison

1-ieee754.hs

{-# 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

2-ieee754-core.hs

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 ())