msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests 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 #-}
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
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"
tests/Test.hs
+16 -1
View File
@@ -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]
]