From d7641bcee21ac4b1219afd1c36647f66a148bf45 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sun, 8 Apr 2018 10:25:05 -0700 Subject: [PATCH] fix implicit type extraction --- src/Language/Wasm/Parser.y | 10 ++++++++-- src/Language/Wasm/Validate.hs | 28 ++++++++++++++-------------- tests/Test.hs | 1 + 3 files changed, 23 insertions(+), 16 deletions(-) diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 45726c4..15adfd5 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -1421,7 +1421,7 @@ data FunCtx = FunCtx { desugarize :: [ModuleField] -> S.Module desugarize fields = let mod = Module { - types = extract extractTypeDef fields, + types = reverse $ foldl' extractTypeDef (explicitTypeDefs fields) fields, functions = extract extractFunction fields, tables = extract extractTable fields, imports = extract extractImport fields, @@ -1457,8 +1457,14 @@ desugarize fields = synTypeDefToStruct (TypeDef _ FuncType { params, results }) = S.FuncType (map paramType params) results + explicitTypeDefs :: [ModuleField] -> [TypeDef] + explicitTypeDefs = map (\(MFType def) -> def) . filter isTypeDef + where + isTypeDef (MFType _) = True + isTypeDef _ = False + extractTypeDef :: [TypeDef] -> ModuleField -> [TypeDef] - extractTypeDef defs (MFType def) = def : defs + 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 }) = diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index b737b8d..d6b5e03 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -32,7 +32,7 @@ data ValidationResult = | ResultTypeDoesntMatch | NoTableInModule | NoMemoryInModule - | TypeMismatch + | TypeMismatch { actual :: Arrow, expected :: Arrow } | InvalidConstantExpr | InvalidStartFunctionType | ImportedGlobalIsNotConst @@ -169,20 +169,20 @@ getInstrType Block { result, body } = do t <- withLabel result $ getExpressionType body if isArrowMatch t blockType then return $ empty ==> result - else throwError TypeMismatch + else throwError $ TypeMismatch t blockType getInstrType Loop { result, body } = do let blockType = empty ==> result t <- withLabel result $ getExpressionType body if isArrowMatch t blockType then return $ empty ==> result - else throwError TypeMismatch + else throwError $ TypeMismatch t blockType getInstrType If { result, true, false } = do let blockType = empty ==> result l <- withLabel result $ getExpressionType true r <- withLabel result $ getExpressionType false - if isArrowMatch l blockType && isArrowMatch r blockType - then return $ I32 ==> result - else throwError TypeMismatch + if isArrowMatch l blockType + then (if isArrowMatch r blockType then (return $ I32 ==> result) else (throwError $ TypeMismatch r blockType)) + else throwError $ TypeMismatch l blockType getInstrType (Br lbl) = do r <- map Val . maybeToList <$> getLabel lbl return $ (Any : r) ==> Any @@ -373,7 +373,7 @@ unify (from `Arrow` to) (from' `Arrow` to') = unify' (f `Arrow` (Val v':t)) ((Val v:f') `Arrow` t') = if v == v' then unify' (f `Arrow` t) (f' `Arrow` t') - else throwError TypeMismatch + else throwError $ TypeMismatch (from `Arrow` to) (from' `Arrow` to') unify' (f `Arrow` (Var r:t)) ((Val v:f') `Arrow` t') = let subst = replace (Var r) (Val v) in unify' (subst f `Arrow` subst t) (f' `Arrow` t') @@ -463,7 +463,7 @@ isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types Right arr -> if isArrowMatch arr (empty ==> results) then Valid - else TypeMismatch + else TypeMismatch arr (empty ==> results) functionsShouldBeValid :: Validator functionsShouldBeValid mod@Module {functions} = @@ -510,11 +510,11 @@ globalsShouldBeValid m@Module { imports, globals } = let check = runChecker ctx $ do isConstExpression init t <- getExpressionType init - return $ isArrowMatch (empty ==> getGlobalType gt) t + return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch (empty ==> I32) t in case check of Left err -> err - Right eq -> if eq then Valid else TypeMismatch + Right res -> res elemsShouldBeValid :: Validator elemsShouldBeValid m@Module { elems, functions, tables, imports } = @@ -526,11 +526,11 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } = let check = runChecker ctx $ do isConstExpression offset t <- getExpressionType offset - return $ isArrowMatch (empty ==> I32) t + return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch (empty ==> I32) t in let isIniterValid = case check of Left err -> err - Right eq -> if eq then Valid else TypeMismatch + Right res -> res in let tableImports = filter isTableImport imports in let isTableIndexValid = @@ -552,11 +552,11 @@ datasShouldBeValid m@Module { datas, mems, imports } = let check = runChecker ctx $ do isConstExpression offset t <- getExpressionType offset - return $ isArrowMatch (empty ==> I32) t + return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch (empty ==> I32) t in let isOffsetValid = case check of Left err -> err - Right eq -> if eq then Valid else TypeMismatch + Right res -> res in let memImports = filter isMemImport imports in if memIdx < (fromIntegral $ length memImports + length mems) diff --git a/tests/Test.hs b/tests/Test.hs index c5051c7..e45e3c3 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -34,6 +34,7 @@ compile file = do main :: IO () main = do files <- Directory.listDirectory "tests/samples" + let files = ["func.wast"] scriptTestCases <- (`mapM` files) $ \file -> do content <- LBS.readFile $ "tests/samples/" ++ file let Right script = Parser.parseScript <$> Lexer.scanner content