From edbdeaec46bdcbc75e14fa53b00cc2c03d8d0893 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Wed, 14 Mar 2018 21:12:01 -0700 Subject: [PATCH] start instruction evaluator --- src/Language/Wasm/Binary.hs | 2 +- src/Language/Wasm/Interpreter.hs | 100 ++++++++++++++++++++++++------- src/Language/Wasm/Parser.y | 2 +- src/Language/Wasm/Structure.hs | 2 +- src/Language/Wasm/Validate.hs | 2 +- 5 files changed, 82 insertions(+), 26 deletions(-) diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index 7aca0ef..a361508 100644 --- a/src/Language/Wasm/Binary.hs +++ b/src/Language/Wasm/Binary.hs @@ -719,7 +719,7 @@ instance Serialize LocalTypeRange where get = LocalTypeRange <$> getULEB128 <*> get instance Serialize Function where - put Function {locals, body} = do + put Function {localTypes = locals, body} = do let bs = runPut $ do putVec $ map (LocalTypeRange 1) locals putExpression body diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index daae2c2..450da93 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -14,7 +14,7 @@ import Data.Vector (Vector, (!), (!?), (//)) import Data.Vector.Storable.Mutable (IOVector) import qualified Data.Vector as Vector import qualified Data.Vector.Storable.Mutable as IOVector -import Data.IORef (IORef, newIORef, readIORef) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Word (Word8, Word32, Word64) import Numeric.Natural (Natural) import qualified Control.Monad as Monad @@ -29,17 +29,7 @@ data Value = | VF64 Double deriving (Eq, Show) -data AdminInstr = - I Instruction - | Trap - | Invoke Address - | InitElem Address Word32 [Natural] - | InitData Address Word32 LBS.ByteString - | Label [AdminInstr] [AdminInstr] - | IFrame Frame [AdminInstr] - deriving (Show, Eq) - -data Frame = Frame { locals :: Vector Value, mod :: ModuleInstance } deriving (Eq, Show) +data Label = Label type Address = Int @@ -203,9 +193,15 @@ allocMems mems = Vector.fromList <$> mapM allocMem mems } initialize :: ModuleInstance -> Module -> Store -> IO Store -initialize inst Module {elems, datas} store = do - store' <- Monad.foldM initElem store elems - Monad.foldM initData store' datas +initialize inst Module {elems, datas, start} store = do + storeWithTables <- Monad.foldM initElem store elems + storeWithMems <- Monad.foldM initData storeWithTables datas + case start of + Just (StartFunction idx) -> do + let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) + [] <- eval storeWithMems funInst [] + return storeWithMems + Nothing -> return storeWithMems where initElem :: Store -> ElemSegment -> IO Store initElem st ElemSegment {tableIndex, offset, funcIndexes} = do @@ -235,9 +231,7 @@ initialize inst Module {elems, datas} store = do mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk return $ st { memInstances = memInstances st // [(idx, MemoryInstance mem maxLen)] } -data EvalContext = EvalContext ModuleInstance (IORef Store) - -instantiate :: Store -> Imports -> Module -> IO EvalContext +instantiate :: Store -> Imports -> Module -> IO (ModuleInstance, Store) instantiate st imps m = do let inst = calcInstance st imps m let functions = funcInstances st <> (allocFunctions inst $ Struct.functions m) @@ -250,8 +244,70 @@ instantiate st imps m = do memInstances = mems, globalInstances = globals } - ref <- newIORef st' - return $ EvalContext inst ref + return (inst, st') -invoke :: EvalContext -> TL.Text -> [Value] -> IO [Value] -invoke = undefined \ No newline at end of file +type Stack = [Value] + +data EvalCtx = EvalCtx { + locals :: Vector Value, + labels :: [Label], + stack :: Stack +} + +eval :: Store -> FunctionInstance -> [Value] -> IO [Value] +eval store FunctionInstance { funcType, moduleInstance, code = Function { localTypes, body} } args = do + let checkedArgs = zipWith checkArgType (params funcType) args + let initialContext = EvalCtx { + locals = Vector.fromList $ checkedArgs ++ map initLocal localTypes, + labels = [], + stack = [] + } + result <- Monad.foldM step initialContext body + return $ reverse $ stack result + where + checkArgType :: ValueType -> Value -> Value + checkArgType I32 (VI32 v) = VI32 v + checkArgType I64 (VI64 v) = VI64 v + checkArgType F32 (VF32 v) = VF32 v + checkArgType F64 (VF64 v) = VF64 v + checkArgType _ _ = error "Argument types do not match function type" + + initLocal :: ValueType -> Value + initLocal I32 = VI32 0 + initLocal I64 = VI64 0 + initLocal F32 = VF32 0 + initLocal F64 = VF64 0 + + step :: EvalCtx -> Instruction -> IO EvalCtx + step ctx (I32Const v) = return ctx { stack = VI32 v : stack ctx } + step ctx (I64Const v) = return ctx { stack = VI64 v : stack ctx } + step ctx (F32Const v) = return ctx { stack = VF32 v : stack ctx } + step ctx (F64Const v) = return ctx { stack = VF64 v : stack ctx } + step ctx (GetLocal i) = return ctx { stack = (locals ctx ! fromIntegral i) : stack ctx } + step ctx@EvalCtx{ stack = (v:rest) } (SetLocal i) = + return ctx { stack = rest, locals = locals ctx // [(fromIntegral i, v)] } + step ctx@EvalCtx{ locals = ls, stack = (v:rest) } (TeeLocal i) = + return ctx { + stack = (ls ! fromIntegral i) : rest, + locals = locals ctx // [(fromIntegral i, v)] + } + step ctx (GetGlobal i) = do + let globalInst = globalInstances store ! (globaladdrs moduleInstance ! fromIntegral i) + val <- case globalInst of + GIConst v -> return v + GIMut ref -> readIORef ref + return ctx { stack = val : stack ctx } + step ctx@EvalCtx{ stack = (v:rest) } (SetGlobal i) = do + let globalInst = globalInstances store ! (globaladdrs moduleInstance ! fromIntegral i) + case globalInst of + GIConst v -> error "Attempt of mutation of constant global" + GIMut ref -> writeIORef ref v + return ctx { stack = rest } + step _ _ = error "Error during evaluation" +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 diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 3c435f2..4f8e4cd 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -1514,7 +1514,7 @@ desugarize fields = let ctx = FunCtx mod [] locals params in S.Function { S.funcType = typeIdx, - S.locals = map localType locals, + S.localTypes = map localType locals, S.body = map (synInstrToStruct ctx) body } diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 324eb09..3e7727f 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -176,7 +176,7 @@ type Expression = [Instruction] data Function = Function { funcType :: TypeIndex, - locals :: LocalsType, + localTypes :: LocalsType, body :: Expression } deriving (Show, Eq) diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index a58b0e4..b737b8d 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -454,7 +454,7 @@ ctxFromModule locals labels returns m@Module {types, tables, mems, globals, impo getGlobalType _ = Nothing isFunctionValid :: Function -> Validator -isFunctionValid Function {funcType, locals, body} mod@Module {types} = +isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types} = let FuncType params results = types !! fromIntegral funcType in let r = safeHead results in let ctx = ctxFromModule (params ++ locals) [r] r mod in