GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

reduce code duplication

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-25 11:16:41 -07:00
parent fc2eb97647
commit abc546723d
1 changed files with 48 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+48 -66
View File
@@ -330,7 +330,7 @@ emptyModInstance = ModuleInstance {
exports = Vector.empty exports = Vector.empty
} }
calcInstance :: Store -> Imports -> Module -> Either String ModuleInstance calcInstance :: Store -> Imports -> Module -> Initialize ModuleInstance
calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, globals, exports, imports} = do calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, globals, exports, imports} = do
let funLen = length fs let funLen = length fs
let tableLen = length ts let tableLen = length ts
@@ -362,28 +362,28 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl
exports = Vector.fromList $ map refExport exports exports = Vector.fromList $ map refExport exports
} }
where where
getImpIdx :: Import -> Either String ExternalValue getImpIdx :: Import -> Initialize ExternalValue
getImpIdx (Import m n _) = getImpIdx (Import m n _) =
case Map.lookup (m, n) imps of case Map.lookup (m, n) imps of
Just idx -> Right idx Just idx -> return idx
Nothing -> Left $ "Cannot find import from module " ++ show m ++ " with name " ++ show n Nothing -> throwError $ "Cannot find import from module " ++ show m ++ " with name " ++ show n
checkImportType :: Import -> Either String ExternalValue checkImportType :: Import -> Initialize ExternalValue
checkImportType imp@(Import _ _ (ImportFunc typeIdx)) = do checkImportType imp@(Import _ _ (ImportFunc typeIdx)) = do
idx <- getImpIdx imp idx <- getImpIdx imp
funcAddr <- case idx of funcAddr <- case idx of
ExternFunction funcAddr -> Right funcAddr ExternFunction funcAddr -> return funcAddr
other -> Left "incompatible import type" other -> throwError "incompatible import type"
let expectedType = types !! fromIntegral typeIdx let expectedType = types !! fromIntegral typeIdx
let actualType = Language.Wasm.Interpreter.funcType $ fs ! funcAddr let actualType = Language.Wasm.Interpreter.funcType $ fs ! funcAddr
if expectedType == actualType if expectedType == actualType
then Right idx then return idx
else Left "incompatible import type" else throwError "incompatible import type"
checkImportType imp@(Import _ _ (ImportGlobal globalType)) = do checkImportType imp@(Import _ _ (ImportGlobal globalType)) = do
let err = Left "incompatible import type" let err = throwError "incompatible import type"
idx <- getImpIdx imp idx <- getImpIdx imp
globalAddr <- case idx of globalAddr <- case idx of
ExternGlobal globalAddr -> Right globalAddr ExternGlobal globalAddr -> return globalAddr
_ -> err _ -> err
let globalInst = gs ! globalAddr let globalInst = gs ! globalAddr
let vt = case globalType of let vt = case globalType of
@@ -392,25 +392,25 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl
let vt' = case globalInst of let vt' = case globalInst of
GIConst vt _ -> vt GIConst vt _ -> vt
GIMut vt _ -> vt GIMut vt _ -> vt
if vt == vt' then Right idx else err if vt == vt' then return idx else err
checkImportType imp@(Import _ _ (ImportMemory limit)) = do checkImportType imp@(Import _ _ (ImportMemory limit)) = do
idx <- getImpIdx imp idx <- getImpIdx imp
memAddr <- case idx of memAddr <- case idx of
ExternMemory memAddr -> Right memAddr ExternMemory memAddr -> return memAddr
_ -> Left "incompatible import type" _ -> throwError "incompatible import type"
let MemoryInstance { lim } = ms ! memAddr let MemoryInstance { lim } = ms ! memAddr
if limitMatch lim limit if limitMatch lim limit
then Right idx then return idx
else Left "incompatible import type" else throwError "incompatible import type"
checkImportType imp@(Import _ _ (ImportTable (TableType limit _))) = do checkImportType imp@(Import _ _ (ImportTable (TableType limit _))) = do
idx <- getImpIdx imp idx <- getImpIdx imp
tableAddr <- case idx of tableAddr <- case idx of
ExternTable tableAddr -> Right tableAddr ExternTable tableAddr -> return tableAddr
_ -> Left "incompatible import type" _ -> throwError "incompatible import type"
let TableInstance { lim } = ts ! tableAddr let TableInstance { lim } = ts ! tableAddr
if limitMatch lim limit if limitMatch lim limit
then Right idx then return idx
else Left "incompatible import type" else throwError "incompatible import type"
limitMatch :: Limit -> Limit -> Bool limitMatch :: Limit -> Limit -> Bool
limitMatch (Limit n1 m1) (Limit n2 m2) = n1 >= n2 && (isNothing m2 || fromMaybe False ((<=) <$> m1 <*> m2)) limitMatch (Limit n1 m1) (Limit n2 m2) = n1 >= n2 && (isNothing m2 || fromMaybe False ((<=) <$> m1 <*> m2))
@@ -490,10 +490,10 @@ type Initialize = ExceptT String IO
initialize :: ModuleInstance -> Module -> Store -> Initialize Store initialize :: ModuleInstance -> Module -> Store -> Initialize Store
initialize inst Module {elems, datas, start} store = do initialize inst Module {elems, datas, start} store = do
checkedMems <- Monad.foldM checkData store datas checkedMems <- mapM (checkData store) datas
checkedTables <- Monad.foldM checkElem checkedMems elems checkedTables <- mapM (checkElem store) elems
storeWithTables <- Monad.foldM initElem checkedMems elems mapM_ initData checkedMems
st <- Monad.foldM initData storeWithTables datas st <- Monad.foldM initElem store checkedTables
case start of case start of
Just (StartFunction idx) -> do Just (StartFunction idx) -> do
let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx) let funInst = funcInstances store ! (funcaddrs inst ! fromIntegral idx)
@@ -503,7 +503,7 @@ initialize inst Module {elems, datas, start} store = do
_ -> throwError "Start function terminated with trap" _ -> throwError "Start function terminated with trap"
Nothing -> return st Nothing -> return st
where where
checkElem :: Store -> ElemSegment -> Initialize Store checkElem :: Store -> ElemSegment -> Initialize (Address, Int, [Address])
checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do checkElem st ElemSegment {tableIndex, offset, funcIndexes} = do
VI32 val <- liftIO $ evalConstExpr inst st offset VI32 val <- liftIO $ evalConstExpr inst st offset
let from = fromIntegral val let from = fromIntegral val
@@ -514,24 +514,15 @@ initialize inst Module {elems, datas, start} store = do
let len = Vector.length elems let len = Vector.length elems
if last > len if last > len
then throwError "elements segment does not fit" then throwError "elements segment does not fit"
else return st else return (idx, from, funcs)
initElem :: Store -> ElemSegment -> Initialize Store initElem :: Store -> (Address, Int, [Address]) -> Initialize Store
initElem st ElemSegment {tableIndex, offset, funcIndexes} = do initElem st (idx, from, funcs) = 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
let last = from + length funcs
let TableInstance lim elems = tableInstances st ! idx let TableInstance lim elems = tableInstances st ! idx
let len = Vector.length elems let table = TableInstance lim (elems // zip [from..] (map Just funcs))
if last > len return st { tableInstances = tableInstances st Vector.// [(idx, table)] }
then throwError "elements segment does not fit"
else do
let table = TableInstance lim (elems // zip [from..] (map Just funcs))
return st { tableInstances = tableInstances st Vector.// [(idx, table)] }
checkData :: Store -> DataSegment -> Initialize Store checkData :: Store -> DataSegment -> Initialize (Int, IOVector Word8, LBS.ByteString)
checkData st DataSegment {memIndex, offset, chunk} = do checkData st DataSegment {memIndex, offset, chunk} = do
VI32 val <- liftIO $ evalConstExpr inst st offset VI32 val <- liftIO $ evalConstExpr inst st offset
let from = fromIntegral val let from = fromIntegral val
@@ -542,35 +533,26 @@ initialize inst Module {elems, datas, start} store = do
let len = IOVector.length mem let len = IOVector.length mem
if last > len if last > len
then throwError "data segment does not fit" then throwError "data segment does not fit"
else return st else return (from, mem, chunk)
initData :: Store -> DataSegment -> Initialize Store initData :: (Int, IOVector Word8, LBS.ByteString) -> Initialize ()
initData st DataSegment {memIndex, offset, chunk} = do initData (from, mem, chunk) =
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 <- liftIO $ readIORef memory
mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk mapM_ (\(i,b) -> IOVector.write mem i b) $ zip [from..] $ LBS.unpack chunk
return st
instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store)) instantiate :: Store -> Imports -> Module -> IO (Either String (ModuleInstance, Store))
instantiate st imps m = instantiate st imps m = runExceptT $ do
case calcInstance st imps m of inst <- calcInstance st imps m
Left err -> return $ Left err let functions = funcInstances st <> (allocFunctions inst $ Struct.functions m)
Right inst -> do globals <- liftIO $ (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m)
let functions = funcInstances st <> (allocFunctions inst $ Struct.functions m) let tables = tableInstances st <> (allocTables $ Struct.tables m)
globals <- (globalInstances st <>) <$> (allocAndInitGlobals inst st $ Struct.globals m) mems <- liftIO $ (memInstances st <>) <$> (allocMems $ Struct.mems m)
let tables = tableInstances st <> (allocTables $ Struct.tables m) st' <- initialize inst m $ st {
mems <- (memInstances st <>) <$> (allocMems $ Struct.mems m) funcInstances = functions,
st' <- runExceptT $ initialize inst m $ st { tableInstances = tables,
funcInstances = functions, memInstances = mems,
tableInstances = tables, globalInstances = globals
memInstances = mems, }
globalInstances = globals return $ (inst, st')
}
return $ (,) inst <$> st'
type Stack = [Value] type Stack = [Value]