msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

fix multivalue return typecheck and some execution rules

Browse Source
This commit is contained in:
Ilya Rezvov
2021-04-06 23:20:03 -07:00
parent 604f8f190d
commit 93a79badbe
3 changed files with 19 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+13 -13
View File
@@ -636,13 +636,13 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
step _ Unreachable = return Trap
step ctx Nop = return $ Done ctx
step ctx (Block blockType expr) = do
let resType = case blockType of
Inline Nothing -> []
Inline (Just valType) -> [valType]
TypeIndex typeIdx -> results $ funcTypes moduleInstance ! fromIntegral typeIdx
let FuncType paramType resType = case blockType of
Inline Nothing -> FuncType [] []
Inline (Just valType) -> FuncType [] [valType]
TypeIndex typeIdx -> funcTypes moduleInstance ! fromIntegral typeIdx
res <- go ctx { labels = Label resType : labels ctx } expr
case res of
Break 0 r EvalCtx{ locals = ls } -> return $ Done ctx { locals = ls, stack = r ++ stack ctx }
Break 0 r EvalCtx{ locals = ls } -> return $ Done ctx { locals = ls, stack = r ++ (drop (length paramType) $ stack ctx) }
Break n r ctx' -> return $ Break (n - 1) r ctx'
Done ctx'@EvalCtx{ labels = (_:rest) } -> return $ Done ctx' { labels = rest }
command -> return command
@@ -653,26 +653,26 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
TypeIndex typeIdx -> results $ funcTypes moduleInstance ! fromIntegral typeIdx
res <- go ctx { labels = Label resType : labels ctx } expr
case res of
Break 0 r EvalCtx{ locals = ls } -> step ctx { locals = ls, stack = r ++ stack ctx } loop
Break 0 r EvalCtx{ locals = ls, stack = st } -> step ctx { locals = ls, stack = st } loop
Break n r ctx' -> return $ Break (n - 1) r ctx'
Done ctx'@EvalCtx{ labels = (_:rest) } -> return $ Done ctx' { labels = rest }
command -> return command
step ctx@EvalCtx{ stack = (VI32 v): rest } (If blockType true false) = do
let resType = case blockType of
Inline Nothing -> []
Inline (Just valType) -> [valType]
TypeIndex typeIdx -> results $ funcTypes moduleInstance ! fromIntegral typeIdx
let FuncType paramType resType = case blockType of
Inline Nothing -> FuncType [] []
Inline (Just valType) -> FuncType [] [valType]
TypeIndex typeIdx -> funcTypes moduleInstance ! fromIntegral typeIdx
let expr = if v /= 0 then true else false
res <- go ctx { labels = Label resType : labels ctx, stack = rest } expr
case res of
Break 0 r EvalCtx{ locals = ls } -> return $ Done ctx { locals = ls, stack = r ++ rest }
Break 0 r EvalCtx{ locals = ls } -> return $ Done ctx { locals = ls, stack = r ++ (drop (length paramType) rest) }
Break n r ctx' -> return $ Break (n - 1) r ctx'
Done ctx'@EvalCtx{ labels = (_:rest) } -> return $ Done ctx' { labels = rest }
command -> return command
step ctx@EvalCtx{ stack, labels } (Br label) = do
let idx = fromIntegral label
let Label resType = labels !! idx
case sequence $ zipWith checkValType resType $ take (length resType) stack of
case sequence $ zipWith checkValType (reverse resType) $ take (length resType) stack of
Just result -> return $ Break idx result ctx
Nothing -> return Trap
step ctx@EvalCtx{ stack = (VI32 v): rest } (BrIf label) =
@@ -685,7 +685,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
step ctx { stack = rest } (Br lbl)
step EvalCtx{ stack } Return =
let resType = results funcType in
case sequence $ zipWith checkValType resType $ take (length resType) stack of
case sequence $ zipWith checkValType (reverse resType) $ take (length resType) stack of
Just result -> return $ ReturnFn $ reverse result
Nothing -> return Trap
step ctx (Call fun) = do
src/Language/Wasm/Validate.hs
+5 -5
View File
@@ -98,7 +98,7 @@ data Arrow = Arrow End End deriving (Show, Eq)
(==>) a b = Arrow (toEnd a) (toEnd b)
asArrow :: FuncType -> Arrow
asArrow (FuncType params results) = Arrow (map Val params) (map Val results)
asArrow (FuncType params results) = Arrow (map Val params) (map Val $ reverse results)
isArrowMatch :: Arrow -> Arrow -> Bool
isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
@@ -210,7 +210,7 @@ getInstrType Block { blockType, body } = do
getInstrType Loop { blockType, body } = do
bt@(Arrow from _) <- getBlockType blockType
resultType <- getResultType blockType
t <- withLabel resultType $ getExpressionTypeWithInput from body
t <- withLabel [] $ getExpressionTypeWithInput from body
if isArrowMatch t bt
then return bt
else throwError $ TypeMismatch t bt
@@ -404,7 +404,7 @@ replace _ _ [] = []
replace x y (v:r) = (if x == v then y else v) : replace x y r
getExpressionTypeWithInput :: [VType] -> Expression -> Checker Arrow
getExpressionTypeWithInput inp = fmap ((inp `Arrow`) . reverse) . foldM go inp
getExpressionTypeWithInput inp = fmap (inp `Arrow`) . foldM go inp
where
go :: [VType] -> Instruction Natural -> Checker [VType]
go stack instr = do
@@ -485,9 +485,9 @@ isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types
let FuncType params results = types !! fromIntegral funcType
let ctx = ctxFromModule (params ++ locals) [results] results mod
arr <- runChecker ctx $ getExpressionType body
if isArrowMatch arr (empty ==> results)
if isArrowMatch arr (empty ==> (reverse results))
then return ()
else Left $ TypeMismatch arr (empty ==> results)
else Left $ TypeMismatch arr (empty ==> (reverse results))
else Left TypeIndexOutOfRange
functionsShouldBeValid :: Validator
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 = ["call.wast"]
-- let files = ["loop.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do