msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

implement assert_trap assertion

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-21 08:59:31 -07:00
parent 3c882a97d1
commit 49719b64cd
2 changed files with 35 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+18 -12
View File
@@ -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
src/Language/Wasm/Script.hs
+17 -7
View File
@@ -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