From fa1d9a7bd112d3ce15fc5702c4f7936ed75d98c2 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Wed, 7 Apr 2021 10:35:51 -0700 Subject: [PATCH] handle more parsing edgecases --- src/Language/Wasm/Parser.y | 117 ++++++++++++++++++++++------------ src/Language/Wasm/Script.hs | 1 + src/Language/Wasm/Validate.hs | 2 +- 3 files changed, 78 insertions(+), 42 deletions(-) diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 864f5a1..5a47b85 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -69,6 +69,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBSChar8 import Data.Maybe (fromMaybe, fromJust, isNothing) import Data.List (foldl', findIndex, find) import Control.Monad (guard, foldM) +import Control.Monad.Except (throwError) import Numeric.Natural (Natural) import Data.Word (Word32, Word64) @@ -642,27 +643,27 @@ memarg8 :: { MemArg } instruction_list(terminator) : terminator { ($1, []) } | plaininstr mixed_instruction_list(terminator) { ([PlainInstr $1] ++) `fmap` $2 } - | 'call_indirect' typeuse(terminator) { + | 'call_indirect' typeuse(terminator) {% let (tu, instr, end) = $2 in - (end, [PlainInstr $ CallIndirect tu] ++ instr) + onlyAnonimParams tu >> (return (end, [PlainInstr $ CallIndirect tu] ++ instr)) } - | 'block' opt(ident) typeuse('end') opt(ident) mixed_instruction_list(terminator) {% - let (tu, instr, _) = $3 in - if matchIdents $2 $4 - then Right $ ([BlockInstr $2 tu instr] ++) `fmap` $5 - else Left "Block labels have to match" + | 'block' opt(ident) typeuse('end') opt(ident) mixed_instruction_list(terminator) {% do + let (tu, instr, _) = $3 + matchIdents $2 $4 + onlyAnonimParams tu + return $ ([BlockInstr $2 tu instr] ++) `fmap` $5 } - | 'loop' opt(ident) typeuse('end') opt(ident) mixed_instruction_list(terminator) {% - let (tu, instr, _) = $3 in - if matchIdents $2 $4 - then Right $ ([LoopInstr $2 tu instr] ++) `fmap` $5 - else Left "Loop labels have to match" + | 'loop' opt(ident) typeuse('end') opt(ident) mixed_instruction_list(terminator) {% do + let (tu, instr, _) = $3 + matchIdents $2 $4 + onlyAnonimParams tu + return $ ([LoopInstr $2 tu instr] ++) `fmap` $5 } - | 'if' opt(ident) typeuse(if_else) mixed_instruction_list(terminator) {% - let (tu, trueBranch, (falseBranch, identAfter)) = $3 in - if matchIdents $2 identAfter - then Right $ ([IfInstr $2 tu trueBranch falseBranch] ++) `fmap` $4 - else Left "If labels have to match" + | 'if' opt(ident) typeuse(if_else) mixed_instruction_list(terminator) {% do + let (tu, trueBranch, (falseBranch, identAfter)) = $3 + matchIdents $2 identAfter + onlyAnonimParams tu + return $ ([IfInstr $2 tu trueBranch falseBranch] ++) `fmap` $4 } mixed_instruction_list(terminator) @@ -672,9 +673,7 @@ mixed_instruction_list(terminator) if_else :: { ([Instruction], Maybe Ident) } : 'end' opt(ident) { ([], $2) } | 'else' opt(ident) mixed_instruction_list('end') opt(ident) {% - if matchIdents $2 $4 - then Right (snd $3, if isNothing $2 then $4 else $2) - else Left "If labels have to match" + matchIdents $2 $4 >> return (snd $3, if isNothing $2 then $4 else $2) } folded_instr_list(terminator) : folded_instr1 mixed_instruction_list(terminator) { ($1 ++) `fmap` $2 } @@ -684,21 +683,21 @@ folded_instr :: { [Instruction] } folded_instr1 :: { [Instruction] } : plaininstr mixed_instruction_list(')') { snd $2 ++ [PlainInstr $1] } - | 'call_indirect' typeuse(')') { + | 'call_indirect' typeuse(')') {% let (tu, instr, _) = $2 in - instr ++ [PlainInstr $ CallIndirect tu] + onlyAnonimParams tu >> (return $ instr ++ [PlainInstr $ CallIndirect tu]) } - | 'block' opt(ident) typeuse(')') { + | 'block' opt(ident) typeuse(')') {% let (typeUse, instr, _) = $3 in - [BlockInstr $2 typeUse instr] + onlyAnonimParams typeUse >> (return [BlockInstr $2 typeUse instr]) } - | 'loop' opt(ident) typeuse(')') { + | 'loop' opt(ident) typeuse(')') {% let (typeUse, instr, _) = $3 in - [LoopInstr $2 typeUse instr] + onlyAnonimParams typeUse >> (return [LoopInstr $2 typeUse instr]) } - | 'if' opt(ident) '(' typeuse1(folded_then_else, never) { + | 'if' opt(ident) '(' typeuse1(folded_then_else, never) {% let (typeUse, Right (pred, (trueBranch, falseBranch))) = $4 in - pred ++ [IfInstr $2 typeUse trueBranch falseBranch] + onlyAnonimParams typeUse >> (return $ pred ++ [IfInstr $2 typeUse trueBranch falseBranch]) } folded_then_else :: { ([Instruction], ([Instruction], [Instruction])) } @@ -997,10 +996,23 @@ prependFuncResults prep f@(Function { funcType = AnonimousTypeUse ft }) = mergeFuncType :: FuncType -> FuncType -> FuncType mergeFuncType (FuncType lps lrs) (FuncType rps rrs) = FuncType (lps ++ rps) (lrs ++ rrs) -matchIdents :: Maybe Ident -> Maybe Ident -> Bool -matchIdents Nothing _ = True -matchIdents _ Nothing = True -matchIdents a b = a == b +matchIdents :: Maybe Ident -> Maybe Ident -> Either String () +matchIdents Nothing Nothing = return () +matchIdents (Just a) (Just b) = if a == b then return () else throwError "mismatching label" +matchIdents Nothing (Just _) = throwError "mismatching label" +matchIdents (Just _) Nothing = return () + +onlyAnonimParams :: TypeUse -> Either String () +onlyAnonimParams (IndexedTypeUse _ (Just ft)) = onlyAnonimFT ft +onlyAnonimParams (AnonimousTypeUse ft) = onlyAnonimFT ft +onlyAnonimParams _ = return () + +onlyAnonimFT :: FuncType -> Either String () +onlyAnonimFT (FuncType params _) = mapM_ isAnonim params + where + isAnonim ParamType{ ident = Just _ } = + throwError "only anonimous params allowed in block signatures" + isAnonim _ = return () asOffset :: LBS.ByteString -> Maybe Natural asOffset str = do @@ -1350,6 +1362,7 @@ desugarize fields = do elements <- mapM (synElemToStruct mod) $ elems mod segments <- mapM (synDataToStruct mod) $ datas mod globs <- mapM (synGlobalToStruct mod) $ globals mod + checkTableIdentsUniqueness mod checkMemoryIdentsUniqueness mod checkGlobalIdentsUniqueness mod return S.Module { @@ -1666,6 +1679,23 @@ desugarize fields = do synTableToStruct :: Table -> S.Table synTableToStruct (Table _ _ tableType) = S.Table tableType + checkTableIdentsUniqueness :: Module -> Either String () + checkTableIdentsUniqueness m@Module { imports, tables } = do + mapM_ checkImportUniqueness $ filter isTableImport imports + mapM_ checkTableUniqueness tables + where + checkImportUniqueness Import { desc = ImportTable (Just id) _ } = + if length (getTableIndexes m id) > 1 + then throwError "duplicate table" + else return () + checkImportUniqueness _ = return () + + checkTableUniqueness (Table _ (Just id) _) = + if length (getTableIndexes m id) > 1 + then throwError "duplicate table" + else return () + checkTableUniqueness _ = return () + extractTable :: [Table] -> ModuleField -> [Table] extractTable tables (MFTable table) = table : tables extractTable tables _ = tables @@ -1674,15 +1704,20 @@ desugarize fields = do isTableImport Import { desc = ImportTable _ _ } = True isTableImport _ = False + getTableIndexes :: Module -> Ident -> [Natural] + getTableIndexes Module { imports, tables } id = + let tableImports = zip [0..] $ filter isTableImport imports in + let importIndexes = map fst $ filter (\(_, Import { desc = ImportTable ident _ }) -> ident == Just id) tableImports in + let isIdent (_, (Table _ (Just id) _)) = True in + let tableIndexes = map fst $ filter isIdent $ zip [length tableImports..] tables in + map fromIntegral $ importIndexes ++ tableIndexes + getTableIndex :: Module -> TableIndex -> Maybe Natural - getTableIndex Module { imports, tables } (Named id) = - let tableImports = filter isTableImport imports in - case findIndex (\(Import { desc = ImportTable ident _ }) -> ident == Just id) tableImports of - Just idx -> return $ fromIntegral idx - Nothing -> - let isIdent (Table _ (Just id) _) = True in - fromIntegral . (+ length tableImports) <$> findIndex isIdent tables - getTableIndex Module { imports, tables } (Index idx) = Just idx + getTableIndex mod (Named id) = + case getTableIndexes mod id of + [idx] -> return idx + _ -> Nothing + getTableIndex _ (Index idx) = Just idx -- memory synMemoryToStruct :: Memory -> S.Memory @@ -1726,7 +1761,7 @@ desugarize fields = do case getMemIndexes mod id of [idx] -> return idx _ -> Nothing - getMemIndex Module { imports, mems } (Index idx) = Just idx + getMemIndex _ (Index idx) = Just idx -- global synGlobalToStruct :: Module -> Global -> Either String S.Global diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 2dfa395..4ad619b 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -187,6 +187,7 @@ runScript onAssertFail script = do getFailureString Validate.InvalidResultArity = ["invalid result arity"] getFailureString Validate.GlobalIsImmutable = ["global is immutable"] getFailureString Validate.InvalidStartFunctionType = ["start function"] + getFailureString Validate.InvalidTableType = ["size minimum must not be greater than maximum"] getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]] printFailedAssert :: String -> Assertion -> AssertM () diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index da45074..6ddad39 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -210,7 +210,7 @@ getInstrType Block { blockType, body } = do getInstrType Loop { blockType, body } = do bt@(Arrow from _) <- getBlockType blockType resultType <- getResultType blockType - t <- withLabel [] $ getExpressionTypeWithInput from body + t <- withLabel (map (\(Val v) -> v) from) $ getExpressionTypeWithInput from body if isArrowMatch t bt then return bt else throwError $ TypeMismatch t bt