type signature parsing for loop and if blocks

src/Language/Wasm/Binary.hs

@@ -331,17 +331,17 @@ instance Serialize (Instruction Natural) where
         putWord8 0x02
         putBlockType blockType
         putExpression body
-    put (Loop result body) = do
+    put (Loop blockType body) = do
         putWord8 0x03
-        putResultType result
+        putBlockType blockType
         putExpression body
-    put If {resultType, true, false = []} = do
+    put If {blockType, true, false = []} = do
         putWord8 0x04
-        putResultType resultType
+        putBlockType blockType
         putExpression true
-    put If {resultType, true, false} = do
+    put If {blockType, true, false} = do
         putWord8 0x04
-        putResultType resultType
+        putBlockType blockType
         mapM_ put true
         putWord8 0x05 -- ELSE
         putExpression false
@@ -528,12 +528,12 @@ instance Serialize (Instruction Natural) where
             0x00 -> return Unreachable
             0x01 -> return Nop
             0x02 -> Block <$> getBlockType <*> getExpression
-            0x03 -> Loop <$> getResultType <*> getExpression
+            0x03 -> Loop <$> getBlockType <*> getExpression
             0x04 -> do
-                resultType <- getResultType
+                blockType <- getBlockType
                 (true, hasElse) <- getTrueBranch
                 false <- if hasElse then getExpression else return []
-                return $ If resultType true false
+                return $ If blockType true false
             0x0C -> Br <$> getULEB128 32
             0x0D -> BrIf <$> getULEB128 32
             0x0E -> BrTable <$> (map unIndex <$> getVec) <*> getULEB128 32

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, (.=)
@@ -681,7 +681,7 @@ finish val = do
     appendExpr [Return]
 
 newtype Label i = Label Natural deriving (Show, Eq)
