GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

parse arithmetic nan

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-08 19:47:10 -07:00
parent 6b376ee4cb
commit 8ef3eadc9a
4 changed files with 35 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Lexer.x
+13 -9
View File
@@ -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
src/Language/Wasm/Parser.y
+20 -17
View File
@@ -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'
tests/Test.hs
+1 -1
View File
@@ -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
wasm.cabal
+1
View File
@@ -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