From 016ec834222a596b0734ab7d36c6a9bb1e273be2 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Fri, 12 Mar 2021 22:34:42 -0800 Subject: [PATCH] change instansiating to be stateful --- src/Language/Wasm/Interpreter.hs | 49 +++++++++------- src/Language/Wasm/Script.hs | 99 +++++++++++++++++++------------- tests/Test.hs | 2 +- 3 files changed, 87 insertions(+), 63 deletions(-) diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 1a2242a..1a44f12 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -53,6 +53,7 @@ import Data.Bits ( ) import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE) import Control.Monad.Except (ExceptT, runExceptT, throwError) +import qualified Control.Monad.State as State import Control.Monad.IO.Class (liftIO) import Language.Wasm.Structure as Struct @@ -468,25 +469,27 @@ allocMems mems = Vector.fromList <$> mapM allocMem mems memory } -type Initialize = ExceptT String IO +type Initialize = ExceptT String (State.StateT Store IO) -initialize :: ModuleInstance -> Module -> Store -> Initialize Store -initialize inst Module {elems, datas, start} store = do - checkedMems <- mapM (checkData store) datas - checkedTables <- mapM (checkElem store) elems +initialize :: ModuleInstance -> Module -> Initialize () +initialize inst Module {elems, datas, start} = do + checkedMems <- mapM checkData datas + checkedTables <- mapM checkElem elems mapM_ initData checkedMems - st <- Monad.foldM initElem store checkedTables + mapM_ initElem checkedTables + st <- State.get case start of Just (StartFunction idx) -> do - let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) + let funInst = funcInstances st ! (funcaddrs inst ! fromIntegral idx) mainRes <- liftIO $ eval defaultBudget st funInst [] case mainRes of - Just [] -> return st + Just [] -> return () _ -> throwError "Start function terminated with trap" - Nothing -> return st + Nothing -> return () where - checkElem :: Store -> ElemSegment -> Initialize (Address, Int, [Address]) - checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do + checkElem :: ElemSegment -> Initialize (Address, Int, [Address]) + checkElem ElemSegment {tableIndex, offset, funcIndexes} = do + st <- State.get VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let funcs = map ((funcaddrs inst !) . fromIntegral) funcIndexes @@ -497,14 +500,15 @@ initialize inst Module {elems, datas, start} store = do Monad.when (last > len) $ throwError "elements segment does not fit" return (idx, from, funcs) - initElem :: Store -> (Address, Int, [Address]) -> Initialize Store - initElem st (idx, from, funcs) = do - let TableInstance lim elems = tableInstances st ! idx - let table = TableInstance lim (elems // zip [from..] (map Just funcs)) - return st { tableInstances = tableInstances st Vector.// [(idx, table)] } + initElem :: (Address, Int, [Address]) -> Initialize () + initElem (idx, from, funcs) = State.modify $ \st -> + let TableInstance lim elems = tableInstances st ! idx in + let table = TableInstance lim (elems // zip [from..] (map Just funcs)) in + st { tableInstances = tableInstances st Vector.// [(idx, table)] } - checkData :: Store -> DataSegment -> Initialize (Int, MemoryStore, LBS.ByteString) - checkData st DataSegment {memIndex, offset, chunk} = do + checkData :: DataSegment -> Initialize (Int, MemoryStore, LBS.ByteString) + checkData DataSegment {memIndex, offset, chunk} = do + st <- State.get VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let idx = memaddrs inst ! fromIntegral memIndex @@ -519,21 +523,22 @@ initialize inst Module {elems, datas, start} store = do initData (from, mem, chunk) = mapM_ (\(i,b) -> ByteArray.writeByteArray mem i b) $ zip [from..] $ LBS.unpack chunk -instantiate :: Store -> Imports -> Valid.ValidModule -> IO (Either String (ModuleInstance, Store)) -instantiate st imps mod = runExceptT $ do +instantiate :: Store -> Imports -> Valid.ValidModule -> IO (Either String ModuleInstance, Store) +instantiate st imps mod = flip State.runStateT st $ 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) let tables = tableInstances st <> (allocTables $ Struct.tables m) mems <- liftIO $ (memInstances st <>) <$> (allocMems $ Struct.mems m) - st' <- initialize inst m $ st { + State.put $ st { funcInstances = functions, tableInstances = tables, memInstances = mems, globalInstances = globals } - return $ (inst, st') + initialize inst m + return inst type Stack = [Value] diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index c1a63ce..6c12fa6 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -8,6 +8,8 @@ import qualified Data.Map as Map import qualified Data.Vector as Vector import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLEncoding +import qualified Control.Monad.State as State +import Control.Monad.IO.Class (liftIO) import Numeric.IEEE (identicalIEEE) import qualified Control.DeepSeq as DeepSeq import Data.Maybe (fromJust, isNothing) @@ -45,6 +47,8 @@ emptyState = ScriptState { moduleRegistery = Map.empty } +type AssertM = State.StateT (ScriptState, String) IO + runScript :: OnAssertFail -> Script -> IO () runScript onAssertFail script = do (globI32, globI64, globF32, globF64) <- hostGlobals @@ -103,9 +107,9 @@ runScript onAssertFail script = do addModule ident m st = case Validate.validate m of Right m -> do - res <- Interpreter.instantiate (store st) (buildImports st) m + (res, store') <- Interpreter.instantiate (store st) (buildImports st) m case res of - Right (modInst, store') -> return $ addToStore ident modInst $ st { lastModule = Just modInst, store = store' } + Right modInst -> return $ addToStore ident modInst $ st { lastModule = Just modInst, store = store' } Left reason -> error $ "Module instantiation failed due to invalid module with reason: " ++ show reason Left reason -> error $ "Module instantiation failed due to invalid module with reason: " ++ show reason @@ -137,19 +141,19 @@ runScript onAssertFail script = do isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2 isValueEqual _ _ = False - isNaNReturned :: ScriptState -> String -> Action -> Assertion -> IO () - isNaNReturned st pos action assert = do - result <- runAction st action + isNaNReturned :: Action -> Assertion -> AssertM () + isNaNReturned action assert = do + result <- runActionInAssert action case result of Just [Interpreter.VF32 v] -> if isNaN v then return () - else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert + else printFailedAssert ("Expected NaN, but action returned " ++ show v) assert Just [Interpreter.VF64 v] -> if isNaN v then return () - else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert - _ -> onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show result) assert + else printFailedAssert ("Expected NaN, but action returned " ++ show v) assert + _ -> printFailedAssert ("Expected NaN, but action returned " ++ show result) assert buildModule :: ModuleDef -> (Maybe Ident, Struct.Module) buildModule (RawModDef ident m) = (ident, m) @@ -185,67 +189,81 @@ runScript onAssertFail script = do getFailureString Validate.InvalidStartFunctionType = ["start function"] getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]] - runAssert :: ScriptState -> String -> Assertion -> IO () - runAssert st pos assert@(AssertReturn action expected) = do - result <- runAction st action + printFailedAssert :: String -> Assertion -> AssertM () + printFailedAssert msg assert = do + (_, pos) <- State.get + liftIO $ onAssertFail (pos ++ ": " ++ msg) assert + + runActionInAssert :: Action -> AssertM (Maybe [Interpreter.Value]) + runActionInAssert action = do + (st, _) <- State.get + liftIO $ runAction st action + + runAssert :: Assertion -> AssertM () + runAssert assert@(AssertReturn action expected) = do + (st, _) <- State.get + result <- runActionInAssert action case result of Just result -> do if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected)) then return () - else onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert - Nothing -> onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert - runAssert st pos assert@(AssertReturnCanonicalNaN action) = isNaNReturned st pos action assert - runAssert st pos assert@(AssertReturnArithmeticNaN action) = isNaNReturned st pos action assert - runAssert st pos assert@(AssertInvalid moduleDef failureString) = + else printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert + Nothing -> printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert + runAssert assert@(AssertReturnCanonicalNaN action) = isNaNReturned action assert + runAssert assert@(AssertReturnArithmeticNaN action) = isNaNReturned action assert + runAssert assert@(AssertInvalid moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of - Right _ -> onAssertFail (pos ++ ": An invalid module passed validation step") assert + Right _ -> printFailedAssert "An invalid module passed validation step" assert Left reason -> if failureString `elem` getFailureString reason then return () else - let msg = pos ++ ": Module is invalid for other reason. Expected " + let msg = "Module is invalid for other reason. Expected " ++ show failureString ++ ", but actual is " ++ show (getFailureString reason) - in onAssertFail msg assert - runAssert st pos assert@(AssertMalformed (TextModDef _ textRep) failureString) = + in printFailedAssert msg assert + runAssert assert@(AssertMalformed (TextModDef _ textRep) failureString) = case DeepSeq.force $ Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule of - Right _ -> onAssertFail (pos ++ ": Module parsing should fail with failure string " ++ show failureString) assert + Right _ -> printFailedAssert ("Module parsing should fail with failure string " ++ show failureString) assert Left _ -> return () - runAssert st pos assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) = + runAssert assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) = case Binary.decodeModuleLazy binaryRep of - Right _ -> onAssertFail (pos ++ ": Module decoding should fail with failure string " ++ show failureString) assert + Right _ -> printFailedAssert ("Module decoding should fail with failure string " ++ show failureString) assert Left _ -> return () - runAssert st _ assert@(AssertMalformed (RawModDef _ _) failureString) = return () - runAssert st pos assert@(AssertUnlinkable moduleDef failureString) = + runAssert assert@(AssertMalformed (RawModDef _ _) failureString) = return () + runAssert assert@(AssertUnlinkable moduleDef failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of Right m -> do - res <- Interpreter.instantiate (store st) (buildImports st) m + st <- fst <$> State.get + (res, _) <- liftIO $ Interpreter.instantiate (store st) (buildImports st) m case res of Left err -> return () - Right _ -> onAssertFail (pos ++ ": Module linking should fail with failure string " ++ show failureString) assert - Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason - runAssert st pos assert@(AssertTrap (Left action) failureString) = do - result <- runAction st action + Right _ -> printFailedAssert ("Module linking should fail with failure string " ++ show failureString) assert + Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason + runAssert assert@(AssertTrap (Left action) failureString) = do + result <- runActionInAssert action if isNothing result then return () - else onAssertFail (pos ++ ":Expected trap, but action returned " ++ show (fromJust result)) assert - runAssert st pos assert@(AssertTrap (Right moduleDef) failureString) = + else printFailedAssert ("Expected trap, but action returned " ++ show (fromJust result)) assert + runAssert assert@(AssertTrap (Right moduleDef) failureString) = let (_, m) = buildModule moduleDef in case Validate.validate m of Right m -> do - res <- Interpreter.instantiate (store st) (buildImports st) m + st <- fst <$> State.get + (res, store') <- liftIO $ Interpreter.instantiate (store st) (buildImports st) m case res of - Left "Start function terminated with trap" -> return () - _ -> onAssertFail (pos ++ ": Module linking should fail with trap during execution of a start function") assert - Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason - runAssert st pos assert@(AssertExhaustion action failureString) = do - result <- runAction st action + Left "Start function terminated with trap" -> + State.modify $ \(st, pos) -> (st { store = store' }, pos) + _ -> printFailedAssert ("Module linking should fail with trap during execution of a start function") assert + Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason + runAssert assert@(AssertExhaustion action failureString) = do + result <- runActionInAssert action if isNothing result then return () - else onAssertFail (pos ++ ": Expected exhaustion, but action returned " ++ show (fromJust result)) assert + else printFailedAssert ("Expected exhaustion, but action returned " ++ show (fromJust result)) assert runCommand :: ScriptState -> Command -> IO ScriptState runCommand st (ModuleDef moduleDef) = @@ -253,5 +271,6 @@ runScript onAssertFail script = do addModule ident m st runCommand st (Register name i) = return $ addToRegistery name i st runCommand st (Action action) = runAction st action >> return st - runCommand st (Assertion pos assertion) = runAssert st ("Line " ++ show pos) assertion >> return st + runCommand st (Assertion pos assertion) = do + fst <$> flip State.execStateT (st, ("Line " ++ show pos)) (runAssert assertion) runCommand st _ = return st diff --git a/tests/Test.hs b/tests/Test.hs index 409d653..f66b65f 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 = ["global.wast"] + -- let files = ["linking.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do