added line position for failed asserts and implemented mutable globals import/export proposal

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