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

start multivalue proposal implementation for block instruction

Browse Source
This commit is contained in:
Ilya Rezvov
2021-03-15 22:59:10 -07:00
parent 511bae84e8
commit b1874dfcea
7 changed files with 92 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Binary.hs
+26 -3
View File
@@ -167,6 +167,29 @@ getResultType = do
0x7C -> return [F64]
_ -> fail "unexpected byte in result type position"
putBlockType :: BlockType -> Put
putBlockType (Inline Nothing) = putWord8 0x40
putBlockType (Inline (Just valType)) = put valType
putBlockType (TypeIndex idx) = putSLEB128 idx
getInlineBlockType :: Get (Maybe (Maybe ValueType))
getInlineBlockType = do
op <- getWord8
case op of
0x40 -> return $ Just Nothing
0x7F -> return $ Just (Just I32)
0x7E -> return $ Just (Just I64)
0x7D -> return $ Just (Just F32)
0x7C -> return $ Just (Just F64)
_ -> return Nothing
getBlockType :: Get BlockType
getBlockType = do
inlineType <- lookAheadM getInlineBlockType
case inlineType of
Just inline -> return $ Inline inline
Nothing -> TypeIndex <$> getSLEB128 33
data SectionType =
CustomSection
| TypeSection
@@ -304,9 +327,9 @@ instance Serialize MemArg where
instance Serialize (Instruction Natural) where
put Unreachable = putWord8 0x00
put Nop = putWord8 0x01
put (Block result body) = do
put (Block blockType body) = do
putWord8 0x02
putResultType result
putBlockType blockType
putExpression body
put (Loop result body) = do
putWord8 0x03
@@ -504,7 +527,7 @@ instance Serialize (Instruction Natural) where
case op of
0x00 -> return Unreachable
0x01 -> return Nop
0x02 -> Block <$> getResultType <*> getExpression
0x02 -> Block <$> getBlockType <*> getExpression
0x03 -> Loop <$> getResultType <*> getExpression
0x04 -> do
resultType <- getResultType
src/Language/Wasm/Builder.hs
+6 -6
View File
@@ -41,7 +41,7 @@ module Language.Wasm.Builder (
memorySize, growMemory,
nop, Language.Wasm.Builder.drop, select,
call, callIndirect, finish, br, brIf, brTable,
if', loop, block, when, for, while,
if', loop, {-block,-} when, for, while,
trap, unreachable,
appendExpr, after,
Producer, OutType, produce, Consumer, (.=)
@@ -727,11 +727,11 @@ loop res body = do
appendExpr [Loop (asResultValue res) (genExpr deep $ body)]
return returnableValue
block :: (Returnable res) => res -> GenFun res -> GenFun res
block res body = do
deep <- (+1) <$> ask
appendExpr [Block (asResultValue res) (genExpr deep $ body)]
return returnableValue
-- block :: (Returnable res) => res -> GenFun res -> GenFun res
-- block res body = do
-- deep <- (+1) <$> ask
-- appendExpr [Block (asResultValue res) (genExpr deep $ body)]
-- return returnableValue
trap :: Proxy t -> GenFun (Proxy t)
trap t = do
src/Language/Wasm/Interpreter.hs
+5 -1
View File
@@ -635,7 +635,11 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
step :: EvalCtx -> Instruction Natural -> IO EvalResult
step _ Unreachable = return Trap
step ctx Nop = return $ Done ctx
step ctx (Block resType expr) = do
step ctx (Block blockType expr) = do
let resType = case blockType of
Inline Nothing -> []
Inline (Just valType) -> [valType]
TypeIndex typeIdx -> results $ funcTypes moduleInstance ! fromIntegral typeIdx
res <- go ctx { labels = Label resType : labels ctx } expr
case res of
Break 0 r EvalCtx{ locals = ls } -> return $ Done ctx { locals = ls, stack = r ++ stack ctx }
src/Language/Wasm/Parser.y
+27 -19
View File
@@ -576,7 +576,7 @@ plaininstr :: { PlainInstr }
typeuse :: { TypeUse }
: '(' typeuse1 { $2 }
| {- empty -} { AnonimousTypeUse $ FuncType [] [] }
| {- empty -} { emptyTypeUse }
typeuse1 :: { TypeUse }
: 'type' index ')' typedtypeuse { IndexedTypeUse $2 $4 }
@@ -644,28 +644,28 @@ raw_block :: { Maybe Ident -> Either String Instruction }
: 'end' opt(ident) {
\ident ->
if ident == $2 || isNothing $2
then Right $ BlockInstr ident [] []
then Right $ BlockInstr ident emptyTypeUse []
else Left "Block labels have to match"
}
| raw_instr list(instruction) 'end' opt(ident) {
\ident ->
if ident == $4 || isNothing $4
then Right $ BlockInstr ident [] ($1 ++ concat $2)
then Right $ BlockInstr ident emptyTypeUse ($1 ++ concat $2)
else Left "Block labels have to match"
}
| '(' raw_block1 { $2 }
raw_block1 :: { Maybe Ident -> Either String Instruction }
: 'result' list(valtype) ')' list(instruction) 'end' opt(ident) {
: typeuse1 list(instruction) 'end' opt(ident) {
\ident ->
if ident == $6 || isNothing $6
then Right $ BlockInstr ident $2 (concat $4)
if ident == $4 || isNothing $4
then Right $ BlockInstr ident $1 (concat $2)
else Left "Block labels have to match"
}
| folded_instr1 list(instruction) 'end' opt(ident) {
\ident ->
if ident == $4 || isNothing $4
then Right $ BlockInstr ident [] ($1 ++ concat $2)
then Right $ BlockInstr ident emptyTypeUse ($1 ++ concat $2)
else Left "Block labels have to match"
}
@@ -737,7 +737,7 @@ raw_else :: { ([Instruction], Maybe Ident) }
raw_call_indirect :: { [Instruction] }
: '(' raw_call_indirect_typeuse { (PlainInstr $ CallIndirect $ fst $2) : snd $2 }
| {- empty -} { [PlainInstr $ CallIndirect $ AnonimousTypeUse $ FuncType [] []] }
| {- empty -} { [PlainInstr $ CallIndirect emptyTypeUse] }
raw_call_indirect_typeuse :: { (TypeUse, [Instruction]) }
: 'type' index ')' raw_call_indirect_functype {
@@ -780,13 +780,13 @@ folded_instr1 :: { [Instruction] }
| 'if' opt(ident) '(' folded_if_result { $4 $2 }
folded_block :: { Maybe Ident -> Instruction }
: ')' { \ident -> BlockInstr ident [] [] }
: ')' { \ident -> BlockInstr ident emptyTypeUse [] }
| '(' folded_block1 { $2 }
| raw_instr list(instruction) ')' { \ident -> BlockInstr ident [] ($1 ++ concat $2) }
| raw_instr list(instruction) ')' { \ident -> BlockInstr ident emptyTypeUse ($1 ++ concat $2) }
folded_block1 :: { Maybe Ident -> Instruction }
: 'result' list(valtype) ')' list(instruction) ')' { \ident -> BlockInstr ident $2 (concat $4) }
| folded_instr1 list(instruction) ')' { \ident -> BlockInstr ident [] ($1 ++ concat $2) }
: typeuse1 list(instruction) ')' { \ident -> BlockInstr ident $1 (concat $2) }
| folded_instr1 list(instruction) ')' { \ident -> BlockInstr ident emptyTypeUse ($1 ++ concat $2) }
folded_loop :: { Maybe Ident -> Instruction }
: ')' { \ident -> LoopInstr ident [] [] }
@@ -821,7 +821,7 @@ folded_else :: { [Instruction] }
| '(' 'else' list(instruction) ')' ')' { concat $3 }
folded_call_indirect :: { [Instruction] }
: ')' { [PlainInstr $ CallIndirect $ AnonimousTypeUse $ FuncType [] []] }
: ')' { [PlainInstr $ CallIndirect emptyTypeUse] }
| '(' folded_call_indirect_typeuse { snd $2 ++ [PlainInstr $ CallIndirect $ fst $2] }
folded_call_indirect_typeuse :: { (TypeUse, [Instruction]) }
@@ -1308,11 +1308,13 @@ data TypeUse =
| AnonimousTypeUse FuncType
deriving (Show, Eq, Generic, NFData)
emptyTypeUse = AnonimousTypeUse emptyFuncType
data Instruction =
PlainInstr PlainInstr
| BlockInstr {
label :: Maybe Ident,
resultType :: [ValueType],
blockType :: TypeUse,
body :: [Instruction]
}
| LoopInstr {
@@ -1593,8 +1595,8 @@ desugarize fields = do
extractTypeDefFromInstruction :: [TypeDef] -> Instruction -> [TypeDef]
extractTypeDefFromInstruction defs (PlainInstr (CallIndirect typeUse)) =
matchTypeUse defs typeUse
extractTypeDefFromInstruction defs (BlockInstr { body }) =
extractTypeDefFromInstructions defs body
extractTypeDefFromInstruction defs (BlockInstr { body, blockType }) =
extractTypeDefFromInstructions (matchTypeUse defs blockType) body
extractTypeDefFromInstruction defs (LoopInstr { body }) =
extractTypeDefFromInstructions defs body
extractTypeDefFromInstruction defs (IfInstr { trueBranch, falseBranch }) =
@@ -1742,9 +1744,15 @@ desugarize fields = do
synInstrToStruct _ (PlainInstr F64PromoteF32) = return $ S.F64PromoteF32
synInstrToStruct _ (PlainInstr (IReinterpretF sz)) = return $ S.IReinterpretF sz
synInstrToStruct _ (PlainInstr (FReinterpretI sz)) = return $ S.FReinterpretI sz
synInstrToStruct ctx BlockInstr {label, resultType, body} =
let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
S.Block resultType <$> mapM (synInstrToStruct ctx') body
synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } BlockInstr {label, blockType, body} = do
let ctx' = ctx { ctxLabels = label : ctxLabels ctx }
bt <- case blockType of
AnonimousTypeUse (FuncType [] []) -> return $ S.Inline Nothing
AnonimousTypeUse (FuncType [] [vt]) -> return $ S.Inline (Just vt)
typed -> case getTypeIndex types typed of
Just idx -> return $ S.TypeIndex idx
Nothing -> Left "unknown type"
S.Block bt <$> mapM (synInstrToStruct ctx') body
synInstrToStruct ctx LoopInstr {label, resultType, body} =
let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
S.Loop resultType <$> mapM (synInstrToStruct ctx') body
src/Language/Wasm/Structure.hs
+7 -1
View File
@@ -30,6 +30,7 @@ module Language.Wasm.Structure (
GlobalType(..),
FuncType(..),
ValueType(..),
BlockType(..),
ParamsType,
ResultType,
LocalsType,
@@ -115,11 +116,16 @@ type LocalsType = [ValueType]
data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq, Generic, NFData)
data BlockType =
Inline (Maybe ValueType)
| TypeIndex TypeIndex
deriving (Show, Eq, Generic, NFData)
data Instruction index =
-- Control instructions
Unreachable
| Nop
| Block { resultType :: ResultType, body :: Expression }
| Block { blockType :: BlockType, body :: Expression }
| Loop { resultType :: ResultType, body :: Expression }
| If { resultType :: ResultType, true :: Expression, false :: Expression }
| Br index
src/Language/Wasm/Validate.hs
+20 -5
View File
@@ -183,15 +183,30 @@ checkMemoryInstr size memarg = do
Ctx { mems } <- ask
if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return ()
getBlockType :: BlockType -> Checker Arrow
getBlockType (Inline Nothing) = return $ empty ==> empty
getBlockType (Inline (Just valType)) = return $ empty ==> valType
getBlockType (TypeIndex typeIdx) = do
Ctx { types } <- ask
maybeToEither TypeIndexOutOfRange $ asArrow <$> types !? typeIdx
getResultType :: BlockType -> Checker [ValueType]
getResultType (Inline Nothing) = return []
getResultType (Inline (Just valType)) = return [valType]
getResultType (TypeIndex typeIdx) = do
Ctx { types } <- ask
maybeToEither TypeIndexOutOfRange $ results <$> types !? typeIdx
getInstrType :: Instruction Natural -> Checker Arrow
getInstrType Unreachable = return $ Any ==> Any
getInstrType Nop = return $ empty ==> empty
getInstrType Block { resultType, body } = do
let blockType = empty ==> resultType
getInstrType Block { blockType, body } = do
bt <- getBlockType blockType
resultType <- getResultType blockType
t <- withLabel resultType $ getExpressionType body
if isArrowMatch t blockType
then return $ empty ==> resultType
else throwError $ TypeMismatch t blockType
if isArrowMatch t bt
then return bt
else throwError $ TypeMismatch t bt
getInstrType Loop { resultType, body } = do
let blockType = empty ==> resultType
t <- withLabel [] $ getExpressionType body
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 = ["start.wast"]
let files = ["block.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do