start multivalue proposal implementation for block instruction

src/Language/Wasm/Binary.hs

@@ -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

@@ -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 :: (Returnable res) => res -> GenFun res -> GenFun res
-block res body = do
+-- block res body = do
-    deep <- (+1) <$> ask
+--     deep <- (+1) <$> ask
-    appendExpr [Block (asResultValue res) (genExpr deep $ body)]
+--     appendExpr [Block (asResultValue res) (genExpr deep $ body)]
-    return returnableValue
+--     return returnableValue
 
 trap :: Proxy t -> GenFun (Proxy t)
 trap t = do

src/Language/Wasm/Interpreter.hs

@@ -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

@@ -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
+            if ident == $4 || isNothing $4
-            then Right $ BlockInstr ident $2 (concat $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) }
+    : typeuse1 list(instruction) ')' { \ident -> BlockInstr ident $1 (concat $2) }
-    | folded_instr1 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 }) =
+        extractTypeDefFromInstruction defs (BlockInstr { body, blockType }) =
-            extractTypeDefFromInstructions defs body
+            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} =
+        synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } BlockInstr {label, blockType, body} = do
-            let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
+            let ctx' = ctx { ctxLabels = label : ctxLabels ctx }
-            S.Block resultType <$> mapM (synInstrToStruct ctx') body
+            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

@@ -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

@@ -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
+getInstrType Block { blockType, body } = do
-    let blockType = empty ==> resultType
+    bt <- getBlockType blockType
+    resultType <- getResultType blockType
     t <- withLabel resultType $ getExpressionType body
-    if isArrowMatch t blockType
+    if isArrowMatch t bt
-    then return $ empty ==> resultType
+    then return bt
-    else throwError $ TypeMismatch t blockType
+    else throwError $ TypeMismatch t bt
 getInstrType Loop { resultType, body } = do
     let blockType = empty ==> resultType
     t <- withLabel [] $ getExpressionType body

tests/Test.hs

@@ -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