From 6561ed0264c48512eaba39620d8bd54f6ceda2e5 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Thu, 15 Mar 2018 19:42:24 -0700 Subject: [PATCH] implement interpretation of control instruction --- src/Language/Wasm/Interpreter.hs | 112 ++++++++++++++++++++++++------- 1 file changed, 89 insertions(+), 23 deletions(-) diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 450da93..185c27e 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -29,7 +29,7 @@ data Value = | VF64 Double deriving (Eq, Show) -data Label = Label +data Label = Label ResultType deriving (Show, Eq) type Address = Int @@ -252,25 +252,37 @@ data EvalCtx = EvalCtx { locals :: Vector Value, labels :: [Label], stack :: Stack -} +} deriving (Show, Eq) + +data EvalResult = + Done EvalCtx + | Break Int [Value] EvalCtx + | Trap + | ReturnFn [Value] + deriving (Show, Eq) 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 checkedArgs = zipWith checkValType (params funcType) args let initialContext = EvalCtx { locals = Vector.fromList $ checkedArgs ++ map initLocal localTypes, - labels = [], + labels = [Label $ results funcType], stack = [] } - result <- Monad.foldM step initialContext body - return $ reverse $ stack result + res <- go initialContext body + case res of + Done ctx -> return $ reverse $ stack ctx + ReturnFn r -> return r + Break 0 r _ -> return $ reverse r + Break _ _ _ -> error "Break is out of range" + Trap -> error "Evaluation terminated with Trap" 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" + checkValType :: ValueType -> Value -> Value + checkValType I32 (VI32 v) = VI32 v + checkValType I64 (VI64 v) = VI64 v + checkValType F32 (VF32 v) = VF32 v + checkValType F64 (VF64 v) = VF64 v + checkValType _ _ = error "Value types do not match provided value" initLocal :: ValueType -> Value initLocal I32 = VI32 0 @@ -278,16 +290,66 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT 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 } + go :: EvalCtx -> [Instruction] -> IO EvalResult + go ctx [] = return $ Done ctx + go ctx (instr:rest) = do + res <- step ctx instr + case res of + Done ctx' -> go ctx' rest + command -> return command + + step :: EvalCtx -> Instruction -> IO EvalResult + step _ Unreachable = return Trap + step ctx Nop = return $ Done ctx + step ctx (Block resType expr) = do + 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 n r ctx' -> return $ Break (n - 1) r ctx' + command -> return command + step ctx loop@(Loop resType expr) = do + 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 n r ctx' -> return $ Break (n - 1) r ctx' + command -> return command + step ctx@EvalCtx{ stack = (VI32 v): rest } (If resType true false) = do + 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 ++ stack ctx } + Break n r ctx' -> return $ Break (n - 1) r ctx' + command -> return command + step ctx@EvalCtx{ stack, labels } (Br label) = do + let idx = fromIntegral label + 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 + then return $ Done ctx { stack = rest } + else step ctx { stack = rest } (Br label) + step ctx@EvalCtx{ stack = (VI32 v): rest } (BrTable labels label) = + let idx = fromIntegral v in + let lbl = fromIntegral $ if idx < length labels then labels !! idx else label in + step ctx { stack = rest } (Br lbl) + step EvalCtx{ stack } Return = + let resType = results funcType in + return $ ReturnFn $ reverse $ zipWith checkValType resType $ take (length resType) stack + step ctx (Call fun) = do + let funInst@FunctionInstance { funcType } = funcInstances store ! (funcaddrs moduleInstance ! fromIntegral fun) + let args = params funcType + res <- eval store funInst (zipWith checkValType args $ take (length args) $ stack ctx) + return $ Done ctx { stack = reverse res ++ (drop (length args) $ stack ctx) } + step ctx@EvalCtx{ stack = (_:rest) } Drop = return $ Done ctx { stack = rest } + step ctx@EvalCtx{ stack = (VI32 test:val2:val1:rest) } Select = + if test == 0 + then return $ Done ctx { stack = val1 : rest } + else return $ Done ctx { stack = val2 : rest } + step ctx (GetLocal i) = return $ Done 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)] } + return $ Done ctx { stack = rest, locals = locals ctx // [(fromIntegral i, v)] } step ctx@EvalCtx{ locals = ls, stack = (v:rest) } (TeeLocal i) = - return ctx { + return $ Done ctx { stack = (ls ! fromIntegral i) : rest, locals = locals ctx // [(fromIntegral i, v)] } @@ -296,14 +358,18 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT val <- case globalInst of GIConst v -> return v GIMut ref -> readIORef ref - return ctx { stack = val : stack ctx } + return $ Done 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" + return $ Done ctx { stack = rest } + step ctx (I32Const v) = return $ Done ctx { stack = VI32 v : stack ctx } + step ctx (I64Const v) = return $ Done ctx { stack = VI64 v : stack ctx } + step ctx (F32Const v) = return $ Done ctx { stack = VF32 v : stack ctx } + step ctx (F64Const v) = return $ Done ctx { stack = VF64 v : stack ctx } + step _ instr = error $ "Error during evaluation of instruction " ++ show instr eval store HostInstance { funcType, tag } args = return args invoke :: Store -> Address -> [Value] -> IO [Value]