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

add elem.drop and extend call_indirect to accept table index

Browse Source
This commit is contained in:
Ilya Rezvov
2022-06-04 21:58:34 -06:00
parent 6eb3acde17
commit 82defff076
7 changed files with 74 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Binary.hs
+3 -3
View File
@@ -365,7 +365,7 @@ instance Serialize (Instruction Natural) where
put (BrTable labels label) = putWord8 0x0E >> putVec (map Index labels) >> putULEB128 label
put Return = putWord8 0x0F
put (Call funcIdx) = putWord8 0x10 >> putULEB128 funcIdx
put (CallIndirect typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putWord8 0x00
put (CallIndirect tableIdx typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putULEB128 tableIdx
-- Parametric instructions
put Drop = putWord8 0x1A
put Select = putWord8 0x1B
@@ -565,8 +565,8 @@ instance Serialize (Instruction Natural) where
0x10 -> Call <$> getULEB128 32
0x11 -> do
typeIdx <- getULEB128 32
byteGuard 0x00
return $ CallIndirect typeIdx
tableIdx <- getULEB128 32
return $ CallIndirect tableIdx typeIdx
-- Parametric instructions
0x1A -> return $ Drop
0x1B -> return $ Select
src/Language/Wasm/Builder.hs
+1 -1
View File
@@ -655,7 +655,7 @@ callIndirect :: (Producer index, OutType index ~ Proxy I32, Returnable res) => T
callIndirect (TypeDef idx) index args = do
sequence_ args
produce index
appendExpr [CallIndirect idx]
appendExpr [CallIndirect 0 idx]
return returnableValue
br :: Label t -> GenFun ()
src/Language/Wasm/Interpreter.hs
+16 -7
View File
@@ -510,10 +510,14 @@ allocElems :: ModuleInstance -> Store -> [ElemSegment] -> IO (Vector ElemInstanc
allocElems inst st = fmap Vector.fromList . mapM allocElem
where
allocElem :: ElemSegment -> IO ElemInstance
allocElem (ElemSegment t mode refs) =
ElemInstance mode t
<$> (Vector.fromList <$> mapM (evalConstExpr inst st) refs)
<*> newIORef False -- is dropped
allocElem (ElemSegment t mode refs) = do
indexes <- flip mapM refs $ \refExpr -> do
ref <- evalConstExpr inst st refExpr
return $ case ref of
RF v -> RF $ fromIntegral . (funcaddrs inst !) . fromIntegral <$> v
_ -> ref
ElemInstance mode t (Vector.fromList indexes)
<$> newIORef False -- is dropped
allocDatas :: ModuleInstance -> Store -> [DataSegment] -> Vector DataInstance
allocDatas _inst _st = Vector.fromList . map (const DataInstance)
@@ -765,14 +769,14 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
Just res -> return $ Done ctx { stack = reverse res ++ (drop (length args) $ stack ctx) }
Nothing -> return Trap
Nothing -> return Trap
step ctx@EvalCtx{ stack = (VI32 v): rest } (CallIndirect typeIdx) = do
step ctx@EvalCtx{ stack = (VI32 v): rest } (CallIndirect tableIdx typeIdx) = do
let funcType = funcTypes moduleInstance ! fromIntegral typeIdx
let TableInstance { items } = tableInstances store ! (tableaddrs moduleInstance ! 0)
let TableInstance { items } = tableInstances store ! (tableaddrs moduleInstance ! fromIntegral tableIdx)
let pos = fromIntegral v
if pos >= MVector.length items
then return Trap
else do
maybeAddr <- liftIO $ MVector.read items pos
maybeAddr <- MVector.unsafeRead items pos
let checks = do
addr <- maybeAddr
let funcInst = funcInstances store ! addr
@@ -947,6 +951,11 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
v <- MVector.unsafeRead items dst
let val = (case et of {FuncRef -> RF; ExternRef -> RE}) (fromIntegral <$> v)
return $ Done ctx { stack = val : rest }
step ctx (ElemDrop elemIdx) = do
let elemAddr = elemaddrs moduleInstance ! fromIntegral elemIdx
let ElemInstance {isDropped} = elemInstances store ! elemAddr
writeIORef isDropped True
return $ Done ctx
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
+32 -12
View File
@@ -173,6 +173,7 @@ import Language.Wasm.Lexer (
'table.grow' { Lexeme _ (TKeyword "table.grow") }
'table.get' { Lexeme _ (TKeyword "table.get") }
'table.set' { Lexeme _ (TKeyword "table.set") }
'elem.drop' { Lexeme _ (TKeyword "elem.drop") }
'i32.const' { Lexeme _ (TKeyword "i32.const") }
'i64.const' { Lexeme _ (TKeyword "i64.const") }
'f32.const' { Lexeme _ (TKeyword "f32.const") }
@@ -480,6 +481,8 @@ plaininstr :: { PlainInstr }
}
| 'table.get' index { TableGet $2 }
| 'table.set' index { TableSet $2 }
| 'table.copy' index index { TableCopy $2 $3 }
| 'elem.drop' index { ElemDrop $2 }
-- numeric instructions
| 'i32.const' int32 { I32Const $2 }
| 'i64.const' int64 { I64Const $2 }
@@ -690,9 +693,10 @@ memarg8 :: { MemArg }
instruction_list(terminator)
: terminator { ($1, []) }
| plaininstr mixed_instruction_list(terminator) { ([PlainInstr $1] ++) `fmap` $2 }
| 'call_indirect' typeuse(terminator) {%
let (tu, instr, end) = $2 in
onlyAnonimParams tu >> (return (end, [PlainInstr $ CallIndirect tu] ++ instr))
| 'call_indirect' opt(index) typeuse(terminator) {%
let tableIdx = fromMaybe (Index 0) $2 in
let (tu, instr, end) = $3 in
onlyAnonimParams tu >> (return (end, [PlainInstr $ CallIndirect tableIdx tu] ++ instr))
}
| 'block' opt(ident) typeuse('end') opt(ident) mixed_instruction_list(terminator) {% do
let (tu, instr, _) = $3
@@ -730,9 +734,10 @@ folded_instr :: { [Instruction] }
folded_instr1 :: { [Instruction] }
: plaininstr mixed_instruction_list(')') { snd $2 ++ [PlainInstr $1] }
| 'call_indirect' typeuse(')') {%
let (tu, instr, _) = $2 in
onlyAnonimParams tu >> (return $ instr ++ [PlainInstr $ CallIndirect tu])
| 'call_indirect' opt(index) typeuse(')') {%
let tableIdx = fromMaybe (Index 0) $2 in
let (tu, instr, _) = $3 in
onlyAnonimParams tu >> (return $ instr ++ [PlainInstr $ CallIndirect tableIdx tu])
}
| 'block' opt(ident) typeuse(')') {%
let (typeUse, instr, _) = $3 in
@@ -1183,7 +1188,7 @@ data PlainInstr =
| BrTable [LabelIndex] LabelIndex
| Return
| Call FuncIndex
| CallIndirect TypeUse
| CallIndirect TableIndex TypeUse
-- Reference instructions
| RefNull ElemType
| RefIsNull
@@ -1232,6 +1237,7 @@ data PlainInstr =
| TableGet TableIndex
| TableSet TableIndex
| TableCopy TableIndex TableIndex
| ElemDrop ElemIndex
-- Numeric instructions
| I32Const Integer
| I64Const Integer
@@ -1564,7 +1570,7 @@ desugarize fields = do
extractTypeDefFromInstructions = foldl' extractTypeDefFromInstruction
extractTypeDefFromInstruction :: [TypeDef] -> Instruction -> [TypeDef]
extractTypeDefFromInstruction defs (PlainInstr (CallIndirect typeUse)) =
extractTypeDefFromInstruction defs (PlainInstr (CallIndirect _ typeUse)) =
matchTypeUse defs typeUse
extractTypeDefFromInstruction defs (BlockInstr { body, blockType }) =
extractTypeDefFromInstructions (matchTypeUse defs blockType) body
@@ -1647,10 +1653,13 @@ desugarize fields = do
case getFuncIndex ctxMod funIdx of
Just idx -> return $ S.Call idx
Nothing -> Left "unknown function"
synInstrToStruct FunCtx { ctxMod = Module { types } } (PlainInstr (CallIndirect typeUse)) =
case getTypeIndex types typeUse of
Just idx -> return $ S.CallIndirect idx
Nothing -> Left "unknown type"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (CallIndirect tableIdx typeUse)) =
case getTableIndex ctxMod tableIdx of
Just tableIdx ->
case getTypeIndex (types ctxMod) typeUse of
Just idx -> return $ S.CallIndirect tableIdx idx
Nothing -> Left "unknown type"
Nothing -> Left "unknown table"
synInstrToStruct _ (PlainInstr Drop) = return $ S.Drop
synInstrToStruct _ (PlainInstr Select) = return $ S.Select
synInstrToStruct _ (PlainInstr (RefNull elType)) = return $ S.RefNull elType
@@ -1713,6 +1722,13 @@ desugarize fields = do
Just elemIdx -> return $ S.TableInit tableIdx elemIdx
Nothing -> Left "unknown elem"
Nothing -> Left "unknown table"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableCopy fromIdx toIdx)) =
case getTableIndex ctxMod fromIdx of
Just fromIdx ->
case getTableIndex ctxMod toIdx of
Just toIdx -> return $ S.TableCopy fromIdx toIdx
Nothing -> Left "unknown table"
Nothing -> Left "unknown table"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableSet tableIdx)) =
case getTableIndex ctxMod tableIdx of
Just tableIdx -> return $ S.TableSet tableIdx
@@ -1721,6 +1737,10 @@ desugarize fields = do
case getTableIndex ctxMod tableIdx of
Just tableIdx -> return $ S.TableGet tableIdx
Nothing -> Left "unknown table"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (ElemDrop elemIdx)) =
case getElemIndex ctxMod elemIdx of
Just elemIdx -> return $ S.ElemDrop elemIdx
Nothing -> Left "unknown elem"
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/Structure.hs
+2 -1
View File
@@ -137,7 +137,7 @@ data Instruction index =
| BrTable [index] index
| Return
| Call index
| CallIndirect index
| CallIndirect index index
-- Reference instructions
| RefNull ElemType
| RefIsNull
@@ -186,6 +186,7 @@ data Instruction index =
| TableGet TableIndex
| TableSet TableIndex
| TableCopy TableIndex TableIndex
| ElemDrop ElemIndex
-- Numeric instructions
| I32Const Word32
| I64Const Word64
src/Language/Wasm/Validate.hs
+16 -3
View File
@@ -251,10 +251,10 @@ getInstrType Return = do
getInstrType (Call fun) = do
Ctx { funcs } <- ask
maybeToEither FunctionIndexOutOfRange $ asArrow <$> funcs !? fun
getInstrType (CallIndirect sign) = do
getInstrType (CallIndirect tableIdx sign) = do
Ctx { types, tables } <- ask
if length tables < 1
then throwError (TableIndexOutOfRange 0)
if length tables <= fromIntegral tableIdx
then throwError (TableIndexOutOfRange tableIdx)
else do
Arrow from to <- maybeToEither TypeIndexOutOfRange $ asArrow <$> types !? sign
return $ (from ++ [Val I32]) ==> to
@@ -379,6 +379,15 @@ getInstrType (TableInit tableIdx elemIdx) = do
let elemType = elems !! fromIntegral elemIdx
when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
return $ [I32, I32, I32] ==> empty
getInstrType (TableCopy fromIdx toIdx) = do
Ctx { tables } <- ask
let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx)
when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx)
when (length tables <= to) $ throwError (TableIndexOutOfRange toIdx)
let TableType _ fromType = tables !! from
let TableType _ toType = tables !! to
when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType)
return $ [I32, I32, I32] ==> empty
getInstrType (TableGet tableIdx) = do
Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
@@ -389,6 +398,10 @@ getInstrType (TableSet tableIdx) = do
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx
return $ [I32, elemTypeToRefType tableType] ==> empty
getInstrType (ElemDrop elemIdx) = do
Ctx { elems } <- ask
when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
return $ empty ==> empty
getInstrType (I32Const _) = return $ empty ==> I32
getInstrType (I64Const _) = return $ empty ==> I64
getInstrType (F32Const _) = return $ empty ==> F32
tests/Test.hs
+4 -2
View File
@@ -16,8 +16,10 @@ import qualified Data.List as List
main :: IO ()
main = do
files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
let files = ["ref_is_null.wast"]
files <-
filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
<$> Directory.listDirectory "tests/spec"
let files = ["table_init.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do