msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

use ExceptT transformer to clarify interpreter code

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-25 10:49:58 -07:00
parent 70f207d02d
commit fc2eb97647
1 changed files with 37 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+37 -40
View File
@@ -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,