From 8ef3eadc9a4cda2eb5d9c31dc28825294b8b5e7a Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sun, 8 Apr 2018 19:47:10 -0700 Subject: [PATCH] parse arithmetic nan --- src/Language/Wasm/Lexer.x | 22 +++++++++++++--------- src/Language/Wasm/Parser.y | 37 ++++++++++++++++++++----------------- tests/Test.hs | 2 +- wasm.cabal | 1 + 4 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x index f201d30..0abf140 100644 --- a/src/Language/Wasm/Lexer.x +++ b/src/Language/Wasm/Lexer.x @@ -11,6 +11,7 @@ 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) } @@ -54,11 +55,9 @@ tokens :- <0> "nan" { constToken $ TFloatLit nan } <0> "+nan" { constToken $ TFloatLit nan } <0> "-nan" { constToken $ TFloatLit minusNaN } -<0> @nanhex { constToken $ TFloatLit nan {- TODO: real hex rep parsing -}} -<0> "+" @nanhex { constToken $ TFloatLit nan {- TODO: real hex rep parsing -}} -<0> "-" @nanhex { constToken $ TFloatLit minusNaN {- TODO: real hex rep parsing -}} +<0> $sign? @nanhex { parseNanSigned } <0> "inf" { constToken $ TFloatLit inf } -<0> "+inf" { constToken $ TFloatLit inf } +<0> "+inf" { constToken $ TFloatLit inf } <0> "-inf" { constToken $ TFloatLit minusInf } <0> @keyword { tokenStr TKeyword } <0> @linecomment ; @@ -99,11 +98,10 @@ isAllowedStringChar _userState (_pos, _rest, inp, _) _len _nextInp = let code = Char.ord char in code >= 0x20 && code /= 0x7f && char /= '"' && char /= '\\' -minusNaN, nan, inf, minusInf :: Double -minusNaN = read "-NaN" -nan = read "NaN" -inf = read "Infinity" -minusInf = read "-Infinity" +minusNaN, inf, minusInf :: Double +minusNaN = -nan +inf = infinity +minusInf = -infinity parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64) parseSign str = @@ -122,6 +120,12 @@ parseHexalSignedInt = token $ \(pos, _, s, _) len -> let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in Lexeme pos $ TIntLit $ sign num +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 $ fromIntegral num + parseDecimalSignedInt :: AlexAction Lexeme parseDecimalSignedInt = token $ \(pos, _, s, _) len -> let (sign, slen) = parseSign s in diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index d10ba10..e8d6002 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -71,6 +71,7 @@ import Control.Monad (guard) import Numeric.Natural (Natural) import Data.Word (Word32, Word64) import Data.Bits ((.|.)) +import Numeric.IEEE (infinity, nan) import Language.Wasm.Lexer ( Token ( @@ -318,8 +319,7 @@ u32 { Lexeme _ (TIntLit (asUInt32 -> Just $$)) } i32 { Lexeme _ (TIntLit (asInt32 -> Just $$)) } i64 { Lexeme _ (TIntLit (asInt64 -> Just $$)) } unrestricted_int { Lexeme _ (TIntLit $$) } -f32 { Lexeme _ (TFloatLit (asFloat32 -> $$)) } -f64 { Lexeme _ (TFloatLit (asFloat64 -> $$)) } +f64 { Lexeme _ (TFloatLit $$) } offset { Lexeme _ (TKeyword (asOffset -> Just $$)) } align { Lexeme _ (TKeyword (asAlign -> Just $$)) } string { Lexeme _ (TStringLit (asString -> Just $$)) } @@ -381,15 +381,14 @@ float32 :: { Float } | i32 { fromIntegral $1 } | i64 { fromIntegral $1 } | unrestricted_int { fromIntegral $1 } - | f32 { $1 } + | f64 { asFloat32 $1 } float64 :: { Double } : u32 { fromIntegral $1 } | i32 { fromIntegral $1 } | i64 { fromIntegral $1 } | unrestricted_int { fromIntegral $1 } - | f32 { realToFrac $1 } - | f64 { realToFrac $1 } + | f64 { $1 } plaininstr :: { PlainInstr } -- control instructions @@ -801,9 +800,9 @@ function :: { [ModuleField] } : 'func' opt(ident) export_import_typeuse_locals_body { $3 $2 } export_import_typeuse_locals_body :: { Maybe Ident -> [ModuleField] } - : ')' { \i -> [MFFunc $ emptyFunction { ident = i }] } + : ')' { \i -> [MFFunc Nothing $ emptyFunction { ident = i }] } | raw_instr list(instruction) ')' { - \i -> [MFFunc $ emptyFunction { ident = i, body = $1 ++ concat $2 }] + \i -> [MFFunc Nothing $ emptyFunction { ident = i, body = $1 ++ concat $2 }] } | '(' export_import_typeuse_locals_body1 { $2 } @@ -817,7 +816,7 @@ import_typeuse_locals_body1 :: { Maybe Ident -> ModuleField } : 'import' name name ')' typeuse ')' { \ident -> MFImport $ Import $2 $3 $ ImportFunc ident $5 } - | typeuse_locals_body1 { MFFunc . $1 } + | typeuse_locals_body1 { MFFunc Nothing . $1 } typeuse_locals_body1 :: { Maybe Ident -> Function } : 'type' typeidx ')' signature_locals_body { @@ -1100,10 +1099,7 @@ asInt64 val | otherwise = Nothing asFloat32 :: Double -> Float -asFloat32 = realToFrac - -asFloat64 :: Double -> Double -asFloat64 = id +asFloat32 v = realToFrac v asOffset :: LBS.ByteString -> Maybe Natural asOffset str = do @@ -1337,7 +1333,7 @@ data DataSegment = DataSegment { data ModuleField = MFType TypeDef | MFImport Import - | MFFunc Function + | MFFunc (Maybe Int) Function | MFTable Table | MFMem Memory | MFGlobal Global @@ -1443,7 +1439,7 @@ desugarize fields = S.mems = map synMemoryToStruct $ mems mod, S.globals = map (synGlobalToStruct mod) $ globals mod, S.start = fmap (synStartToStruct mod) $ start mod, - S.exports = synExportsToStruct mod fields + S.exports = synExportsToStruct mod $ appendIndexToFuncs fields } where -- utils @@ -1468,7 +1464,7 @@ desugarize fields = extractTypeDef defs (MFType _) = defs -- should be extracted before implicit defs extractTypeDef defs (MFImport Import { desc = ImportFunc _ typeUse }) = matchTypeUse defs typeUse - extractTypeDef defs (MFFunc Function { funcType, body }) = + extractTypeDef defs (MFFunc _ Function { funcType, body }) = extractTypeDefFromInstructions (matchTypeUse defs funcType) body extractTypeDef defs (MFGlobal Global { initializer }) = extractTypeDefFromInstructions defs initializer @@ -1649,7 +1645,7 @@ desugarize fields = } extractFunction :: [Function] -> ModuleField -> [Function] - extractFunction funcs (MFFunc fun) = fun : funcs + extractFunction funcs (MFFunc _ fun) = fun : funcs extractFunction funcs _ = funcs getLabelIdx :: FunCtx -> LabelIndex -> Maybe Natural @@ -1806,6 +1802,13 @@ desugarize fields = extractStart' start _ = start -- exports + appendIndexToFuncs :: [ModuleField] -> [ModuleField] + appendIndexToFuncs mf = reverse $ snd $ foldl' appendIndexToFunc (0, []) mf + where + appendIndexToFunc :: (Int, [ModuleField]) -> ModuleField -> (Int, [ModuleField]) + appendIndexToFunc (idx, mf) (MFFunc _ fun) = (idx + 1, (MFFunc (Just idx) fun):mf) + appendIndexToFunc (idx, mf) f = (idx, f:mf) + synExportsToStruct :: Module -> [ModuleField] -> [S.Export] synExportsToStruct mod (MFExport Export { name, desc = ExportFunc Nothing } : rest) = let @@ -1819,7 +1822,7 @@ desugarize fields = let idx = fromIntegral $ case head rest' of MFImport imp -> fromJust $ findIndex (== imp) funImports - MFFunc fun -> length funImports + (fromJust $ findIndex (== fun) $ functions mod) + MFFunc (Just idx) fun -> length funImports + idx _ -> error "export statement without index has to be followed with import or function" in map (\name -> S.Export name $ S.ExportFunc idx) names ++ synExportsToStruct mod rest' diff --git a/tests/Test.hs b/tests/Test.hs index dd1d160..16f8255 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 = ["imports.wast"] + -- let files = ["float_memory.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 0ed91c5..433292f 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -31,6 +31,7 @@ library , utf8-string >=1.0 , cereal >= 0.5 , vector >= 0.12 + , ieee754 >= 0.8 build-tools: alex >=3.1.3 , happy >=1.9.4