From 01e0ab8d44b31ca551b489297aa78ac6d0ed97ac Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Tue, 9 Mar 2021 22:45:16 -0800 Subject: [PATCH] added line position for failed asserts and implemented mutable globals import/export proposal --- src/Language/Wasm/Interpreter.hs | 18 ++++---- src/Language/Wasm/Parser.y | 77 +++++++++++++++++++++----------- src/Language/Wasm/Script.hs | 73 ++++++++++++++++-------------- tests/Test.hs | 2 +- 4 files changed, 101 insertions(+), 69 deletions(-) diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 1a0dbed..1a2242a 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -19,7 +19,8 @@ module Language.Wasm.Interpreter ( emptyStore, emptyImports, makeHostModule, - makeMutGlobal + makeMutGlobal, + makeConstGlobal ) where import qualified Data.Map as Map @@ -177,6 +178,9 @@ data GlobalInstance = GIConst ValueType Value | GIMut ValueType (IORef Value) makeMutGlobal :: Value -> IO GlobalInstance makeMutGlobal val = GIMut (getValueType val) <$> newIORef val +makeConstGlobal :: Value -> GlobalInstance +makeConstGlobal val = GIConst (getValueType val) val + getValueType :: Value -> ValueType getValueType (VI32 _) = I32 getValueType (VI64 _) = I64 @@ -364,13 +368,11 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl ExternGlobal globalAddr -> return globalAddr _ -> err let globalInst = gs ! globalAddr - let vt = case globalType of - Const vt -> vt - Mut vt -> vt - let vt' = case globalInst of - GIConst vt _ -> vt - GIMut vt _ -> vt - if vt == vt' then return idx else err + let typesMatch = case (globalType, globalInst) of + (Const vt, GIConst vt' _) -> vt == vt' + (Mut vt, GIMut vt' _) -> vt == vt' + _ -> False + if typesMatch then return idx else err checkImportType imp@(Import _ _ (ImportMemory limit)) = do idx <- getImpIdx imp memAddr <- case idx of diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 2d94e1d..c9259e5 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -313,14 +313,14 @@ import Language.Wasm.Lexer ( 'register' { Lexeme _ (TKeyword "register") } 'invoke' { Lexeme _ (TKeyword "invoke") } 'get' { Lexeme _ (TKeyword "get") } -'assert_return' { Lexeme _ (TKeyword "assert_return") } -'assert_return_canonical_nan' { Lexeme _ (TKeyword "assert_return_canonical_nan") } -'assert_return_arithmetic_nan' { Lexeme _ (TKeyword "assert_return_arithmetic_nan") } -'assert_trap' { Lexeme _ (TKeyword "assert_trap") } -'assert_malformed' { Lexeme _ (TKeyword "assert_malformed") } -'assert_invalid' { Lexeme _ (TKeyword "assert_invalid") } -'assert_unlinkable' { Lexeme _ (TKeyword "assert_unlinkable") } -'assert_exhaustion' { Lexeme _ (TKeyword "assert_exhaustion") } +'assert_return' { Lexeme $$ (TKeyword "assert_return") } +'assert_return_canonical_nan' { Lexeme $$ (TKeyword "assert_return_canonical_nan") } +'assert_return_arithmetic_nan' { Lexeme $$ (TKeyword "assert_return_arithmetic_nan") } +'assert_trap' { Lexeme $$ (TKeyword "assert_trap") } +'assert_malformed' { Lexeme $$ (TKeyword "assert_malformed") } +'assert_invalid' { Lexeme $$ (TKeyword "assert_invalid") } +'assert_unlinkable' { Lexeme $$ (TKeyword "assert_unlinkable") } +'assert_exhaustion' { Lexeme $$ (TKeyword "assert_exhaustion") } 'script' { Lexeme _ (TKeyword "script") } 'input' { Lexeme _ (TKeyword "input") } 'output' { Lexeme _ (TKeyword "output") } @@ -1104,7 +1104,7 @@ command1 :: { Command } : module1 { ModuleDef $1 } | 'register' string opt(ident) ')' { Register $2 $3 } | action1 { Action $1 } - | assertion1 { Assertion $1 } + | assertion1 { let (Just (AlexPn _ line _), a) = $1 in Assertion line a } | meta1 { Meta $1 } module1 :: { ModuleDef } @@ -1117,15 +1117,15 @@ action1 :: { Action } : 'invoke' opt(ident) string list(folded_instr) ')' { Invoke $2 $3 (map (map constInstructionToValue) $4) } | 'get' opt(ident) string ')' { Get $2 $3 } -assertion1 :: { Assertion } - : 'assert_return' '(' action1 list(folded_instr) ')' { AssertReturn $3 (map (map constInstructionToValue) $4) } - | 'assert_return_canonical_nan' '(' action1 ')' { AssertReturnCanonicalNaN $3 } - | 'assert_return_arithmetic_nan' '(' action1 ')' { AssertReturnArithmeticNaN $3 } - | 'assert_trap' '(' assertion_trap string ')' { AssertTrap $3 $4 } - | 'assert_malformed' '(' module1 string ')' { AssertMalformed $3 $4 } - | 'assert_invalid' '(' module1 string ')' { AssertInvalid $3 $4 } - | 'assert_unlinkable' '(' module1 string ')' { AssertUnlinkable $3 $4 } - | 'assert_exhaustion' '(' action1 string ')' { AssertExhaustion $3 $4 } +assertion1 :: { (Maybe AlexPosn, Assertion) } + : 'assert_return' '(' action1 list(folded_instr) ')' { ($1, AssertReturn $3 (map (map constInstructionToValue) $4)) } + | 'assert_return_canonical_nan' '(' action1 ')' { ($1, AssertReturnCanonicalNaN $3) } + | 'assert_return_arithmetic_nan' '(' action1 ')' { ($1, AssertReturnArithmeticNaN $3) } + | 'assert_trap' '(' assertion_trap string ')' { ($1, AssertTrap $3 $4) } + | 'assert_malformed' '(' module1 string ')' { ($1, AssertMalformed $3 $4) } + | 'assert_invalid' '(' module1 string ')' { ($1, AssertInvalid $3 $4) } + | 'assert_unlinkable' '(' module1 string ')' { ($1, AssertUnlinkable $3 $4) } + | 'assert_exhaustion' '(' action1 string ')' { ($1, AssertExhaustion $3 $4) } assertion_trap :: { Either Action ModuleDef } : action1 { Left $1 } @@ -1454,7 +1454,7 @@ data Command = ModuleDef ModuleDef | Register TL.Text (Maybe Ident) | Action Action - | Assertion Assertion + | Assertion Int Assertion | Meta Meta deriving (Show, Eq) @@ -1518,6 +1518,7 @@ desugarize fields = do segments <- mapM (synDataToStruct mod) $ datas mod globs <- mapM (synGlobalToStruct mod) $ globals mod checkMemoryIdentsUniqueness mod + checkGlobalIdentsUniqueness mod return S.Module { S.types = map synTypeDefToStruct $ types mod, S.functions = funs, @@ -1855,7 +1856,7 @@ desugarize fields = do getMemIndexes :: Module -> Ident -> [Natural] getMemIndexes Module { imports, mems } id = let memImports = zip [0..] $ filter isMemImport imports in - let importIndexes = map fst $ filter (\((_, Import { desc = ImportMemory ident _ })) -> ident == Just id) memImports in + let importIndexes = map fst $ filter (\(_, Import { desc = ImportMemory ident _ }) -> ident == Just id) memImports in let isIdent (_, (Memory _ (Just id) _)) = True in let memIndexes = map fst $ filter isIdent $ zip [length memImports..] mems in map fromIntegral $ importIndexes ++ memIndexes @@ -1873,6 +1874,23 @@ desugarize fields = do let ctx = FunCtx mod [] [] [] in S.Global globalType <$> mapM (synInstrToStruct ctx) initializer + checkGlobalIdentsUniqueness :: Module -> Either String () + checkGlobalIdentsUniqueness m@Module { imports, globals } = do + mapM_ checkImportUniqueness $ filter isGlobalImport imports + mapM_ checkGlobalUniqueness globals + where + checkImportUniqueness Import { desc = ImportGlobal (Just id) _ } = + if length (getGlobalIndexes m id) > 1 + then Left "duplicate global" + else return () + checkImportUniqueness _ = return () + + checkGlobalUniqueness (Global _ (Just id) _ _) = + if length (getGlobalIndexes m id) > 1 + then Left "duplicate global" + else return () + checkGlobalUniqueness _ = return () + extractGlobal :: [Global] -> ModuleField -> [Global] extractGlobal globals (MFGlobal global) = global : globals extractGlobal globals _ = globals @@ -1881,14 +1899,19 @@ desugarize fields = do isGlobalImport Import { desc = ImportGlobal _ _ } = True isGlobalImport _ = False + getGlobalIndexes :: Module -> Ident -> [Natural] + getGlobalIndexes Module { imports, globals } id = + let globalImports = zip [0..] $ filter isGlobalImport imports in + let importIndexes = map fst $ filter (\(_, Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports in + let isIdent (_, Global { ident }) = ident == Just id in + let globalIndexes = map fst $ filter isIdent $ zip [length globalImports..] globals in + map fromIntegral $ importIndexes ++ globalIndexes + getGlobalIndex :: Module -> GlobalIndex -> Maybe Natural - getGlobalIndex Module { imports, globals } (Named id) = - let globalImports = filter isGlobalImport imports in - case findIndex (\(Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports of - Just idx -> return $ fromIntegral idx - Nothing -> - let isIdent (Global { ident }) = ident == Just id in - fromIntegral . (+ length globalImports) <$> findIndex isIdent globals + getGlobalIndex mod@Module { imports, globals } (Named id) = + case getGlobalIndexes mod id of + [idx] -> return idx + _ -> Nothing getGlobalIndex Module { imports, globals } (Index idx) = Just idx -- elem segment diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 603ba08..c1a63ce 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -47,7 +47,7 @@ emptyState = ScriptState { runScript :: OnAssertFail -> Script -> IO () runScript onAssertFail script = do - (globI32, globF32, globF64) <- hostGlobals + (globI32, globI64, globF32, globF64) <- hostGlobals (st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [ ("print", hostPrint []), ("print_i32", hostPrint [Struct.I32]), @@ -56,6 +56,7 @@ runScript onAssertFail script = do ("print_f32", hostPrint [Struct.F32]), ("print_f64", hostPrint [Struct.F64]), ("global_i32", globI32), + ("global_i64", globI64), ("global_f32", globF32), ("global_f64", globF64), ("memory", Interpreter.HostMemory $ Struct.Limit 1 (Just 2)), @@ -65,10 +66,16 @@ runScript onAssertFail script = do where hostPrint paramTypes = Interpreter.HostFunction (Struct.FuncType paramTypes []) (\args -> return []) hostGlobals = do - globI32 <- Interpreter.makeMutGlobal $ Interpreter.VI32 666 + let globI32 = Interpreter.makeConstGlobal $ Interpreter.VI32 666 + let globI64 = Interpreter.makeConstGlobal $ Interpreter.VI64 666 globF32 <- Interpreter.makeMutGlobal $ Interpreter.VF32 666 globF64 <- Interpreter.makeMutGlobal $ Interpreter.VF64 666 - return (Interpreter.HostGlobal globI32, Interpreter.HostGlobal globF32, Interpreter.HostGlobal globF64) + return ( + Interpreter.HostGlobal globI32, + Interpreter.HostGlobal globI64, + Interpreter.HostGlobal globF32, + Interpreter.HostGlobal globF64 + ) go [] _ = return () go (c:cs) st = runCommand st c >>= go cs @@ -130,19 +137,19 @@ runScript onAssertFail script = do isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2 isValueEqual _ _ = False - isNaNReturned :: ScriptState -> Action -> Assertion -> IO () - isNaNReturned st action assert = do + isNaNReturned :: ScriptState -> String -> Action -> Assertion -> IO () + isNaNReturned st pos action assert = do result <- runAction st action case result of Just [Interpreter.VF32 v] -> if isNaN v then return () - else onAssertFail ("Expected NaN, but action returned " ++ show v) assert + else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert Just [Interpreter.VF64 v] -> if isNaN v then return () - else onAssertFail ("Expected NaN, but action returned " ++ show v) assert - _ -> onAssertFail ("Expected NaN, but action returned " ++ show result) assert + else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert + _ -> onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show result) assert buildModule :: ModuleDef -> (Maybe Ident, Struct.Module) buildModule (RawModDef ident m) = (ident, m) @@ -178,67 +185,67 @@ runScript onAssertFail script = do getFailureString Validate.InvalidStartFunctionType = ["start function"] getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]] - runAssert :: ScriptState -> Assertion -> IO () - runAssert st assert@(AssertReturn action expected) = do + runAssert :: ScriptState -> String -> Assertion -> IO () + runAssert st pos assert@(AssertReturn action expected) = do result <- runAction st action case result of Just result -> do if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected)) then return () - else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert - Nothing -> onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert - runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert - runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert - runAssert st assert@(AssertInvalid moduleDef failureString) = + else onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert + Nothing -> onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert + runAssert st pos assert@(AssertReturnCanonicalNaN action) = isNaNReturned st pos action assert + runAssert st pos assert@(AssertReturnArithmeticNaN action) = isNaNReturned st pos action assert + runAssert st pos assert@(AssertInvalid moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of - Right _ -> onAssertFail "An invalid module passed validation step" assert + Right _ -> onAssertFail (pos ++ ": An invalid module passed validation step") assert Left reason -> if failureString `elem` getFailureString reason then return () else - let msg = "Module is invalid for other reason. Expected " + let msg = pos ++ ": Module is invalid for other reason. Expected " ++ show failureString ++ ", but actual is " ++ show (getFailureString reason) in onAssertFail msg assert - runAssert st assert@(AssertMalformed (TextModDef _ textRep) failureString) = + runAssert st pos assert@(AssertMalformed (TextModDef _ textRep) failureString) = case DeepSeq.force $ Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule of - Right _ -> onAssertFail ("Module parsing should fail with failure string " ++ show failureString) assert + Right _ -> onAssertFail (pos ++ ": Module parsing should fail with failure string " ++ show failureString) assert Left _ -> return () - runAssert st assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) = + runAssert st pos assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) = case Binary.decodeModuleLazy binaryRep of - Right _ -> onAssertFail ("Module decoding should fail with failure string " ++ show failureString) assert + Right _ -> onAssertFail (pos ++ ": Module decoding should fail with failure string " ++ show failureString) assert Left _ -> return () - runAssert st assert@(AssertMalformed (RawModDef _ _) failureString) = return () - runAssert st assert@(AssertUnlinkable moduleDef failureString) = + runAssert st _ assert@(AssertMalformed (RawModDef _ _) failureString) = return () + runAssert st pos assert@(AssertUnlinkable moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of Right m -> do res <- Interpreter.instantiate (store st) (buildImports st) m case res of Left err -> return () - Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert - Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason - runAssert st assert@(AssertTrap (Left action) failureString) = do + Right _ -> onAssertFail (pos ++ ": Module linking should fail with failure string " ++ show failureString) assert + Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason + runAssert st pos assert@(AssertTrap (Left action) failureString) = do result <- runAction st action if isNothing result then return () - else onAssertFail ("Expected trap, but action returned " ++ show (fromJust result)) assert - runAssert st assert@(AssertTrap (Right moduleDef) failureString) = + else onAssertFail (pos ++ ":Expected trap, but action returned " ++ show (fromJust result)) assert + runAssert st pos assert@(AssertTrap (Right moduleDef) failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of Right m -> do res <- Interpreter.instantiate (store st) (buildImports st) m case res of Left "Start function terminated with trap" -> return () - _ -> onAssertFail ("Module linking should fail with trap during execution of a start function") assert - Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason - runAssert st assert@(AssertExhaustion action failureString) = do + _ -> onAssertFail (pos ++ ": Module linking should fail with trap during execution of a start function") assert + Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason + runAssert st pos assert@(AssertExhaustion action failureString) = do result <- runAction st action if isNothing result then return () - else onAssertFail ("Expected exhaustion, but action returned " ++ show (fromJust result)) assert + else onAssertFail (pos ++ ": Expected exhaustion, but action returned " ++ show (fromJust result)) assert runCommand :: ScriptState -> Command -> IO ScriptState runCommand st (ModuleDef moduleDef) = @@ -246,5 +253,5 @@ runScript onAssertFail script = do addModule ident m st runCommand st (Register name i) = return $ addToRegistery name i st runCommand st (Action action) = runAction st action >> return st - runCommand st (Assertion assertion) = runAssert st assertion >> return st + runCommand st (Assertion pos assertion) = runAssert st ("Line " ++ show pos) assertion >> return st runCommand st _ = return st diff --git a/tests/Test.hs b/tests/Test.hs index f66b65f..409d653 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -17,7 +17,7 @@ import qualified Data.List as List main :: IO () main = do files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec" - -- let files = ["linking.wast"] + -- let files = ["global.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do