diff --git a/exec/Main.hs b/exec/Main.hs index 4a4d38e..372da18 100644 --- a/exec/Main.hs +++ b/exec/Main.hs @@ -5,9 +5,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Base64.Lazy as Base64 import Data.Maybe (fromMaybe) -import qualified Language.Wasm.Lexer as Lexer -import qualified Language.Wasm.Parser as Parser -import qualified Language.Wasm.Binary as Binary +import qualified Language.Wasm as Wasm import Options.Applicative import Data.Semigroup ((<>)) @@ -105,10 +103,7 @@ config = subparser ( ) toBinary :: LBS.ByteString -> Either String LBS.ByteString -toBinary content = do - lexemes <- Lexer.scanner content - mod <- Parser.parseModule lexemes - return $ Binary.dumpModuleLazy mod +toBinary = fmap Wasm.encodeLazy . Wasm.parse compileAs :: (LBS.ByteString -> LBS.ByteString) -> String -> String -> IO () compileAs transform input output = do diff --git a/src/Language/Wasm.hs b/src/Language/Wasm.hs index 3dc8274..ddc8b26 100644 --- a/src/Language/Wasm.hs +++ b/src/Language/Wasm.hs @@ -1,6 +1,48 @@ module Language.Wasm ( - something + Module, + ValidModule, + ValidationError(..), + parse, + validate, + Language.Wasm.parseScript, + encode, + encodeLazy, + decode, + decodeLazy, + Script, + runScript ) where -something :: Int -something = 42 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS + +import Language.Wasm.Structure as Struct +import Language.Wasm.Script as Script +import Language.Wasm.Lexer as Lexer +import Language.Wasm.Parser as Parser +import Language.Wasm.Validate as Valid +import Language.Wasm.Binary as Binary + +-- | Parse WebAssembly text representation to `Module` +parse :: LBS.ByteString -> Either String Module +parse content = Lexer.scanner content >>= Parser.parseModule + +-- | Parse WebAssembly extended scipt grammar +parseScript :: LBS.ByteString -> Either String Script +parseScript content = Lexer.scanner content >>= Parser.parseScript + +-- | Dump `Module` to binary representation +encode :: Module -> BS.ByteString +encode = dumpModule + +-- | Dump `Module` to binary representation lazily +encodeLazy :: Module -> LBS.ByteString +encodeLazy = dumpModuleLazy + +-- | Decode `Module` from binary representation +decode :: BS.ByteString -> Either String Module +decode = decodeModule + +-- | Decode `Module` from binary representation lazily +decodeLazy :: LBS.ByteString -> Either String Module +decodeLazy = decodeModuleLazy diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 99202a6..50e0956 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -53,9 +53,8 @@ import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.IO.Class (liftIO) -import Debug.Trace as Debug - import Language.Wasm.Structure as Struct +import Language.Wasm.Validate as Valid import Language.Wasm.FloatUtils ( wordToFloat, floatToWord, @@ -532,8 +531,9 @@ initialize inst Module {elems, datas, start} store = do initData (from, mem, chunk) = mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk -instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store)) -instantiate st imps m = runExceptT $ do +instantiate :: Store -> Imports -> Valid.ValidModule -> IO (Either String (ModuleInstance, Store)) +instantiate st imps mod = runExceptT $ do + let m = Valid.getModule mod inst <- calcInstance st imps m let functions = funcInstances st <> (allocFunctions inst $ Struct.functions m) globals <- liftIO $ (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m) diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x index e72fe03..bff6056 100644 --- a/src/Language/Wasm/Lexer.x +++ b/src/Language/Wasm/Lexer.x @@ -21,8 +21,6 @@ import Data.Word (Word8) import Data.List (isPrefixOf) import Text.Read (readEither) -import qualified Debug.Trace as Debug - } %wrapper "monadUserState-bytestring" diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 236f561..a1dfa99 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -96,8 +96,6 @@ import Language.Wasm.Lexer ( asDouble ) -import Debug.Trace as Debug - } %name parseModule mod diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 49ce7d7..303b44b 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -95,12 +95,12 @@ runScript onAssertFail script = do addModule :: Maybe Ident -> Struct.Module -> ScriptState -> IO ScriptState addModule ident m st = case Validate.validate m of - Validate.Valid -> do + Right m -> do res <- Interpreter.instantiate (store st) (buildImports st) m case res of Right (modInst, store') -> return $ addToStore ident modInst $ st { lastModule = Just modInst, store = store' } Left reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason - reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason + Left reason -> error $ "Module instantiation failed dut to invalid module with reason: " ++ show reason getModule :: ScriptState -> Maybe Ident -> Maybe Interpreter.ModuleInstance getModule st (Just (Ident i)) = Map.lookup i (modules st) @@ -156,7 +156,7 @@ runScript onAssertFail script = do checkModuleInvalid :: Struct.Module -> IO () checkModuleInvalid _ = return () - getFailureString :: Validate.ValidationResult -> [TL.Text] + getFailureString :: Validate.ValidationError -> [TL.Text] getFailureString (Validate.TypeMismatch _ _) = ["type mismatch"] getFailureString Validate.ResultTypeDoesntMatch = ["type mismatch"] getFailureString Validate.MoreThanOneMemory = ["multiple memories"] @@ -194,8 +194,8 @@ runScript onAssertFail script = do runAssert st assert@(AssertInvalid moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of - Validate.Valid -> onAssertFail "Invalid module pass validation" assert - reason -> + Right _ -> onAssertFail "Invalid module pass validation" assert + Left reason -> if failureString `elem` getFailureString reason then return () else @@ -216,12 +216,12 @@ runScript onAssertFail script = do runAssert st assert@(AssertUnlinkable moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of - Validate.Valid -> do + Right m -> do res <- Interpreter.instantiate (store st) (buildImports st) m case res of Left err -> return () Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert - reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason + Left reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason runAssert st assert@(AssertTrap (Left action) failureString) = do result <- runAction st action if isNothing result @@ -230,12 +230,12 @@ runScript onAssertFail script = do runAssert st assert@(AssertTrap (Right moduleDef) failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of - Validate.Valid -> do + Right m -> do res <- Interpreter.instantiate (store st) (buildImports st) m case res of Left "Start function terminated with trap" -> return () _ -> onAssertFail ("Module linking should fail with trap during execution of a start function") assert - reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason + Left reason -> error $ "Module linking failed dut to invalid module with reason: " ++ show reason runAssert st assert@(AssertExhaustion action failureString) = do result <- runAction st action if isNothing result diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index a561493..ca80ec1 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -3,9 +3,12 @@ {-# LANGUAGE FlexibleInstances #-} module Language.Wasm.Validate ( + ValidationError(..), ValidationResult(..), validate, - isValid + isValid, + ValidModule, + getModule ) where import Language.Wasm.Structure @@ -22,7 +25,7 @@ import Control.Monad.Except (Except, runExcept, throwError) import Debug.Trace as Debug -data ValidationResult = +data ValidationError = DuplicatedExportNames [String] | InvalidTableType | MinMoreThanMaxInMemoryLimit @@ -45,18 +48,19 @@ data ValidationResult = | ImportedGlobalIsNotConst | ExportedGlobalIsNotConst | GlobalIsImmutable - | Valid deriving (Show, Eq) +type ValidationResult = Either ValidationError () + instance Monoid ValidationResult where - mempty = Valid - mappend Valid vr = vr - mappend vr Valid = vr + mempty = Right () + mappend (Right ()) vr = vr + mappend vr (Right ()) = vr mappend vr _ = vr isValid :: ValidationResult -> Bool -isValid Valid = True -isValid reason = Debug.trace ("Module mismatched with reason " ++ show reason) $ False +isValid (Right ()) = True +isValid (Left reason) = Debug.trace ("Module mismatched with reason " ++ show reason) $ False type Validator = Module -> ValidationResult @@ -129,12 +133,12 @@ data Ctx = Ctx { importedGlobals :: Natural } deriving (Show, Eq) -type Checker = ReaderT Ctx (Except ValidationResult) +type Checker = ReaderT Ctx (Except ValidationError) freshVar :: Checker VType freshVar = return Var -runChecker :: Ctx -> Checker a -> Either ValidationResult a +runChecker :: Ctx -> Checker a -> Either ValidationError a runChecker ctx = runExcept . flip runReaderT ctx (!?) :: [a] -> Natural -> Maybe a @@ -146,7 +150,7 @@ safeHead :: [a] -> Maybe a safeHead (x: _) = Just x safeHead [] = Nothing -maybeToEither :: ValidationResult -> Maybe a -> Checker a +maybeToEither :: ValidationError -> Maybe a -> Checker a maybeToEither _ (Just a) = return a maybeToEither l Nothing = throwError l @@ -453,17 +457,15 @@ isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types then let FuncType params results = types !! fromIntegral funcType in if length results > 1 - then InvalidResultArity - else - let r = safeHead results in - let ctx = ctxFromModule (params ++ locals) [r] r mod in - case runChecker ctx $ getExpressionType body of - Left err -> err - Right arr -> - if isArrowMatch arr (empty ==> results) - then Valid - else TypeMismatch arr (empty ==> results) - else TypeIndexOutOfRange + then Left InvalidResultArity + else do + let r = safeHead results + let ctx = ctxFromModule (params ++ locals) [r] r mod + arr <- runChecker ctx $ getExpressionType body + if isArrowMatch arr (empty ==> results) + then return () + else Left $ TypeMismatch arr (empty ==> results) + else Left TypeIndexOutOfRange functionsShouldBeValid :: Validator functionsShouldBeValid mod@Module {functions} = @@ -476,13 +478,13 @@ tablesShouldBeValid Module { imports, tables } = let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in if length tableImports + length tables <= 1 then res' - else MoreThanOneTable + else Left MoreThanOneTable where isValidTableType :: TableType -> ValidationResult isValidTableType (TableType (Limit min max) _) = if min <= fromMaybe min max - then Valid - else InvalidTableType + then return () + else Left InvalidTableType memoryShouldBeValid :: Validator memoryShouldBeValid Module { imports, mems } = @@ -491,12 +493,12 @@ memoryShouldBeValid Module { imports, mems } = let res' = foldl' (\r (Memory l) -> r <> isValidLimit l) res mems in if length memImports + length mems <= 1 then res' - else MoreThanOneMemory + else Left MoreThanOneMemory where isValidLimit :: Limit -> ValidationResult isValidLimit (Limit min max) = - let minMax = if min <= fromMaybe min max then Valid else MinMoreThanMaxInMemoryLimit in - let maxLim = if fromMaybe min max <= 65536 then Valid else MemoryLimitExceeded in + let minMax = if min <= fromMaybe min max then return () else Left MinMoreThanMaxInMemoryLimit in + let maxLim = if fromMaybe min max <= 65536 then return () else Left MemoryLimitExceeded in minMax <> maxLim globalsShouldBeValid :: Validator @@ -509,16 +511,11 @@ globalsShouldBeValid m@Module { imports, globals } = getGlobalType (Mut vt) = vt isGlobalValid :: Ctx -> Global -> ValidationResult - isGlobalValid ctx (Global gt init) = - let check = runChecker ctx $ do - isConstExpression init - t <- getExpressionType init - let expected = empty ==> getGlobalType gt - return $ if isArrowMatch expected t then Valid else TypeMismatch t expected - in - case check of - Left err -> err - Right res -> res + isGlobalValid ctx (Global gt init) = runChecker ctx $ do + isConstExpression init + t <- getExpressionType init + let expected = empty ==> getGlobalType gt + if isArrowMatch expected t then return () else throwError $ TypeMismatch t expected elemsShouldBeValid :: Validator elemsShouldBeValid m@Module { elems, functions, tables, imports } = @@ -530,22 +527,20 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } = let check = runChecker ctx $ do isConstExpression offset t <- getExpressionType offset - return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) - in - let isIniterValid = case check of - Left err -> err - Right res -> res + if isArrowMatch (empty ==> I32) t + then return () + else throwError $ TypeMismatch t (empty ==> I32) in let tableImports = filter isTableImport imports in let isTableIndexValid = if tableIdx < (fromIntegral $ length tableImports + length tables) - then Valid - else TableIndexOutOfRange + then return () + else Left TableIndexOutOfRange in let funImports = filter isFuncImport imports in let funsLength = fromIntegral $ length functions + length funImports in - let isFunsValid = foldMap (\i -> if i < funsLength then Valid else FunctionIndexOutOfRange) funs in - isIniterValid <> isFunsValid <> isTableIndexValid + let isFunsValid = foldMap (\i -> if i < funsLength then return () else Left FunctionIndexOutOfRange) funs in + check <> isFunsValid <> isTableIndexValid datasShouldBeValid :: Validator datasShouldBeValid m@Module { datas, mems, imports } = @@ -557,25 +552,23 @@ datasShouldBeValid m@Module { datas, mems, imports } = let check = runChecker ctx $ do isConstExpression offset t <- getExpressionType offset - return $ if isArrowMatch (empty ==> I32) t then Valid else TypeMismatch t (empty ==> I32) - in - let isOffsetValid = case check of - Left err -> err - Right res -> res + if isArrowMatch (empty ==> I32) t + then return () + else throwError $ TypeMismatch t (empty ==> I32) in let memImports = filter isMemImport imports in if memIdx < (fromIntegral $ length memImports + length mems) - then isOffsetValid - else MemoryIndexOutOfRange + then check + else Left MemoryIndexOutOfRange startShouldBeValid :: Validator -startShouldBeValid Module { start = Nothing } = Valid +startShouldBeValid Module { start = Nothing } = return () startShouldBeValid m@Module { start = Just (StartFunction idx) } = let types = getFuncTypes m in let i = fromIntegral idx in if length types > i - then if FuncType [] [] == types !! i then Valid else InvalidStartFunctionType - else FunctionIndexOutOfRange + then if FuncType [] [] == types !! i then return () else Left InvalidStartFunctionType + else Left FunctionIndexOutOfRange exportsShouldBeValid :: Validator exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals } = @@ -588,29 +581,29 @@ exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals isExportValid :: Export -> ValidationResult isExportValid (Export _ (ExportFunc funIdx)) = - if fromIntegral funIdx < length funcImports + length functions then Valid else FunctionIndexOutOfRange + if fromIntegral funIdx < length funcImports + length functions then return () else Left FunctionIndexOutOfRange isExportValid (Export _ (ExportTable tableIdx)) = - if fromIntegral tableIdx < length tableImports + length tables then Valid else TableIndexOutOfRange + if fromIntegral tableIdx < length tableImports + length tables then return () else Left TableIndexOutOfRange isExportValid (Export _ (ExportMemory memIdx)) = - if fromIntegral memIdx < length memImports + length mems then Valid else MemoryIndexOutOfRange + if fromIntegral memIdx < length memImports + length mems then return () else Left MemoryIndexOutOfRange isExportValid (Export _ (ExportGlobal globalIdx)) = if fromIntegral globalIdx < length globalImports + length globals then ( if fromIntegral globalIdx >= length globalImports then ( case globals !! (fromIntegral globalIdx - length globalImports) of - (Global (Mut _) _) -> ExportedGlobalIsNotConst - _ -> Valid + (Global (Mut _) _) -> Left ExportedGlobalIsNotConst + _ -> return () ) - else Valid + else return () ) - else GlobalIndexOutOfRange + else Left GlobalIndexOutOfRange areExportNamesUnique :: ValidationResult areExportNamesUnique = case foldl' go (Set.empty, []) exports of - (_, []) -> Valid - (_, dup) -> DuplicatedExportNames dup + (_, []) -> return () + (_, dup) -> Left $ DuplicatedExportNames dup where go :: (Set.Set TL.Text, [String]) -> Export -> (Set.Set TL.Text, [String]) go (set, dup) (Export name _) = @@ -623,20 +616,25 @@ importsShouldBeValid Module { imports, types } = foldMap isImportValid imports where isImportValid :: Import -> ValidationResult - isImportValid (Import _ _ (ImportFunc typeIdx)) = if fromIntegral typeIdx < length types then Valid else TypeIndexOutOfRange - isImportValid (Import _ _ (ImportTable _)) = Valid -- checked in tables section - isImportValid (Import _ _ (ImportMemory _)) = Valid -- checked in mems section - isImportValid (Import _ _ (ImportGlobal (Const _))) = Valid - isImportValid (Import _ _ (ImportGlobal (Mut _))) = ImportedGlobalIsNotConst + isImportValid (Import _ _ (ImportFunc typeIdx)) = + if fromIntegral typeIdx < length types + then return () + else Left TypeIndexOutOfRange + isImportValid (Import _ _ (ImportTable _)) = return () -- checked in tables section + isImportValid (Import _ _ (ImportMemory _)) = return () -- checked in mems section + isImportValid (Import _ _ (ImportGlobal (Const _))) = return () + isImportValid (Import _ _ (ImportGlobal (Mut _))) = Left ImportedGlobalIsNotConst typesShouldBeValid :: Validator typesShouldBeValid Module { types } = foldMap isTypeValid types where isTypeValid :: FuncType -> ValidationResult - isTypeValid FuncType { results } = if length results <= 1 then Valid else InvalidResultArity + isTypeValid FuncType { results } = if length results <= 1 then return () else Left InvalidResultArity -validate :: Validator -validate mod = foldMap ($ mod) validators +newtype ValidModule = ValidModule { getModule :: Module } deriving (Show, Eq) + +validate :: Module -> Either ValidationError ValidModule +validate mod = const (ValidModule mod) <$> foldMap ($ mod) validators where validators :: [Validator] validators = [ diff --git a/tests/Test.hs b/tests/Test.hs index 0cc4c0d..ccdc349 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -10,34 +10,14 @@ import qualified System.Directory as Directory import qualified Data.ByteString.Lazy as LBS -import qualified Language.Wasm.Lexer as Lexer -import qualified Language.Wasm.Parser as Parser -import qualified Language.Wasm.Structure as Structure -import qualified Language.Wasm.Binary as Binary -import qualified Language.Wasm.Validate as Validate -import qualified Language.Wasm.Interpreter as Interpreter +import qualified Language.Wasm as Wasm import qualified Language.Wasm.Script as Script -import qualified Debug.Trace as Debug - -isRight :: (Show b) => Either a b -> Bool -isRight (Right x) = x `seq` True -isRight _ = False - -compile :: String -> IO () -compile file = do - content <- LBS.readFile $ "tests/samples/" ++ file - let Right mod = Lexer.scanner content >>= Parser.parseModule - LBS.writeFile ("tests/runnable/" ++ file) $ Binary.dumpModuleLazy mod - -- to run: python -m SimpleHTTPServer 8081 && open http://localhost:8081/tests/runnable - main :: IO () main = do files <- Directory.listDirectory "tests/samples" - -- let files = ["address.wast"] scriptTestCases <- (`mapM` files) $ \file -> do - content <- LBS.readFile $ "tests/samples/" ++ file - let Right script = Lexer.scanner content >>= Parser.parseScript + Right script <- Wasm.parseScript <$> LBS.readFile ("tests/samples/" ++ file) return $ testCase file $ do Script.runScript (\msg assert -> assertFailure ("Failed assert: " ++ msg ++ ". Assert " ++ show assert)) script defaultMain $ testGroup "Wasm Core Test Suit" scriptTestCases diff --git a/wasm.cabal b/wasm.cabal index 133c348..75b38c3 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -1,11 +1,5 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. --- --- see: https://github.com/sol/hpack --- --- hash: 1b02a1858ead3517927e9405dabc17ffb37f0df038564d37e8321b18227389ec - name: wasm -version: 0.1.0 +version: 1.0.0 author: Ilya Rezvov maintainer: rezvov.ilya@gmail.com license: MIT @@ -56,7 +50,7 @@ executable wasm hs-source-dirs: exec build-depends: base >=4.6 && <5.0 - , wasm ==0.1.0 + , wasm >= 1.0.0 , optparse-applicative >= 0.14 , bytestring >=0.10 && <0.11 , base64-bytestring >= 1.0 @@ -75,7 +69,7 @@ test-suite test , tasty >=0.7 , tasty-hunit >=0.4.1 && <0.10 , text >=1.1 && <1.3 - , wasm ==0.1.0 + , wasm >= 1.0 build-tools: alex >=3.1.3 , happy >=1.9.4