diff --git a/src/Language/Wasm/FloatUtils.hs b/src/Language/Wasm/FloatUtils.hs new file mode 100644 index 0000000..e16e8db --- /dev/null +++ b/src/Language/Wasm/FloatUtils.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Language.Wasm.FloatUtils ( + wordToFloat, + floatToWord, + wordToDouble, + doubleToWord, + makeNaN, + doubleToFloat +) where + +import Data.Word (Word32, Word64) +import Data.Bits ((.|.), (.&.), shiftR) +import Data.Array.ST (newArray, readArray, MArray, STUArray) +import Data.Array.Unsafe (castSTUArray) +import GHC.ST (runST, ST) + +-- brough from https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) + +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) + +wordToDouble :: Word64 -> Double +wordToDouble 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 + +makeNaN :: Word64 -> Double +makeNaN w = wordToDouble $ 0x7FF0000000000000 .|. (0x000FFFFFFFFFFFFF .&. w) + +doubleToFloat :: Double -> Float +doubleToFloat d = + let w = doubleToWord d in + if 0x7FF0000000000000 == (w .&. 0x7FF0000000000000) && (w .&. 0x0007FFFFFFFFFFFF) /= 0 + then wordToFloat $ fromIntegral $ ((0x8000000000000000 .&. w) `shiftR` 32) .|. 0x7F800000 .|. (0x7FFFFF .&. w) + else realToFrac d \ No newline at end of file diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 73d1ee7..84c2efc 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Language.Wasm.Interpreter ( @@ -49,14 +48,18 @@ import Data.Bits ( countLeadingZeros, countTrailingZeros ) -import Data.Array.ST (newArray, readArray, MArray, STUArray) -import Data.Array.Unsafe (castSTUArray) -import GHC.ST (runST, ST) import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE) import Debug.Trace as Debug import Language.Wasm.Structure as Struct +import Language.Wasm.FloatUtils ( + wordToFloat, + floatToWord, + wordToDouble, + doubleToWord, + makeNaN + ) data Value = VI32 Word32 @@ -87,24 +90,6 @@ asWord64 i | i >= 0 = fromIntegral i | otherwise = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1 --- brough from https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa -wordToFloat :: Word32 -> Float -wordToFloat x = runST (cast x) - -floatToWord :: Float -> Word32 -floatToWord x = runST (cast x) - -wordToDouble :: Word64 -> Double -wordToDouble 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 - nearest :: (IEEE a) => a -> a nearest f | f >= 0 && f <= 0.5 = copySign 0 f diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x index 349ea30..ae733ae 100644 --- a/src/Language/Wasm/Lexer.x +++ b/src/Language/Wasm/Lexer.x @@ -1,4 +1,6 @@ { +{-# LANGUAGE FlexibleContexts #-} + module Language.Wasm.Lexer ( Lexeme(..), Token(..), @@ -11,7 +13,10 @@ import qualified Data.Char as Char import qualified Data.ByteString.Lazy.UTF8 as LBSUtf8 import Control.Applicative ((<$>)) import Control.Monad (when) -import Numeric.IEEE (infinity, nan, nanWithPayload) +import Numeric.IEEE (infinity, nan) +import Language.Wasm.FloatUtils (makeNaN) + +import qualified Debug.Trace as Debug } @@ -124,7 +129,7 @@ parseNanSigned :: AlexAction Lexeme parseNanSigned = token $ \(pos, _, s, _) len -> let (sign, slen) = parseSign s in let num = readHexFromPrefix (len - 6 - slen) $ LBSUtf8.drop (6 + slen) s in - Lexeme pos $ TFloatLit $ sign $ nanWithPayload $ fromIntegral num + Lexeme pos $ TFloatLit $ sign $ makeNaN $ fromIntegral num parseDecimalSignedInt :: AlexAction Lexeme parseDecimalSignedInt = token $ \(pos, _, s, _) len -> @@ -134,8 +139,9 @@ parseDecimalSignedInt = token $ \(pos, _, s, _) len -> parseDecFloat :: AlexAction Lexeme parseDecFloat = token $ \(pos, _, s, _) len -> - let str = filter (/= '_') $ takeChars len s in - Lexeme pos $ TFloatLit $ read str + let (sign, slen) = parseSign s in + let str = filter (/= '_') $ takeChars (len - slen) $ LBSUtf8.drop slen s in + Lexeme pos $ TFloatLit $ sign $ readDecFloat str parseHexFloat :: AlexAction Lexeme parseHexFloat = token $ \(pos, _, s, _) len -> @@ -349,6 +355,13 @@ readHexFloat str = let len = length val in sum $ zipWith (\i c -> readHexFromChar c / (16 ^ i)) [1..] val +readDecFloat :: String -> Double +readDecFloat str = + let (val, exp) = splitBy (\c -> c == 'E' || c == 'e') str in + let (int, frac) = splitBy (== '.') val in + let nullIfEmpty str = if null str then "0" else str in + read $ nullIfEmpty int ++ "." ++ nullIfEmpty frac ++ "e" ++ nullIfEmpty exp + scanner :: LBS.ByteString -> Either String [Lexeme] scanner str = runAlex str loop where diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index e14e88a..437aae1 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -72,6 +72,7 @@ import Numeric.Natural (Natural) import Data.Word (Word32, Word64) import Data.Bits ((.|.)) import Numeric.IEEE (infinity, nan) +import Language.Wasm.FloatUtils (doubleToFloat) import Language.Wasm.Lexer ( Token ( @@ -1103,7 +1104,7 @@ asInt64 val | otherwise = Nothing asFloat32 :: Double -> Float -asFloat32 v = realToFrac v +asFloat32 v = doubleToFloat v asOffset :: LBS.ByteString -> Maybe Natural asOffset str = do diff --git a/tests/Test.hs b/tests/Test.hs index aa42a8e..6d7f582 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -34,7 +34,7 @@ compile file = do main :: IO () main = do files <- Directory.listDirectory "tests/samples" - -- let files = ["conversions.wast"] + -- let files = ["float_literals.wast"] scriptTestCases <- (`mapM` files) $ \file -> do content <- LBS.readFile $ "tests/samples/" ++ file let Right script = Parser.parseScript <$> Lexer.scanner content diff --git a/wasm.cabal b/wasm.cabal index 433292f..b077d2b 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -43,6 +43,7 @@ library Language.Wasm.Validate Language.Wasm.Interpreter Language.Wasm.Script + Language.Wasm.FloatUtils Language.Wasm other-modules: Paths_wasm