diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 13aa81b..8a585b6 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -154,6 +154,7 @@ runScript onAssertFail script = do getFailureString :: Validate.ValidationResult -> TL.Text getFailureString (Validate.TypeMismatch _ _) = "type mismatch" + getFailureString Validate.ResultTypeDoesntMatch = "type mismatch" getFailureString Validate.MoreThanOneMemory = "multiple memories" getFailureString Validate.MoreThanOneTable = "multiple tables" getFailureString Validate.LocalIndexOutOfRange = "unknown local" diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 5286038..73c0159 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -16,7 +16,7 @@ import Data.Maybe (fromMaybe, maybeToList, catMaybes, isNothing) import Data.Monoid ((<>)) import Numeric.Natural (Natural) -import Control.Monad.State.Lazy (StateT, evalStateT, get, put) +import Control.Monad (foldM) import Control.Monad.Reader (ReaderT, runReaderT, withReaderT, ask) import Control.Monad.Except (Except, runExcept, throwError) @@ -60,7 +60,7 @@ type Validator = Module -> ValidationResult data VType = Val ValueType - | Var Int + | Var | Any deriving (Show, Eq) @@ -105,11 +105,11 @@ isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t' isEndMatch l (Any:r) = let (leftTail, rightTail) = unzip $ zip (takeWhile (/= Any) $ reverse l) (takeWhile (/= Any) $ reverse r) in isEndMatch (reverse leftTail) (reverse rightTail) - isEndMatch (Var v:l) (x:r) = - let subst = replace (Var v) x in + isEndMatch (Var:l) (x:r) = + let subst = replace Var x in isEndMatch (subst l) (subst r) - isEndMatch (x:l) (Var v:r) = - let subst = replace (Var v) x in + isEndMatch (x:l) (Var:r) = + let subst = replace Var x in isEndMatch (subst l) (subst r) isEndMatch (Val v:l) (Val v':r) = v == v' && isEndMatch l r isEndMatch [] [] = True @@ -127,16 +127,13 @@ data Ctx = Ctx { importedGlobals :: Natural } deriving (Show, Eq) -type Checker = ReaderT Ctx (StateT Int (Except ValidationResult)) +type Checker = ReaderT Ctx (Except ValidationResult) freshVar :: Checker VType -freshVar = do - i <- get - put (i + 1) - return $ Var i +freshVar = return Var runChecker :: Ctx -> Checker a -> Either ValidationResult a -runChecker ctx = runExcept . flip evalStateT 0 . flip runReaderT ctx +runChecker ctx = runExcept . flip runReaderT ctx (!?) :: [a] -> Natural -> Maybe a (!?) (x:_) 0 = Just x @@ -185,7 +182,7 @@ getInstrType Block { result, body } = do else throwError $ TypeMismatch t blockType getInstrType Loop { result, body } = do let blockType = empty ==> result - t <- withLabel result $ getExpressionType body + t <- withLabel [] $ getExpressionType body if isArrowMatch t blockType then return $ empty ==> result else throwError $ TypeMismatch t blockType @@ -207,7 +204,7 @@ getInstrType (BrTable lbls lbl) = do rs <- mapM getLabel lbls -- this check for equality doesn't match the spec, -- but a reference compiler does the same - if all (\r' -> r' == r || isNothing r' || isNothing r) rs + if all (\r' -> (isNothing r && isNothing r') || r' == r || isNothing r') rs then return $ ([Any] ++ (map Val $ maybeToList r) ++ [Val I32]) ==> Any else throwError ResultTypeDoesntMatch getInstrType Return = do @@ -373,47 +370,27 @@ replace :: (Eq a) => a -> a -> [a] -> [a] replace _ _ [] = [] replace x y (v:r) = (if x == v then y else v) : replace x y r -unify :: Arrow -> Arrow -> Checker Arrow -unify (from `Arrow` to) (from' `Arrow` to') = - unify' (from `Arrow` reverse to) (reverse from' `Arrow` to') - where - unify' :: Arrow -> Arrow -> Checker Arrow - unify' (f `Arrow` []) (f' `Arrow` t') = - return $ (reverse f' ++ f) `Arrow` t' - unify' (f `Arrow` t) ([] `Arrow` t') = - return $ f `Arrow` (reverse t ++ t') - unify' (f `Arrow` (Val v':t)) ((Val v:f') `Arrow` t') = - if v == v' - then unify' (f `Arrow` t) (f' `Arrow` t') - else throwError $ TypeMismatch (from `Arrow` to) (from' `Arrow` to') - unify' (f `Arrow` (Var r:t)) ((Val v:f') `Arrow` t') = - let subst = replace (Var r) (Val v) in - unify' (subst f `Arrow` subst t) (f' `Arrow` t') - unify' (f `Arrow` (Val v:t)) ((Var r:f') `Arrow` t') = - let subst = replace (Var r) (Val v) in - unify' (f `Arrow` t) (subst f' `Arrow` subst t') - unify' (f `Arrow` (Var r:t)) ((Var r':f') `Arrow` t') = - let subst = replace (Var r') (Var r) in - unify' (f `Arrow` t) (subst f' `Arrow` subst t') - unify' (f `Arrow` (Any:_)) (_ `Arrow` t') = - return $ f `Arrow` (Any : t') - unify' (f `Arrow` _) (f'@(Any:_) `Arrow` t') = - return $ (f' ++ f) `Arrow` t' - getExpressionType :: [Instruction] -> Checker Arrow -getExpressionType instrs = - case reverse instrs of - [] -> return $ empty ==> empty - (i:rest) -> do - arr <- getInstrType i - go arr rest +getExpressionType = fmap ([] `Arrow`) . foldM go [] where - go :: Arrow -> [Instruction] -> Checker Arrow - go arr [] = return arr - go arr (i:rest) = do - a <- getInstrType i - arr' <- unify a arr - go arr' rest + go :: [VType] -> Instruction -> Checker [VType] + go stack instr = do + (f `Arrow` t) <- getInstrType instr + matchStack stack (reverse f) t + + matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType] + matchStack stack@(Any:_) _arg res = return $ res ++ stack + matchStack (Val v:stack) (Val v':args) res = + if v == v' + then matchStack stack args res + else throwError $ TypeMismatch ((reverse $ Val v':args) `Arrow` res) ([] `Arrow` (Val v:stack)) + matchStack _ (Any:_) res = return $ res + matchStack (Val v:stack) (Var:args) res = + let subst = replace Var (Val v) in + matchStack stack (subst args) (subst res) + matchStack stack [] res = return $ res ++ stack + matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` []) + matchStack _ _ _ = error "inconsistent checker state" isConstExpression :: [Instruction] -> Checker () isConstExpression [] = return () @@ -637,11 +614,18 @@ importsShouldBeValid Module { imports, types } = isImportValid (Import _ _ (ImportGlobal (Const _))) = Valid isImportValid (Import _ _ (ImportGlobal (Mut _))) = ImportedGlobalIsNotConst +typesShouldBeValid :: Validator +typesShouldBeValid Module { types } = foldMap isTypeValid types + where + isTypeValid :: FuncType -> ValidationResult + isTypeValid FuncType { results } = if length results <= 1 then Valid else InvalidResultArity + validate :: Validator validate mod = foldMap ($ mod) validators where validators :: [Validator] validators = [ + typesShouldBeValid, functionsShouldBeValid, tablesShouldBeValid, memoryShouldBeValid, diff --git a/tests/Test.hs b/tests/Test.hs index 24e3805..356adba 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -34,7 +34,7 @@ compile file = do main :: IO () main = do files <- Directory.listDirectory "tests/samples" - -- let files = ["func.wast"] + -- let files = ["br_table.wast"] scriptTestCases <- (`mapM` files) $ \file -> do content <- LBS.readFile $ "tests/samples/" ++ file let Right script = Parser.parseScript <$> Lexer.scanner content diff --git a/tests/samples/align.wast b/tests/samples/align.wast index 133b501..3b0f267 100644 --- a/tests/samples/align.wast +++ b/tests/samples/align.wast @@ -12,7 +12,7 @@ ) (assert_invalid (module (memory 0) (func (drop (i64.load align=16 (i32.const 0))))) - "alignment" + "alignment must not be larger than natural" ) (assert_malformed @@ -29,5 +29,5 @@ ) (assert_invalid (module (memory 0) (func (i64.store align=16 (i32.const 0) (i64.const 0)))) - "alignment" + "alignment must not be larger than natural" )