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

syntax support for ref.ops and pass ref_null.wast

Browse Source
This commit is contained in:
Ilya Rezvov
2022-01-30 16:21:22 -07:00
parent 99532adb63
commit 960acac955
6 changed files with 67 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+16
View File
@@ -70,6 +70,8 @@ data Value =
| VI64 Word64
| VF32 Float
| VF64 Double
| RF (Maybe Natural)
| RE (Maybe Natural)
deriving (Eq, Show)
asInt32 :: Word32 -> Int32
@@ -187,6 +189,8 @@ getValueType (VI32 _) = I32
getValueType (VI64 _) = I64
getValueType (VF32 _) = F32
getValueType (VF64 _) = F64
getValueType (RF _) = Func
genValueType (RE _) = Extern
data ExportInstance = ExportInstance TL.Text ExternalValue deriving (Eq, Show)
@@ -422,6 +426,9 @@ evalConstExpr _ _ [I32Const v] = return $ VI32 v
evalConstExpr _ _ [I64Const v] = return $ VI64 v
evalConstExpr _ _ [F32Const v] = return $ VF32 v
evalConstExpr _ _ [F64Const v] = return $ VF64 v
evalConstExpr _ _ [RefNull FuncRef] = return $ RF Nothing
evalConstExpr _ _ [RefNull ExternRef] = return $ RE Nothing
evalConstExpr _ _ [RefFunc idx] = return $ RF $ Just idx
evalConstExpr inst store [GetGlobal i] = getGlobalValue inst store i
evalConstExpr _ _ instrs = error $ "Global initializer contains unsupported instructions: " ++ show instrs
@@ -718,6 +725,15 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
Just res -> return $ Done ctx { stack = reverse res ++ (drop (length params) rest) }
Nothing -> return Trap
Nothing -> return Trap
step ctx@EvalCtx{ stack = st } (RefNull FuncRef) =
return $ Done ctx { stack = RF Nothing : st }
step ctx@EvalCtx{ stack = st } (RefNull ExternRef) =
return $ Done ctx { stack = RE Nothing : st }
step ctx@EvalCtx{ stack = v:rest } RefIsNull =
let r = case v of { RE Nothing -> 1; RF Nothing -> 1; _ -> 0 } in
return $ Done ctx { stack = VI32 r : rest }
step ctx@EvalCtx{ stack = st } (RefFunc index) =
return $ Done ctx { stack = RF (Just index) : st }
step ctx@EvalCtx{ stack = (_:rest) } Drop = return $ Done ctx { stack = rest }
step ctx@EvalCtx{ stack = (VI32 test:val2:val1:rest) } Select =
if test == 0
src/Language/Wasm/Parser.y
+27
View File
@@ -119,6 +119,8 @@ import Language.Wasm.Lexer (
'f64' { Lexeme _ (TKeyword "f64") }
'mut' { Lexeme _ (TKeyword "mut") }
'funcref' { Lexeme _ (TKeyword "funcref") }
'externref' { Lexeme _ (TKeyword "externref") }
'extern' { Lexeme _ (TKeyword "extern") }
'type' { Lexeme _ (TKeyword "type") }
'unreachable' { Lexeme _ (TKeyword "unreachable") }
'nop' { Lexeme _ (TKeyword "nop") }
@@ -128,6 +130,9 @@ import Language.Wasm.Lexer (
'return' { Lexeme _ (TKeyword "return") }
'call' { Lexeme _ (TKeyword "call") }
'call_indirect' { Lexeme _ (TKeyword "call_indirect") }
'ref.null' { Lexeme _ (TKeyword "ref.null") }
'ref.is_null' { Lexeme _ (TKeyword "ref.is_null") }
'ref.func' { Lexeme _ (TKeyword "ref.func") }
'drop' { Lexeme _ (TKeyword "drop") }
'select' { Lexeme _ (TKeyword "select") }
'get_local' { Lexeme _ (TKeyword "local.get") }
@@ -363,6 +368,8 @@ valtype :: { ValueType }
| 'i64' { I64 }
| 'f32' { F32 }
| 'f64' { F64 }
| 'funcref' { Func }
| 'externref' { Extern }
index :: { Index }
: u32 { Index $1 }
@@ -418,6 +425,10 @@ plaininstr :: { PlainInstr }
| 'call' index { Call $2 }
| 'drop' { Drop }
| 'select' { Select }
-- reference instructions
| 'ref.null' heaptype { RefNull $2 }
| 'ref.is_null' { RefIsNull }
| 'ref.func' index { RefFunc $2 }
-- variable instructions
| 'get_local' index { GetLocal $2 }
| 'set_local' index { SetLocal $2 }
@@ -856,6 +867,11 @@ limits :: { Limit }
elemtype :: { ElemType }
: 'funcref' { FuncRef }
| 'externref' { ExternRef }
heaptype :: { ElemType }
: 'func' { FuncRef }
| 'extern' { ExternRef }
tabletype :: { TableType }
: limits elemtype { TableType $1 $2 }
@@ -1116,6 +1132,10 @@ data PlainInstr =
| Return
| Call FuncIndex
| CallIndirect TypeUse
-- Reference instructions
| RefNull ElemType
| RefIsNull
| RefFunc FuncIndex
-- Parametric instructions
| Drop
| Select
@@ -1376,6 +1396,7 @@ constInstructionToValue (PlainInstr (I32Const v)) = S.I32Const $ integerToWord32
constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v
constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v
constInstructionToValue (PlainInstr (F64Const v)) = S.F64Const v
constInstructionToValue (PlainInstr (RefNull et)) = S.RefNull et
constInstructionToValue _ = error "Only const instructions supported as arguments for actions"
desugarize :: [ModuleField] -> Either String S.Module
@@ -1562,6 +1583,12 @@ desugarize fields = do
Nothing -> Left "unknown type"
synInstrToStruct _ (PlainInstr Drop) = return $ S.Drop
synInstrToStruct _ (PlainInstr Select) = return $ S.Select
synInstrToStruct _ (PlainInstr (RefNull elType)) = return $ S.RefNull elType
synInstrToStruct _ (PlainInstr RefIsNull) = return $ S.RefIsNull
synInstrToStruct FunCtx { ctxMod } (PlainInstr (RefFunc funIdx)) =
case getFuncIndex ctxMod funIdx of
Just idx -> return $ S.RefFunc idx
Nothing -> Left "unknown function"
synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) =
case getLocalIndex ctx localIdx of
Just idx -> return $ S.GetLocal idx
src/Language/Wasm/Script.hs
+4
View File
@@ -122,6 +122,8 @@ runScript onAssertFail script = do
asArg [Struct.F32Const v] = Interpreter.VF32 v
asArg [Struct.I64Const v] = Interpreter.VI64 v
asArg [Struct.F64Const v] = Interpreter.VF64 v
asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing
asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing
asArg _ = error "Only const instructions supported as arguments for actions"
runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
@@ -139,6 +141,8 @@ runScript onAssertFail script = do
isValueEqual (Interpreter.VI64 v1) (Interpreter.VI64 v2) = v1 == v2
isValueEqual (Interpreter.VF32 v1) (Interpreter.VF32 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
isValueEqual (Interpreter.RF f1) (Interpreter.RF f2) = f1 == f2
isValueEqual (Interpreter.RE e1) (Interpreter.RE e2) = e1 == e2
isValueEqual _ _ = False
isNaNReturned :: Action -> Assertion -> AssertM ()
src/Language/Wasm/Structure.hs
+7 -1
View File
@@ -108,6 +108,8 @@ data ValueType =
| I64
| F32
| F64
| Func
| Extern
deriving (Show, Eq, Generic, NFData)
type ResultType = [ValueType]
@@ -134,6 +136,10 @@ data Instruction index =
| Return
| Call index
| CallIndirect index
-- Reference instructions
| RefNull ElemType
| RefIsNull
| RefFunc index
-- Parametric instructions
| Drop
| Select
@@ -207,7 +213,7 @@ data Function = Function {
data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq, Generic, NFData)
data ElemType = FuncRef deriving (Show, Eq, Generic, NFData)
data ElemType = FuncRef | ExternRef deriving (Show, Eq, Generic, NFData)
data TableType = TableType Limit ElemType deriving (Show, Eq, Generic, NFData)
src/Language/Wasm/Validate.hs
+12
View File
@@ -258,6 +258,16 @@ getInstrType Drop = do
getInstrType Select = do
var <- freshVar
return $ [var, var, Val I32] ==> var
getInstrType (RefNull elType) = do
let t = case elType of { FuncRef -> Func; ExternRef -> Extern }
return $ empty ==> Val t
getInstrType RefIsNull = do
return $ empty ==> Val I32
getInstrType (RefFunc funIdx) = do
Ctx { funcs } <- ask
if fromIntegral funIdx < length funcs
then return $ empty ==> Val I32
else throwError FunctionIndexOutOfRange
getInstrType (GetLocal local) = do
Ctx { locals } <- ask
t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
@@ -445,6 +455,8 @@ isConstExpression ((I32Const _):rest) = isConstExpression rest
isConstExpression ((I64Const _):rest) = isConstExpression rest
isConstExpression ((F32Const _):rest) = isConstExpression rest
isConstExpression ((F64Const _):rest) = isConstExpression rest
isConstExpression ((RefNull _):rest) = isConstExpression rest
isConstExpression ((RefFunc _):rest) = isConstExpression rest
isConstExpression ((GetGlobal idx):rest) = do
Ctx {globals, importedGlobals} <- ask
if importedGlobals <= idx
tests/Test.hs
+1 -1
View File
@@ -17,7 +17,7 @@ import qualified Data.List as List
main :: IO ()
main = do
files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
-- let files = ["const.wast"]
let files = ["ref_null.wast", "ref_is_null.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do