From 3d9cb6132b92f0c54b19b46315e9086d2db11926 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Thu, 15 Mar 2018 21:53:02 -0700 Subject: [PATCH] make fact work --- src/Language/Wasm/Interpreter.hs | 89 ++++++++++++++++++-------------- tests/Test.hs | 17 +++++- 2 files changed, 67 insertions(+), 39 deletions(-) diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 55f8b32..bb644f9 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -2,8 +2,12 @@ {-# LANGUAGE NamedFieldPuns #-} module Language.Wasm.Interpreter ( + Value(..), instantiate, - invoke + invoke, + invokeExport, + emptyStore, + emptyImports ) where import qualified Data.Map as Map @@ -22,6 +26,8 @@ import qualified Control.Monad as Monad import Data.Monoid ((<>)) import Data.Bits ((.|.), (.&.), xor, shiftL, shiftR, rotateL, rotateR) +import Debug.Trace as Debug + import Language.Wasm.Structure as Struct data Value = @@ -154,6 +160,9 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl type Imports = Map.Map (TL.Text, TL.Text) ExternalValue +emptyImports :: Imports +emptyImports = Map.empty + allocFunctions :: ModuleInstance -> [Function] -> Vector FunctionInstance allocFunctions inst@ModuleInstance {funcTypes} funs = let mkFuncInst f@Function {funcType} = FunctionInstance (funcTypes ! (fromIntegral funcType)) inst f in @@ -318,6 +327,7 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT go ctx [] = return $ Done ctx go ctx (instr:rest) = do res <- step ctx instr + -- case Debug.trace ("after execution " ++ show instr ++ " result is: " ++ show res) $ res of case res of Done ctx' -> go ctx' rest command -> return command @@ -349,7 +359,7 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT let Label resType = labels !! idx return $ Break idx (zipWith checkValType resType $ take (length resType) stack) ctx step ctx@EvalCtx{ stack = (VI32 v): rest } (BrIf label) = - if v /= 0 + if v == 0 then return $ Done ctx { stack = rest } else step ctx { stack = rest } (Br label) step ctx@EvalCtx{ stack = (VI32 v): rest } (BrTable labels label) = @@ -433,32 +443,32 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT return $ Done ctx { stack = VI32 (v1 `rotateL` fromIntegral v2) : rest } step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IBinOp BS32 IRotr) = return $ Done ctx { stack = VI32 (v1 `rotateR` fromIntegral v2) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 IEq) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 IEq) = return $ Done ctx { stack = VI32 (if v1 == v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 INe) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 INe) = return $ Done ctx { stack = VI32 (if v1 /= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 ILtU) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 ILtU) = return $ Done ctx { stack = VI32 (if v1 < v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 ILtS) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 ILtS) = return $ Done ctx { stack = VI32 (if asInt32 v1 < asInt32 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 IGtU) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 IGtU) = return $ Done ctx { stack = VI32 (if v1 > v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 IGtS) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 IGtS) = return $ Done ctx { stack = VI32 (if asInt32 v1 > asInt32 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 ILeU) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 ILeU) = return $ Done ctx { stack = VI32 (if v1 <= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 ILeS) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 ILeS) = return $ Done ctx { stack = VI32 (if asInt32 v1 <= asInt32 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 IGeU) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 IGeU) = return $ Done ctx { stack = VI32 (if v1 >= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IRelOp BS32 IGeS) = + step ctx@EvalCtx{ stack = (VI32 v2:VI32 v1:rest) } (IRelOp BS32 IGeS) = return $ Done ctx { stack = VI32 (if asInt32 v1 >= asInt32 v2 then 1 else 0) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IAdd) = - return $ Done ctx { stack = VI64 (v1 + v2) : rest } + return $ Done ctx { stack = VI64 (asWord64 $ asInt64 v1 + asInt64 v2) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 ISub) = - return $ Done ctx { stack = VI64 (v1 - v2) : rest } + return $ Done ctx { stack = VI64 (asWord64 $ asInt64 v1 - asInt64 v2) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IMul) = - return $ Done ctx { stack = VI64 (v1 * v2) : rest } + return $ Done ctx { stack = VI64 (asWord64 $ asInt64 v1 * asInt64 v2) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IDivU) = return $ Done ctx { stack = VI64 (v1 `div` v2) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IDivS) = @@ -483,31 +493,34 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT return $ Done ctx { stack = VI64 (v1 `rotateL` fromIntegral v2) : rest } step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IRotr) = return $ Done ctx { stack = VI64 (v1 `rotateR` fromIntegral v2) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IEq) = - return $ Done ctx { stack = VI64 (if v1 == v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 INe) = - return $ Done ctx { stack = VI64 (if v1 /= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILtU) = - return $ Done ctx { stack = VI64 (if v1 < v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILtS) = - return $ Done ctx { stack = VI64 (if asInt64 v1 < asInt64 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGtU) = - return $ Done ctx { stack = VI64 (if v1 > v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGtS) = - return $ Done ctx { stack = VI64 (if asInt64 v1 > asInt64 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILeU) = - return $ Done ctx { stack = VI64 (if v1 <= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILeS) = - return $ Done ctx { stack = VI64 (if asInt64 v1 <= asInt64 v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGeU) = - return $ Done ctx { stack = VI64 (if v1 >= v2 then 1 else 0) : rest } - step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGeS) = - return $ Done ctx { stack = VI64 (if asInt64 v1 >= asInt64 v2 then 1 else 0) : rest } - step _ instr = error $ "Error during evaluation of instruction " ++ show instr + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IEq) = + return $ Done ctx { stack = VI32 (if v1 == v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 INe) = + return $ Done ctx { stack = VI32 (if v1 /= v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILtU) = + return $ Done ctx { stack = VI32 (if v1 < v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILtS) = + return $ Done ctx { stack = VI32 (if asInt64 v1 < asInt64 v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGtU) = + return $ Done ctx { stack = VI32 (if v1 > v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGtS) = + return $ Done ctx { stack = VI32 (if asInt64 v1 > asInt64 v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILeU) = + return $ Done ctx { stack = VI32 (if v1 <= v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILeS) = + return $ Done ctx { stack = VI32 (if asInt64 v1 <= asInt64 v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGeU) = + return $ Done ctx { stack = VI32 (if v1 >= v2 then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGeS) = + return $ Done ctx { stack = VI32 (if asInt64 v1 >= asInt64 v2 then 1 else 0) : rest } + step _ instr = error $ "Error during evaluation of instruction: " ++ show instr eval store HostInstance { funcType, tag } args = return args invoke :: Store -> Address -> [Value] -> IO [Value] invoke st funcIdx = eval st $ funcInstances st ! funcIdx -invokeExport :: Store -> TL.Text -> [Value] -> IO [Value] -invokeExport = undefined \ No newline at end of file +invokeExport :: Store -> ModuleInstance -> TL.Text -> [Value] -> IO [Value] +invokeExport st ModuleInstance { exports } name args = + case Vector.find (\(ExportInstance n _) -> n == name) exports of + Just (ExportInstance _ (ExternFunction addr)) -> invoke st addr args + _ -> error $ "Function with name " ++ show name ++ " was not found in module's exports" \ No newline at end of file diff --git a/tests/Test.hs b/tests/Test.hs index 3c671b1..4b9c28c 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Main ( main ) where @@ -14,6 +15,7 @@ import qualified Language.Wasm.Parser as Parser import qualified Language.Wasm.Structure as Structure import qualified Language.Wasm.Binary as Binary import qualified Language.Wasm.Validate as Validate +import qualified Language.Wasm.Interpreter as Interpreter import qualified Debug.Trace as Debug @@ -53,8 +55,21 @@ main = do assertEqual "Too many tables" Validate.MoreThanOneTable $ Validate.validate mod _ -> assertBool "Module matched" $ Validate.isValid $ Validate.validate mod + interpretFact <- do + content <- LBS.readFile "tests/samples/fact.wast" + let Right mod = Parser.parseModule <$> Lexer.scanner content + (modInst, store) <- Interpreter.instantiate Interpreter.emptyStore Interpreter.emptyImports mod + let fac = \n -> Interpreter.invokeExport store modInst "fac-opt" [Interpreter.VI64 n] + fac3 <- fac 3 + fac5 <- fac 5 + fac8 <- fac 8 + return $ testCase "Interprete factorial" $ do + assertEqual "Fact 3! == 120" [Interpreter.VI64 6] fac3 + assertEqual "Fact 5! == 120" [Interpreter.VI64 120] fac5 + assertEqual "Fact 8! == 40320" [Interpreter.VI64 40320] fac8 defaultMain $ testGroup "tests" [ testGroup "Syntax parsing" syntaxTestCases, testGroup "Binary format" binaryTestCases, - testGroup "Validation" validationTestCases + testGroup "Validation" validationTestCases, + testGroup "Interpretation" [interpretFact] ]