diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 7f68ea9..42a2294 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -491,8 +491,10 @@ initialize inst Module {elems, datas, start} store = do case start of Just (StartFunction idx) -> do let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) - [] <- eval st funInst [] - return $ Right st + mainRes <- eval st funInst [] + case mainRes of + Just [] -> return $ Right st + _ -> return $ Left "Start function terminated with trap" Nothing -> return $ Right st Left reason -> return $ Left reason where @@ -584,7 +586,7 @@ data EvalResult = | ReturnFn [Value] deriving (Show, Eq) -eval :: Store -> FunctionInstance -> [Value] -> IO [Value] +eval :: Store -> FunctionInstance -> [Value] -> IO (Maybe [Value]) eval store FunctionInstance { funcType, moduleInstance, code = Function { localTypes, body} } args = do let checkedArgs = zipWith checkValType (params funcType) args let initialContext = EvalCtx { @@ -594,11 +596,11 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT } res <- go initialContext body case res of - Done ctx -> return $ reverse $ stack ctx - ReturnFn r -> return r - Break 0 r _ -> return $ reverse r + Done ctx -> return $ Just $ reverse $ stack ctx + ReturnFn r -> return $ Just r + Break 0 r _ -> return $ Just $ reverse r Break _ _ _ -> error "Break is out of range" - Trap -> error "Evaluation terminated with Trap" + Trap -> return Nothing where checkValType :: ValueType -> Value -> Value checkValType I32 (VI32 v) = VI32 v @@ -667,7 +669,9 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT let ft = Language.Wasm.Interpreter.funcType funInst let args = params ft res <- eval store funInst (zipWith checkValType args $ reverse $ take (length args) $ stack ctx) - return $ Done ctx { stack = reverse res ++ (drop (length args) $ stack ctx) } + case res of + Just res -> return $ Done ctx { stack = reverse res ++ (drop (length args) $ stack ctx) } + Nothing -> return Trap step ctx@EvalCtx{ stack = (VI32 v): rest } (CallIndirect typeIdx) = do let funcType = funcTypes moduleInstance ! fromIntegral typeIdx let TableInstance { elements } = tableInstances store ! (tableaddrs moduleInstance ! 0) @@ -676,7 +680,9 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT Just (Just addr) -> do let args = params funcType res <- invoke store addr (zipWith checkValType args $ reverse $ take (length args) rest) - return $ Done ctx { stack = reverse res ++ (drop (length args) rest) } + case res of + Just res -> return $ Done ctx { stack = reverse res ++ (drop (length args) rest) } + Nothing -> return Trap _ -> return Trap step ctx@EvalCtx{ stack = (_:rest) } Drop = return $ Done ctx { stack = rest } step ctx@EvalCtx{ stack = (VI32 test:val2:val1:rest) } Select = @@ -1175,12 +1181,12 @@ eval store FunctionInstance { funcType, moduleInstance, code = Function { localT step ctx@EvalCtx{ stack = (VI64 v:rest) } (FReinterpretI BS64) = return $ Done ctx { stack = VF64 (wordToDouble v) : rest } step EvalCtx{ stack } instr = error $ "Error during evaluation of instruction: " ++ show instr ++ ". Stack " ++ show stack -eval _ HostInstance { funcType, hostCode } args = hostCode args +eval _ HostInstance { funcType, hostCode } args = Just <$> hostCode args -invoke :: Store -> Address -> [Value] -> IO [Value] +invoke :: Store -> Address -> [Value] -> IO (Maybe [Value]) invoke st funcIdx = eval st $ funcInstances st ! funcIdx -invokeExport :: Store -> ModuleInstance -> TL.Text -> [Value] -> IO [Value] +invokeExport :: Store -> ModuleInstance -> TL.Text -> [Value] -> IO (Maybe [Value]) invokeExport st ModuleInstance { exports } name args = case Vector.find (\(ExportInstance n _) -> n == name) exports of Just (ExportInstance _ (ExternFunction addr)) -> invoke st addr args diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index a9fcf1c..ff6e2d5 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -10,6 +10,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLEncoding import Numeric.IEEE (identicalIEEE) import qualified Control.DeepSeq as DeepSeq +import Data.Maybe (fromJust, isNothing) import Language.Wasm.Parser ( Ident(..), @@ -112,14 +113,14 @@ runScript onAssertFail script = do asArg [Struct.F64Const v] = Interpreter.VF64 v asArg _ = error "Only const instructions supported as arguments for actions" - runAction :: ScriptState -> Action -> IO [Interpreter.Value] + runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value]) runAction st (Invoke ident name args) = do case getModule st ident of Just m -> Interpreter.invokeExport (store st) m name $ map asArg args Nothing -> error $ "Cannot invoke function on module with identifier '" ++ show ident ++ "'. No such module" runAction st (Get ident name) = do case getModule st ident of - Just m -> Interpreter.getGlobalValueByName (store st) m name >>= return . (: []) + Just m -> Interpreter.getGlobalValueByName (store st) m name >>= return . Just . (: []) Nothing -> error $ "Cannot invoke function on module with identifier '" ++ show ident ++ "'. No such module" isValueEqual :: Interpreter.Value -> Interpreter.Value -> Bool @@ -133,11 +134,11 @@ runScript onAssertFail script = do isNaNReturned st action assert = do result <- runAction st action case result of - [Interpreter.VF32 v] -> + Just [Interpreter.VF32 v] -> if isNaN v then return () else onAssertFail ("Expected NaN, but action returned " ++ show v) assert - [Interpreter.VF64 v] -> + Just [Interpreter.VF64 v] -> if isNaN v then return () else onAssertFail ("Expected NaN, but action returned " ++ show v) assert @@ -182,9 +183,12 @@ runScript onAssertFail script = do runAssert :: ScriptState -> Assertion -> IO () runAssert st assert@(AssertReturn action expected) = do result <- runAction st action - if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected)) - then return () - else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert + case result of + Just result -> do + if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected)) + then return () + else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert + Nothing -> onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert runAssert st assert@(AssertInvalid moduleDef failureString) = @@ -217,6 +221,12 @@ runScript onAssertFail script = do Left err -> return () Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason + runAssert st assert@(AssertTrap (Left action) failureString) = do + result <- runAction st action + if isNothing result + then return () + else onAssertFail ("Expected trap, but action returned " ++ show (fromJust result)) assert + -- runAssert st assert@(AssertTrap (Right moduleDef) failureString) = runAssert _ _ = return () runCommand :: ScriptState -> Command -> IO ScriptState