diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 8c7e788..29bafed 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -50,6 +50,8 @@ import Data.Bits ( countTrailingZeros ) 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 @@ -484,28 +486,26 @@ allocMems mems = Vector.fromList <$> mapM allocMem mems memory } -initialize :: ModuleInstance -> Module -> Store -> IO (Either String Store) +type Initialize = ExceptT String IO + +initialize :: ModuleInstance -> Module -> Store -> Initialize Store initialize inst Module {elems, datas, start} store = do - checkedMems <- Monad.foldM checkData (Right store) datas + checkedMems <- Monad.foldM checkData store datas checkedTables <- Monad.foldM checkElem checkedMems elems storeWithTables <- Monad.foldM initElem checkedMems elems - storeWithMems <- Monad.foldM initData storeWithTables datas - case storeWithMems of - Right st -> do - case start of - Just (StartFunction idx) -> do - let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) - mainRes <- eval defaultBudget st funInst [] - case mainRes of - Just [] -> return $ Right st - _ -> return $ Left "Start function terminated with trap" - Nothing -> return $ Right st - Left reason -> return $ Left reason + st <- Monad.foldM initData storeWithTables datas + case start of + Just (StartFunction idx) -> do + let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) + mainRes <- liftIO $ eval defaultBudget st funInst [] + case mainRes of + Just [] -> return st + _ -> throwError "Start function terminated with trap" + Nothing -> return st where - checkElem :: Either String Store -> ElemSegment -> IO (Either String Store) - checkElem (Left err) _ = return $ Left err - checkElem (Right st) ElemSegment {tableIndex, offset, funcIndexes} = do - VI32 val <- evalConstExpr inst st offset + checkElem :: Store -> ElemSegment -> Initialize Store + checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do + VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let funcs = map ((funcaddrs inst !) . fromIntegral) funcIndexes let idx = tableaddrs inst ! fromIntegral tableIndex @@ -513,13 +513,12 @@ initialize inst Module {elems, datas, start} store = do let TableInstance lim elems = tableInstances st ! idx let len = Vector.length elems if last > len - then return $ Left "elements segment does not fit" - else return $ Right st + then throwError "elements segment does not fit" + else return st - initElem :: Either String Store -> ElemSegment -> IO (Either String Store) - initElem (Left err) _ = return $ Left err - initElem (Right st) ElemSegment {tableIndex, offset, funcIndexes} = do - VI32 val <- evalConstExpr inst st offset + initElem :: Store -> ElemSegment -> Initialize Store + initElem st ElemSegment {tableIndex, offset, funcIndexes} = do + VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let funcs = map ((funcaddrs inst !) . fromIntegral) funcIndexes let idx = tableaddrs inst ! fromIntegral tableIndex @@ -527,36 +526,34 @@ initialize inst Module {elems, datas, start} store = do let TableInstance lim elems = tableInstances st ! idx let len = Vector.length elems if last > len - then return $ Left "elements segment does not fit" + then throwError "elements segment does not fit" else do let table = TableInstance lim (elems // zip [from..] (map Just funcs)) - return $ Right st { tableInstances = tableInstances st Vector.// [(idx, table)] } + return st { tableInstances = tableInstances st Vector.// [(idx, table)] } - checkData :: Either String Store -> DataSegment -> IO (Either String Store) - checkData (Left err) _ = return $ Left err - checkData (Right st) DataSegment {memIndex, offset, chunk} = do - VI32 val <- evalConstExpr inst st offset + checkData :: Store -> DataSegment -> Initialize Store + checkData st DataSegment {memIndex, offset, chunk} = do + VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let idx = memaddrs inst ! fromIntegral memIndex let last = from + (fromIntegral $ LBS.length chunk) let MemoryInstance _ memory = memInstances st ! idx - mem <- readIORef memory + mem <- liftIO $ readIORef memory let len = IOVector.length mem if last > len - then return $ Left "data segment does not fit" - else return $ Right st + then throwError "data segment does not fit" + else return st - initData :: Either String Store -> DataSegment -> IO (Either String Store) - initData (Left err) _ = return $ Left err - initData (Right st) DataSegment {memIndex, offset, chunk} = do - VI32 val <- evalConstExpr inst st offset + initData :: Store -> DataSegment -> Initialize Store + initData st DataSegment {memIndex, offset, chunk} = do + VI32 val <- liftIO $ evalConstExpr inst st offset let from = fromIntegral val let idx = memaddrs inst ! fromIntegral memIndex let last = from + (fromIntegral $ LBS.length chunk) let MemoryInstance _ memory = memInstances st ! idx - mem <- readIORef memory + mem <- liftIO $ readIORef memory mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk - return $ Right st + return st instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store)) instantiate st imps m = @@ -567,7 +564,7 @@ instantiate st imps m = globals <- (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m) let tables = tableInstances st <> (allocTables $ Struct.tables m) mems <- (memInstances st <>) <$> (allocMems $ Struct.mems m) - st' <- initialize inst m $ st { + st' <- runExceptT $ initialize inst m $ st { funcInstances = functions, tableInstances = tables, memInstances = mems,