-
+{-
 when :: (Producer pred, OutType pred ~ Proxy I32)
     => pred
     -> GenFun ()
@@ -704,28 +704,28 @@ while pred body = do
             body
             loopLabel <- label
             if' () pred (br loopLabel) (return ())
-    if' () pred (loop () loopBody) (return ())
+    if' () pred (loop () loopBody) (return ())-}
 
 label :: GenFun (Label t)
 label = Label <$> ask
 
-if' :: (Producer pred, OutType pred ~ Proxy I32, Returnable res)
+-- if' :: (Producer pred, OutType pred ~ Proxy I32, Returnable res)
-    => res
+--     => res
-    -> pred
+--     -> pred
-    -> GenFun res
+--     -> GenFun res
-    -> GenFun res
+--     -> GenFun res
-    -> GenFun res
+--     -> GenFun res
-if' res pred true false = do
+-- if' res pred true false = do
-    produce pred
+--     produce pred
-    deep <- (+1) <$> ask
+--     deep <- (+1) <$> ask
-    appendExpr [If (asResultValue res) (genExpr deep $ true) (genExpr deep $ false)]
+--     appendExpr [If (asResultValue res) (genExpr deep $ true) (genExpr deep $ false)]
-    return returnableValue
+--     return returnableValue
 
-loop :: (Returnable res) => res -> GenFun res -> GenFun res
+-- loop :: (Returnable res) => res -> GenFun res -> GenFun res
-loop res body = do
+-- loop res body = do
-    deep <- (+1) <$> ask
+--     deep <- (+1) <$> ask
-    appendExpr [Loop (asResultValue res) (genExpr deep $ body)]
+--     appendExpr [Loop (asResultValue res) (genExpr deep $ body)]
-    return returnableValue
+--     return returnableValue
 
 -- block :: (Returnable res) => res -> GenFun res -> GenFun res
 -- block res body = do
@@ -988,39 +988,39 @@ asWord64 i
     | i >= 0 = fromIntegral i
     | otherwise = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1
 
-rts :: Module
+-- rts :: Module
-rts = genMod $ do
+-- rts = genMod $ do
-    gc <- importFunction "rts" "gc" () [I32]
+--     gc <- importFunction "rts" "gc" () [I32]
-    memory 10 Nothing
+--     memory 10 Nothing
 
-    stackStart <- global Const i32 0
+--     stackStart <- global Const i32 0
-    stackEnd <- global Const i32 0
+--     stackEnd <- global Const i32 0
-    stackBase <- global Mut i32 0
+--     stackBase <- global Mut i32 0
-    stackTop <- global Mut i32 0
+--     stackTop <- global Mut i32 0
 
-    retReg <- global Mut i32 0
+--     retReg <- global Mut i32 0
-    tmpReg <- global Mut i32 0
+--     tmpReg <- global Mut i32 0
 
-    heapStart <- global Mut i32 0
+--     heapStart <- global Mut i32 0
-    heapNext <- global Mut i32 0
+--     heapNext <- global Mut i32 0
-    heapEnd <- global Mut i32 0
+--     heapEnd <- global Mut i32 0
 
-    aligned <- fun i32 $ do
+--     aligned <- fun i32 $ do
-        size <- param i32
+--         size <- param i32
-        (size `add` i32c 3) `and` i32c 0xFFFFFFFC
+--         (size `add` i32c 3) `and` i32c 0xFFFFFFFC
-    alloc <- funRec i32 $ \self -> do
+--     alloc <- funRec i32 $ \self -> do
-        size <- param i32
+--         size <- param i32
-        alignedSize <- local i32
+--         alignedSize <- local i32
-        addr <- local i32
+--         addr <- local i32
-        alignedSize .= call aligned [arg size]
+--         alignedSize .= call aligned [arg size]
-        if' i32 ((heapNext `add` alignedSize) `lt_u` heapEnd)
+--         if' i32 ((heapNext `add` alignedSize) `lt_u` heapEnd)
-            (do
+--             (do
-                addr .= heapNext
+--                 addr .= heapNext
-                heapNext .= heapNext `add` alignedSize
+--                 heapNext .= heapNext `add` alignedSize
-                ret addr
+--                 ret addr
-            )
+--             )
-            (do
+--             (do
-                call gc []
+--                 call gc []
-                call self [arg size]
+--                 call self [arg size]
-            )
+--             )
-    return ()
+--     return ()

src/Language/Wasm/Interpreter.hs

@@ -646,14 +646,22 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
                 Break n r ctx' -> return $ Break (n - 1) r ctx'
                 Done ctx'@EvalCtx{ labels = (_:rest) } -> return $ Done ctx' { labels = rest }
                 command -> return command
-        step ctx loop@(Loop resType expr) = do
+        step ctx loop@(Loop 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 } -> step ctx { locals = ls, stack = r ++ stack ctx } loop
                 Break n r ctx' -> return $ Break (n - 1) r ctx'
                 Done ctx'@EvalCtx{ labels = (_:rest) } -> return $ Done ctx' { labels = rest }
                 command -> return command
-        step ctx@EvalCtx{ stack = (VI32 v): rest } (If resType true false) = do
+        step ctx@EvalCtx{ stack = (VI32 v): rest } (If blockType true false) = do
+            let resType = case blockType of
+                    Inline Nothing -> []
+                    Inline (Just valType) -> [valType]
+                    TypeIndex typeIdx -> results $ funcTypes moduleInstance ! fromIntegral typeIdx
             let expr = if v /= 0 then true else false
             res <- go ctx { labels = Label resType : labels ctx, stack = rest } expr
             case res of

src/Language/Wasm/Parser.y

@@ -660,68 +660,32 @@ raw_instr :: { [Instruction] }
         then Right $ [BlockInstr $2 tu (instr ++ instr')]
         else Left "Block labels have to match"
     }
-    | 'loop' opt(ident) raw_loop {% (: []) `fmap` $3 $2 }
+    | 'loop' opt(ident) typeuse_cont(pair(folded_instr1_list, block_end), block_end) {%
-    | 'if' opt(ident) raw_if_result {% $3 $2 }
+        let (tu, rest) = $3 in
-
+        let (instr, (instr', identAfter)) = either (\a -> ([], a)) id rest in
-raw_loop :: { Maybe Ident -> Either String Instruction }
+        if $2 == identAfter || isNothing identAfter
-    : 'end' opt(ident) {
+        then Right $ [LoopInstr $2 tu (instr ++ instr')]
-        \ident ->
+        else Left "Block labels have to match"
-            if ident == $2 || isNothing $2
-            then Right $ LoopInstr ident [] []
-            else Left "Loop labels have to match"
     }
-    | raw_instr list(instruction) 'end' opt(ident) {
+    | 'if' opt(ident) typeuse_cont(pair(folded_instr1_list, raw_if_end), raw_if_end) {%
-        \ident ->
+        let (tu, rest) = $3 in
-            if ident == $4 || isNothing $4
+        let (trueBranch, falseBranch, identAfter) = either id (\(t, (t', f, i)) -> (t ++ t', f, i)) rest in
-            then Right $ LoopInstr ident [] ($1 ++ concat $2)
+        if $2 == identAfter || isNothing identAfter
-            else Left "Loop labels have to match"
+        then Right $ [IfInstr $2 tu trueBranch falseBranch]
-    }
+        else Left "If labels have to match"
-    | '(' raw_loop1 { $2 }
-
-raw_loop1 :: { Maybe Ident -> Either String Instruction }
-    : 'result' list(valtype) ')' list(instruction) 'end' opt(ident) {
-        \ident ->
-            if ident == $6 || isNothing $6
-            then Right $ LoopInstr ident $2 (concat $4)
-            else Left "Loop labels have to match"
-    }
-    | folded_instr1 list(instruction) 'end' opt(ident) {
-        \ident ->
-            if ident == $4 || isNothing $4
-            then Right $ LoopInstr ident [] ($1 ++ concat $2)
-            else Left "Loop labels have to match"
     }
 
-raw_if_result :: { Maybe Ident -> Either String [Instruction] }
+raw_if_end
-    : raw_else {
+    : raw_if_else {
-        \ident ->
+        let (falseBranch, ident) = $1 in
-            if ident == (snd $1) || isNothing (snd $1)
+        ([], falseBranch, ident)
-            then Right [IfInstr ident [] [] $ fst $1]
-            else Left "If labels have to match"
     }
-    | raw_instr list(instruction) raw_else {
+    | raw_instr list(instruction) raw_if_else {
-        \ident ->
+        let (falseBranch, ident) = $3 in
-            if ident == (snd $3) || isNothing (snd $3)
+        ($1 ++ concat $2, falseBranch, ident)
-            then Right [IfInstr ident [] ($1 ++ concat $2) $ fst $3]
-            else Left "If labels have to match"
-    }
-    | '(' raw_if_result1 { $2 }
-
-raw_if_result1 :: { Maybe Ident -> Either String [Instruction] }
-    : 'result' list(valtype) ')' list(instruction) raw_else {
-        \ident ->
-            if ident == (snd $5) || isNothing (snd $5)
-            then Right [IfInstr ident $2 (concat $4) $ fst $5]
-            else Left "If labels have to match"
-    }
-    | folded_instr1 list(instruction) raw_else {
-        \ident ->
-            if ident == (snd $3) || isNothing (snd $3)
-            then Right [IfInstr ident [] ($1 ++ concat $2) $ fst $3]
-            else Left "If labels have to match"
     }
 
-raw_else :: { ([Instruction], Maybe Ident) }
+raw_if_else :: { ([Instruction], Maybe Ident) }
     : 'end' opt(ident) { ([], $2) }
     | 'else' opt(ident) list(instruction) 'end' opt(ident) {%
         if matchIdents $2 $5
@@ -748,28 +712,14 @@ folded_instr1 :: { [Instruction] }
         let (instr, instr') = either (\a -> ([], a)) id rest in
         [BlockInstr $2 typeUse (instr ++ instr')]
     }
-    | 'loop' opt(ident) folded_loop { [$3 $2] }
+    | 'loop' opt(ident) typeuse_cont(pair(folded_instr1_list, instr_list_closed), instr_list_closed) {
-    | 'if' opt(ident) '(' folded_if_result { $4 $2 }
+        let (typeUse, rest) = $3 in
-
+        let (instr, instr') = either (\a -> ([], a)) id rest in
-folded_loop :: { Maybe Ident -> Instruction }
+        [LoopInstr $2 typeUse (instr ++ instr')]
-    : ')' { \ident -> LoopInstr ident [] [] }
-    | '(' folded_loop1 { $2 }
-    | raw_instr list(instruction) ')' { \ident -> LoopInstr ident [] ($1 ++ concat $2) }
-
-folded_loop1 :: { Maybe Ident -> Instruction }
-    : 'result' list(valtype) ')' list(instruction) ')' { \ident -> LoopInstr ident $2 (concat $4) }
-    | folded_instr1 list(instruction) ')' { \ident -> LoopInstr ident [] ($1 ++ concat $2) }
-
-folded_if_result :: { Maybe Ident -> [Instruction] }
-    : 'result' list(valtype) ')' '(' folded_then_else {
-        \ident ->
-            let (pred, (trueBranch, falseBranch)) = $5 in
-            pred ++ [IfInstr ident $2 trueBranch falseBranch]
     }
-    | folded_then_else {
+    | 'if' opt(ident) '(' typeuse1_cont(folded_then_else, never) {
-        \ident ->
+        let (typeUse, Right (pred, (trueBranch, falseBranch))) = $4 in
-            let (pred, (trueBranch, falseBranch)) = $1 in
+        pred ++ [IfInstr $2 typeUse trueBranch falseBranch]
-            pred ++ [IfInstr ident [] trueBranch falseBranch]
     }
 
 folded_then_else :: { ([Instruction], ([Instruction], [Instruction])) }
@@ -1225,12 +1175,12 @@ data Instruction =
     }
     | LoopInstr {
         label :: Maybe Ident,
-        resultType :: [ValueType],
+        blockType :: TypeUse,
         body :: [Instruction]
     }
     | IfInstr {
         label :: Maybe Ident,
-        resultType :: [ValueType],
+        blockType :: TypeUse,
         trueBranch :: [Instruction],
         falseBranch :: [Instruction]
     }
@@ -1503,10 +1453,10 @@ desugarize fields = do
             matchTypeUse defs typeUse
         extractTypeDefFromInstruction defs (BlockInstr { body, blockType }) =
             extractTypeDefFromInstructions (matchTypeUse defs blockType) body
-        extractTypeDefFromInstruction defs (LoopInstr { body }) =
+        extractTypeDefFromInstruction defs (LoopInstr { body, blockType }) =
-            extractTypeDefFromInstructions defs body
+            extractTypeDefFromInstructions (matchTypeUse defs blockType) body
-        extractTypeDefFromInstruction defs (IfInstr { trueBranch, falseBranch }) =
+        extractTypeDefFromInstruction defs (IfInstr { blockType, trueBranch, falseBranch }) =
-            extractTypeDefFromInstructions defs $ trueBranch ++ falseBranch
+            extractTypeDefFromInstructions (matchTypeUse defs blockType) $ trueBranch ++ falseBranch
         extractTypeDefFromInstruction defs _ = defs
 
         funcTypesEq :: FuncType -> FuncType -> Bool
@@ -1659,14 +1609,26 @@ desugarize fields = do
                     Just idx -> return $ S.TypeIndex idx
                     Nothing -> Left "unknown type"
             S.Block bt <$> mapM (synInstrToStruct ctx') body
-        synInstrToStruct ctx LoopInstr {label, resultType, body} =
+        synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } LoopInstr {label, blockType, body} = do
-            let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
-            S.Loop resultType <$> mapM (synInstrToStruct ctx') body
-        synInstrToStruct ctx IfInstr {label, resultType, trueBranch, falseBranch} = 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.Loop bt <$> mapM (synInstrToStruct ctx') body
+        synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } IfInstr {label, blockType, trueBranch, falseBranch} = 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"
             trueBranch' <- mapM (synInstrToStruct ctx') trueBranch
             falseBranch' <- mapM (synInstrToStruct ctx') falseBranch
-            return $ S.If resultType trueBranch' falseBranch'
+            return $ S.If bt trueBranch' falseBranch'
         
         synFunctionToStruct :: Module -> Function -> Either String S.Function
         synFunctionToStruct mod Function { funcType, locals, body } = do

src/Language/Wasm/Structure.hs

@@ -126,8 +126,8 @@ data Instruction index =
     Unreachable
     | Nop
     | Block { blockType :: BlockType, body :: Expression }
-    | Loop { resultType :: ResultType, body :: Expression }
+    | Loop { blockType :: BlockType, body :: Expression }
-    | If { resultType :: ResultType, true :: Expression, false :: Expression }
+    | If { blockType :: BlockType, true :: Expression, false :: Expression }
     | Br index
     | BrIf index
     | BrTable [index] index

src/Language/Wasm/Validate.hs

@@ -224,19 +224,26 @@ getInstrType Block { blockType, body } = do
     if isArrowMatch t bt
     then return bt
     else throwError $ TypeMismatch t bt
-getInstrType Loop { resultType, body } = do
+getInstrType Loop { blockType, body } = do
-    let blockType = empty ==> resultType
+    bt <- getBlockType blockType
-    t <- withLabel [] $ getExpressionType body
+    resultType <- getResultType blockType
-    if isArrowMatch t blockType
+    t <- withLabel resultType $ getExpressionType body
-    then return $ empty ==> resultType
+    if isArrowMatch t bt
-    else throwError $ TypeMismatch t blockType
+    then return bt
-getInstrType If { resultType, true, false } = do
+    else throwError $ TypeMismatch t bt
-    let blockType = empty ==> resultType
+getInstrType If { blockType, true, false } = do
+    bt <- getBlockType blockType
+    resultType <- getResultType blockType
     l <- withLabel resultType $ getExpressionType true
     r <- withLabel resultType $ getExpressionType false
-    if isArrowMatch l blockType
+    if isArrowMatch l bt
-    then (if isArrowMatch r blockType then (return $ I32 ==> resultType) else (throwError $ TypeMismatch r blockType))
+    then (
-    else throwError $ TypeMismatch l blockType
+            if isArrowMatch r bt
+            then let Arrow from to = bt in
+                (return $ (from ++ [Val I32]) ==> to)
+            else (throwError $ TypeMismatch r bt)
+        )
+    else throwError $ TypeMismatch l bt
 getInstrType (Br lbl) = do
     r <- map Val . maybeToList <$> getLabel lbl
     return $ (Any : r) ==> Any

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 = ["block.wast", "stack.wast", "func.wast"]
+  let files = ["block.wast", "loop.wast", "if.wast", "stack.wast", "func.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do