diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index d8d30c9..019fa39 100644 --- a/src/Language/Wasm/Binary.hs +++ b/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 diff --git a/src/Language/Wasm/Builder.hs b/src/Language/Wasm/Builder.hs index 936ca64..b5a604c 100644 --- a/src/Language/Wasm/Builder.hs +++ b/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 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 diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 1a44f12..c237aab 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/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 } diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index dadfef0..3a9f717 100644 --- a/src/Language/Wasm/Parser.y +++ b/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 - 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 diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 292c68a..72d5dab 100644 --- a/src/Language/Wasm/Structure.hs +++ b/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 diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 55bd7c1..01e43f4 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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 - 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 diff --git a/tests/Test.hs b/tests/Test.hs index ed398db..729fbee 100644 --- a/tests/Test.hs +++ b/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