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

make fact work

Browse Source
This commit is contained in:
Ilya Rezvov
2018-03-15 21:53:02 -07:00
parent 421d7db976
commit 3d9cb6132b
2 changed files with 67 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+51 -38
View File
@@ -2,8 +2,12 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module Language.Wasm.Interpreter ( module Language.Wasm.Interpreter (
Value(..),
instantiate, instantiate,
invoke invoke,
invokeExport,
emptyStore,
emptyImports
) where ) where
import qualified Data.Map as Map import qualified Data.Map as Map
@@ -22,6 +26,8 @@ import qualified Control.Monad as Monad
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Bits ((.|.), (.&.), xor, shiftL, shiftR, rotateL, rotateR) import Data.Bits ((.|.), (.&.), xor, shiftL, shiftR, rotateL, rotateR)
import Debug.Trace as Debug
import Language.Wasm.Structure as Struct import Language.Wasm.Structure as Struct
data Value = 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 type Imports = Map.Map (TL.Text, TL.Text) ExternalValue
emptyImports :: Imports
emptyImports = Map.empty
allocFunctions :: ModuleInstance -> [Function] -> Vector FunctionInstance allocFunctions :: ModuleInstance -> [Function] -> Vector FunctionInstance
allocFunctions inst@ModuleInstance {funcTypes} funs = allocFunctions inst@ModuleInstance {funcTypes} funs =
let mkFuncInst f@Function {funcType} = FunctionInstance (funcTypes ! (fromIntegral funcType)) inst f in 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 [] = return $ Done ctx
go ctx (instr:rest) = do go ctx (instr:rest) = do
res <- step ctx instr res <- step ctx instr
-- case Debug.trace ("after execution " ++ show instr ++ " result is: " ++ show res) $ res of
case res of case res of
Done ctx' -> go ctx' rest Done ctx' -> go ctx' rest
command -> return command command -> return command
@@ -349,7 +359,7 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT
let Label resType = labels !! idx let Label resType = labels !! idx
return $ Break idx (zipWith checkValType resType $ take (length resType) stack) ctx return $ Break idx (zipWith checkValType resType $ take (length resType) stack) ctx
step ctx@EvalCtx{ stack = (VI32 v): rest } (BrIf label) = step ctx@EvalCtx{ stack = (VI32 v): rest } (BrIf label) =
if v /= 0 if v == 0
then return $ Done ctx { stack = rest } then return $ Done ctx { stack = rest }
else step ctx { stack = rest } (Br label) else step ctx { stack = rest } (Br label)
step ctx@EvalCtx{ stack = (VI32 v): rest } (BrTable labels 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 } return $ Done ctx { stack = VI32 (v1 `rotateL` fromIntegral v2) : rest }
step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IBinOp BS32 IRotr) = step ctx@EvalCtx{ stack = (VI32 v1:VI32 v2:rest) } (IBinOp BS32 IRotr) =
return $ Done ctx { stack = VI32 (v1 `rotateR` fromIntegral v2) : rest } 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 } 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 } 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 } 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 } 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 } 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 } 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 } 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 } 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 } 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 } 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) = 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) = 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) = 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) = step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IDivU) =
return $ Done ctx { stack = VI64 (v1 `div` v2) : rest } return $ Done ctx { stack = VI64 (v1 `div` v2) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IDivS) = 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 } return $ Done ctx { stack = VI64 (v1 `rotateL` fromIntegral v2) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IRotr) = step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IBinOp BS64 IRotr) =
return $ Done ctx { stack = VI64 (v1 `rotateR` fromIntegral v2) : rest } return $ Done ctx { stack = VI64 (v1 `rotateR` fromIntegral v2) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IEq) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IEq) =
return $ Done ctx { stack = VI64 (if v1 == v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 == v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 INe) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 INe) =
return $ Done ctx { stack = VI64 (if v1 /= v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 /= v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILtU) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILtU) =
return $ Done ctx { stack = VI64 (if v1 < v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 < v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILtS) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILtS) =
return $ Done ctx { stack = VI64 (if asInt64 v1 < asInt64 v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if asInt64 v1 < asInt64 v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGtU) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGtU) =
return $ Done ctx { stack = VI64 (if v1 > v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 > v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGtS) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGtS) =
return $ Done ctx { stack = VI64 (if asInt64 v1 > asInt64 v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if asInt64 v1 > asInt64 v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILeU) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILeU) =
return $ Done ctx { stack = VI64 (if v1 <= v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 <= v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 ILeS) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 ILeS) =
return $ Done ctx { stack = VI64 (if asInt64 v1 <= asInt64 v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if asInt64 v1 <= asInt64 v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGeU) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGeU) =
return $ Done ctx { stack = VI64 (if v1 >= v2 then 1 else 0) : rest } return $ Done ctx { stack = VI32 (if v1 >= v2 then 1 else 0) : rest }
step ctx@EvalCtx{ stack = (VI64 v1:VI64 v2:rest) } (IRelOp BS64 IGeS) = step ctx@EvalCtx{ stack = (VI64 v2:VI64 v1:rest) } (IRelOp BS64 IGeS) =
return $ Done ctx { stack = VI64 (if asInt64 v1 >= asInt64 v2 then 1 else 0) : rest } 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 step _ instr = error $ "Error during evaluation of instruction: " ++ show instr
eval store HostInstance { funcType, tag } args = return args eval store HostInstance { funcType, tag } args = return args
invoke :: Store -> Address -> [Value] -> IO [Value] invoke :: Store -> Address -> [Value] -> IO [Value]
invoke st funcIdx = eval st $ funcInstances st ! funcIdx invoke st funcIdx = eval st $ funcInstances st ! funcIdx
invokeExport :: Store -> TL.Text -> [Value] -> IO [Value] invokeExport :: Store -> ModuleInstance -> TL.Text -> [Value] -> IO [Value]
invokeExport = undefined 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"
tests/Test.hs
+16 -1
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module Main ( module Main (
main main
) where ) where
@@ -14,6 +15,7 @@ import qualified Language.Wasm.Parser as Parser
import qualified Language.Wasm.Structure as Structure import qualified Language.Wasm.Structure as Structure
import qualified Language.Wasm.Binary as Binary import qualified Language.Wasm.Binary as Binary
import qualified Language.Wasm.Validate as Validate import qualified Language.Wasm.Validate as Validate
import qualified Language.Wasm.Interpreter as Interpreter
import qualified Debug.Trace as Debug import qualified Debug.Trace as Debug
@@ -53,8 +55,21 @@ main = do
assertEqual "Too many tables" Validate.MoreThanOneTable $ Validate.validate mod assertEqual "Too many tables" Validate.MoreThanOneTable $ Validate.validate mod
_ -> _ ->
assertBool "Module matched" $ Validate.isValid $ 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" [ defaultMain $ testGroup "tests" [
testGroup "Syntax parsing" syntaxTestCases, testGroup "Syntax parsing" syntaxTestCases,
testGroup "Binary format" binaryTestCases, testGroup "Binary format" binaryTestCases,
testGroup "Validation" validationTestCases testGroup "Validation" validationTestCases,
testGroup "Interpretation" [interpretFact]
] ]