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

implement table.get and table.set and pass ref_is_null test suit

Browse Source
This commit is contained in:
Ilya Rezvov
2022-06-04 16:32:20 -06:00
parent e388e21370
commit 6eb3acde17
6 changed files with 69 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+31 -4
View File
@@ -67,6 +67,8 @@ import Language.Wasm.FloatUtils (
doubleToWord
)
import Debug.Trace as Debug
data Value =
VI32 Word32
| VI64 Word64
@@ -169,7 +171,7 @@ type Address = Int
type TableStore = IOVector (Maybe Address)
data TableInstance = TableInstance {
lim :: Limit,
t :: TableType,
items :: TableStore
}
@@ -422,7 +424,7 @@ calcInstance (Store fs ts ms gs es ds) imps mod = do
tableAddr <- case idx of
ExternTable tableAddr -> return tableAddr
_ -> throwError "incompatible import type"
let TableInstance { lim } = ts ! tableAddr
let TableInstance { t = TableType lim _ } = ts ! tableAddr
if limitMatch lim limit
then return idx
else throwError "incompatible import type"
@@ -480,9 +482,9 @@ allocTables :: [Table] -> IO (Vector TableInstance)
allocTables = fmap Vector.fromList . mapM allocTable
where
allocTable :: Table -> IO TableInstance
allocTable (Table (TableType lim@(Limit from to) _)) =
allocTable (Table t@(TableType lim@(Limit from to) _)) =
let elements = MVector.replicate (fromIntegral from) Nothing in
TableInstance lim <$> elements
TableInstance t <$> elements
defaultBudget :: Natural
defaultBudget = 300
@@ -641,6 +643,8 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
checkValType I64 (VI64 v) = Just $ VI64 v
checkValType F32 (VF32 v) = Just $ VF32 v
checkValType F64 (VF64 v) = Just $ VF64 v
checkValType Func (RF v) = Just $ RF v
checkValType Extern (RE v) = Just $ RE v
checkValType _ _ = Nothing
initLocal :: ValueType -> Value
@@ -920,6 +924,29 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
Vector.iforM_ (Vector.slice src len refs) $ \idx (RF fn) ->
MVector.unsafeWrite items (dst + idx) (fromIntegral <$> fn)
return $ Done ctx { stack = rest }
step ctx@EvalCtx{ stack = (ref:VI32 offset:rest) } (TableSet tableIdx) = do
let tableAddr = tableaddrs moduleInstance ! fromIntegral tableIdx
let TableInstance { items } = tableInstances store ! tableAddr
let dst = fromIntegral offset
let val = case ref of
RE extRef -> extRef
RF fnRef -> fnRef
v -> error "Impossible due to validation"
if dst > MVector.length items
then return Trap
else do
MVector.unsafeWrite items dst (fromIntegral <$> val)
return $ Done ctx { stack = rest }
step ctx@EvalCtx{ stack = (VI32 offset:rest) } (TableGet tableIdx) = do
let tableAddr = tableaddrs moduleInstance ! fromIntegral tableIdx
let TableInstance { t = TableType _ et, items } = tableInstances store ! tableAddr
let dst = fromIntegral offset
if dst > MVector.length items
then return Trap
else do
v <- MVector.unsafeRead items dst
let val = (case et of {FuncRef -> RF; ExternRef -> RE}) (fromIntegral <$> v)
return $ Done ctx { stack = val : 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 }
src/Language/Wasm/Parser.y
+17 -1
View File
@@ -133,6 +133,7 @@ import Language.Wasm.Lexer (
'ref.null' { Lexeme _ (TKeyword "ref.null") }
'ref.is_null' { Lexeme _ (TKeyword "ref.is_null") }
'ref.func' { Lexeme _ (TKeyword "ref.func") }
'ref.extern' { Lexeme _ (TKeyword "ref.extern") }
'drop' { Lexeme _ (TKeyword "drop") }
'select' { Lexeme _ (TKeyword "select") }
'get_local' { Lexeme _ (TKeyword "local.get") }
@@ -438,6 +439,7 @@ plaininstr :: { PlainInstr }
| 'ref.null' heaptype { RefNull $2 }
| 'ref.is_null' { RefIsNull }
| 'ref.func' index { RefFunc $2 }
| 'ref.extern' u32 { RefExtern $2 }
-- variable instructions
| 'get_local' index { GetLocal $2 }
| 'set_local' index { SetLocal $2 }
@@ -471,11 +473,13 @@ plaininstr :: { PlainInstr }
| 'memory.size' { CurrentMemory }
| 'memory.grow' { GrowMemory }
-- table instructions
| 'table.init' index opt(index) {
| 'table.init' index opt(index) {
case $3 of
Nothing -> TableInit (Index 0) $2
Just elemIdx -> TableInit $2 elemIdx
}
| 'table.get' index { TableGet $2 }
| 'table.set' index { TableSet $2 }
-- numeric instructions
| 'i32.const' int32 { I32Const $2 }
| 'i64.const' int64 { I64Const $2 }
@@ -1184,6 +1188,7 @@ data PlainInstr =
| RefNull ElemType
| RefIsNull
| RefFunc FuncIndex
| RefExtern Natural
-- Parametric instructions
| Drop
| Select
@@ -1460,6 +1465,7 @@ 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 (PlainInstr (RefExtern n)) = S.RefExtern n
constInstructionToValue _ = error "Only const instructions supported as arguments for actions"
funcIndexToExpr :: [FuncIndex] -> [[Instruction]]
@@ -1653,6 +1659,8 @@ desugarize fields = do
case getFuncIndex ctxMod funIdx of
Just idx -> return $ S.RefFunc idx
Nothing -> Left "unknown function"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (RefExtern idx)) =
return $ S.RefExtern idx
synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) =
case getLocalIndex ctx localIdx of
Just idx -> return $ S.GetLocal idx
@@ -1705,6 +1713,14 @@ desugarize fields = do
Just elemIdx -> return $ S.TableInit tableIdx elemIdx
Nothing -> Left "unknown elem"
Nothing -> Left "unknown table"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableSet tableIdx)) =
case getTableIndex ctxMod tableIdx of
Just tableIdx -> return $ S.TableSet tableIdx
Nothing -> Left "unknown table"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableGet tableIdx)) =
case getTableIndex ctxMod tableIdx of
Just tableIdx -> return $ S.TableGet tableIdx
Nothing -> Left "unknown table"
synInstrToStruct _ (PlainInstr (I32Const val)) = return $ S.I32Const $ integerToWord32 val
synInstrToStruct _ (PlainInstr (I64Const val)) = return $ S.I64Const $ integerToWord64 val
synInstrToStruct _ (PlainInstr (F32Const val)) = return $ S.F32Const val
src/Language/Wasm/Script.hs
+2 -2
View File
@@ -124,7 +124,8 @@ runScript onAssertFail script = do
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"
asArg [Struct.RefExtern v] = Interpreter.RE (Just v)
asArg expr = error $ "Only const instructions supported as arguments for actions: " ++ show expr
runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
runAction st (Invoke ident name args) = do
@@ -176,7 +177,6 @@ runScript onAssertFail script = do
getFailureString (Validate.RefTypeMismatch _ _) = ["type mismatch"]
getFailureString Validate.ResultTypeDoesntMatch = ["type mismatch"]
getFailureString Validate.MoreThanOneMemory = ["multiple memories"]
getFailureString Validate.MoreThanOneTable = ["multiple tables"]
getFailureString (Validate.LocalIndexOutOfRange idx) = ["unknown local", "unknown local " <> TL.pack (show idx)]
getFailureString (Validate.MemoryIndexOutOfRange idx) = ["unknown memory", "unknown memory " <> TL.pack (show idx)]
getFailureString (Validate.TableIndexOutOfRange idx) = ["unknown table", "unknown table " <> TL.pack (show idx)]
src/Language/Wasm/Structure.hs
+1
View File
@@ -142,6 +142,7 @@ data Instruction index =
| RefNull ElemType
| RefIsNull
| RefFunc index
| RefExtern Natural
-- Parametric instructions
| Drop
| Select
src/Language/Wasm/Validate.hs
+17 -6
View File
@@ -32,7 +32,6 @@ data ValidationError =
| MemoryLimitExceeded
| AlignmentOverflow
| MoreThanOneMemory
| MoreThanOneTable
| FunctionIndexOutOfRange
| TableIndexOutOfRange Natural
| MemoryIndexOutOfRange Natural
@@ -200,6 +199,10 @@ getResultType (TypeIndex typeIdx) = do
Ctx { types } <- ask
maybeToEither TypeIndexOutOfRange $ results <$> types !? typeIdx
elemTypeToRefType :: ElemType -> ValueType
elemTypeToRefType FuncRef = Func
elemTypeToRefType ExternRef = Extern
getInstrType :: Instruction Natural -> Checker Arrow
getInstrType Unreachable = return $ Any ==> Any
getInstrType Nop = return $ empty ==> empty
@@ -265,7 +268,8 @@ getInstrType (RefNull elType) = do
let t = case elType of { FuncRef -> Func; ExternRef -> Extern }
return $ empty ==> Val t
getInstrType RefIsNull = do
return $ empty ==> Val I32
var <- freshVar
return $ var ==> Val I32
getInstrType (RefFunc funIdx) = do
Ctx { funcs } <- ask
if fromIntegral funIdx < length funcs
@@ -375,6 +379,16 @@ getInstrType (TableInit tableIdx elemIdx) = do
let elemType = elems !! fromIntegral elemIdx
when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
return $ [I32, I32, I32] ==> empty
getInstrType (TableGet tableIdx) = do
Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx
return $ I32 ==> (elemTypeToRefType tableType)
getInstrType (TableSet tableIdx) = do
Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx
return $ [I32, elemTypeToRefType tableType] ==> empty
getInstrType (I32Const _) = return $ empty ==> I32
getInstrType (I64Const _) = return $ empty ==> I64
getInstrType (F32Const _) = return $ empty ==> F32
@@ -533,10 +547,7 @@ tablesShouldBeValid :: Validator
tablesShouldBeValid Module { imports, tables } =
let tableImports = filter isTableImport imports in
let res = foldMap (\Import { desc = ImportTable t } -> isValidTableType t) tableImports in
let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in
if length tableImports + length tables <= 1
then res'
else Left MoreThanOneTable
foldl' (\r (Table t) -> r <> isValidTableType t) res tables
where
isValidTableType :: TableType -> ValidationResult
isValidTableType (TableType (Limit min max) _) =
tests/Test.hs
+1 -2
View File
@@ -17,8 +17,7 @@ import qualified Data.List as List
main :: IO ()
main = do
files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
-- let files = ["ref_null.wast", "ref_is_null.wast"]
let files = ["elem.wast"]
let files = ["ref_is_null.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do