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

change instansiating to be stateful

Browse Source
This commit is contained in:
Ilya Rezvov
2021-03-12 22:34:42 -08:00
parent 01e0ab8d44
commit 1e7afd94fc
3 changed files with 87 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+27 -22
View File
@@ -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]
src/Language/Wasm/Script.hs
+59 -40
View File
@@ -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