change instansiating to be stateful

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 :: ModuleInstance -> Module -> Initialize ()
-initialize inst Module {elems, datas, start} store = do
+initialize inst Module {elems, datas, start} = do
-    checkedMems <- mapM (checkData store) datas
+    checkedMems <- mapM checkData datas
-    checkedTables <- mapM (checkElem store) elems
+    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 :: ElemSegment -> Initialize (Address, Int, [Address])
-        checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do
+        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 :: (Address, Int, [Address]) -> Initialize ()
-        initElem st (idx, from, funcs) = do
+        initElem (idx, from, funcs) = State.modify $ \st ->
-            let TableInstance lim elems = tableInstances st ! idx
+            let TableInstance lim elems = tableInstances st ! idx in
-            let table = TableInstance lim (elems // zip [from..] (map Just funcs))
+            let table = TableInstance lim (elems // zip [from..] (map Just funcs)) in
-            return st { tableInstances = tableInstances st Vector.// [(idx, table)] }
+            st { tableInstances = tableInstances st Vector.// [(idx, table)] }
 
-        checkData :: Store -> DataSegment -> Initialize (Int, MemoryStore, LBS.ByteString)
+        checkData :: DataSegment -> Initialize (Int, MemoryStore, LBS.ByteString)
-        checkData st DataSegment {memIndex, offset, chunk} = do
+        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 :: Store -> Imports -> Valid.ValidModule -> IO (Either String ModuleInstance, Store)
-instantiate st imps mod = runExceptT $ do
+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]
 

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 :: Action -> Assertion -> AssertM ()
-        isNaNReturned st pos action assert = do
+        isNaNReturned action assert = do
-            result <- runAction st action
+            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
+                    else printFailedAssert ("Expected NaN, but action returned " ++ show v) assert
-                _ -> onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show result) 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 ()
+        printFailedAssert :: String -> Assertion -> AssertM ()
-        runAssert st pos assert@(AssertReturn action expected) = do
+        printFailedAssert msg assert = do
-            result <- runAction st action
+            (_, 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
+                    else printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
-                Nothing -> onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
+                Nothing -> printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
-        runAssert st pos assert@(AssertReturnCanonicalNaN action) = isNaNReturned st pos action assert
+        runAssert assert@(AssertReturnCanonicalNaN action) = isNaNReturned action assert
-        runAssert st pos assert@(AssertReturnArithmeticNaN action) = isNaNReturned st pos action assert
+        runAssert assert@(AssertReturnArithmeticNaN action) = isNaNReturned action assert
-        runAssert st pos assert@(AssertInvalid moduleDef failureString) =
+        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
+                        in printFailedAssert msg assert
-        runAssert st pos assert@(AssertMalformed (TextModDef _ textRep) failureString) =
+        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 assert@(AssertMalformed (RawModDef _ _) failureString) = return ()
-        runAssert st pos assert@(AssertUnlinkable moduleDef failureString) =
+        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
+                        Right _ -> printFailedAssert ("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
+                Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
-        runAssert st pos assert@(AssertTrap (Left action) failureString) = do
+        runAssert assert@(AssertTrap (Left action) failureString) = do
-            result <- runAction st action
+            result <- runActionInAssert action
             if isNothing result
             then return ()
-            else onAssertFail (pos ++ ":Expected trap, but action returned " ++ show (fromJust result)) assert
+            else printFailedAssert ("Expected trap, but action returned " ++ show (fromJust result)) assert
-        runAssert st pos assert@(AssertTrap (Right moduleDef) failureString) =
+        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 ()
+                        Left "Start function terminated with trap" ->
-                        _ -> onAssertFail (pos ++ ": Module linking should fail with trap during execution of a start function") assert
+                            State.modify $ \(st, pos) -> (st { store = store' }, pos)
-                Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason
+                        _ -> printFailedAssert ("Module linking should fail with trap during execution of a start function") assert
-        runAssert st pos assert@(AssertExhaustion action failureString) = do
+                Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
-            result <- runAction st action
+        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

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