diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index acb36dc..fb40ce7 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -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 diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 0ee0390..da45074 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs index 4c22eb1..bd8c60e 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 = ["call.wast"] + -- let files = ["loop.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do