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

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

Browse Source
This commit is contained in:
Ilya Rezvov
2021-03-09 22:45:16 -08:00
parent 20c2623b1c
commit 01e0ab8d44
4 changed files with 101 additions and 69 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+10 -8
View File
@@ -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
src/Language/Wasm/Parser.y
+50 -27
View File
@@ -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
src/Language/Wasm/Script.hs
+40 -33
View File
@@ -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
tests/Test.hs
+1 -1
View File
@@ -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