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

parse memory instructions

Browse Source
This commit is contained in:
Ilya Rezvov
2022-06-10 22:29:31 -06:00
parent 2d4ad42549
commit 46f95dd11d
7 changed files with 73 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Binary.hs
+4 -4
View File
@@ -399,8 +399,8 @@ instance Serialize (Instruction Natural) where
put (I64Store8 memArg) = putWord8 0x3C >> put memArg
put (I64Store16 memArg) = putWord8 0x3D >> put memArg
put (I64Store32 memArg) = putWord8 0x3E >> put memArg
put CurrentMemory = putWord8 0x3F >> putWord8 0x00
put GrowMemory = putWord8 0x40 >> putWord8 0x00
put MemorySize = putWord8 0x3F >> putWord8 0x00
put MemoryGrow = putWord8 0x40 >> putWord8 0x00
-- Numeric instructions
put (I32Const val) = putWord8 0x41 >> putSLEB128 (asInt32 val)
put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val)
@@ -600,8 +600,8 @@ instance Serialize (Instruction Natural) where
0x3C -> I64Store8 <$> get
0x3D -> I64Store16 <$> get
0x3E -> I64Store32 <$> get
0x3F -> byteGuard 0x00 >> (return $ CurrentMemory)
0x40 -> byteGuard 0x00 >> (return $ GrowMemory)
0x3F -> byteGuard 0x00 >> (return $ MemorySize)
0x40 -> byteGuard 0x00 >> (return $ MemoryGrow)
-- Numeric instructions
0x41 -> I32Const <$> getSLEB128 32
0x42 -> I64Const <$> getSLEB128 64
src/Language/Wasm/Builder.hs
+2 -2
View File
@@ -643,10 +643,10 @@ store32 addr val offset align = do
appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)]
memorySize :: GenFun (Proxy I32)
memorySize = appendExpr [CurrentMemory] >> return Proxy
memorySize = appendExpr [MemorySize] >> return Proxy
growMemory :: (Producer size, OutType size ~ Proxy I32) => size -> GenFun ()
growMemory size = produce size >> appendExpr [GrowMemory]
growMemory size = produce size >> appendExpr [MemoryGrow]
call :: (Returnable res) => Fn res -> [GenFun a] -> GenFun res
call (Fn idx) args = sequence_ args >> appendExpr [Call idx] >> return returnableValue
src/Language/Wasm/Interpreter.hs
+20 -13
View File
@@ -233,7 +233,11 @@ isDeclarative :: ElemMode -> Bool
isDeclarative Declarative = True
isDeclarative _ = False
data DataInstance = DataInstance
data DataInstance = DataInstance {
dMode :: DataMode,
isDropped :: IORef Bool,
bytes :: LBS.ByteString
}
data Store = Store {
funcInstances :: Vector FunctionInstance,
@@ -523,8 +527,10 @@ allocElems inst st = fmap Vector.fromList . mapM allocElem
ElemInstance mode t (Vector.fromList indexes)
<$> newIORef False -- is dropped
allocDatas :: ModuleInstance -> Store -> [DataSegment] -> Vector DataInstance
allocDatas _inst _st = Vector.fromList . map (const DataInstance)
allocDatas :: [DataSegment] -> IO (Vector DataInstance)
allocDatas datas = Vector.fromList <$> Monad.forM datas (\DataSegment {dataMode, chunk} -> do
isDropped <- newIORef False
return $ DataInstance dataMode isDropped chunk)
type Initialize = ExceptT String (State.StateT Store IO)
@@ -574,7 +580,7 @@ initialize inst Module {elems, datas, start} = do
liftIO $ writeIORef isDropped True
Monad.forM_ (zip [from..] funcs) $ uncurry $ MVector.unsafeWrite elems
checkData :: DataSegment -> Initialize (Int, MemoryStore, LBS.ByteString)
checkData :: DataSegment -> Initialize (Maybe (Int, MemoryStore, LBS.ByteString))
checkData DataSegment {dataMode = ActiveData memIndex offset, chunk} = do
st <- State.get
VI32 val <- liftIO $ evalConstExpr inst st offset
@@ -584,13 +590,14 @@ initialize inst Module {elems, datas, start} = do
let MemoryInstance _ memory = memInstances st ! idx
mem <- liftIO $ readIORef memory
len <- ByteArray.getSizeofMutableByteArray mem
Monad.when (last > len) $ throwError "data segment does not fit"
return (from, mem, chunk)
checkData DataSegment {dataMode = ActiveData memIndex offset, chunk} =
error "passive data segments are not implemented yet"
Monad.when (last > len) $ throwError "out of bounds memory access"
return $ Just (from, mem, chunk)
checkData DataSegment {dataMode = PassiveData, chunk} =
return Nothing
initData :: (Int, MemoryStore, LBS.ByteString) -> Initialize ()
initData (from, mem, chunk) =
initData :: Maybe (Int, MemoryStore, LBS.ByteString) -> Initialize ()
initData Nothing = return ()
initData (Just (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)
@@ -602,7 +609,7 @@ instantiate st imps mod = flip State.runStateT st $ runExceptT $ do
tables <- (tableInstances st <>) <$> liftIO (allocTables (Struct.tables m))
mems <- liftIO $ (memInstances st <>) <$> allocMems (Struct.mems m)
elems <- liftIO $ (elemInstances st <>) <$> allocElems inst st (Struct.elems m)
let datas = dataInstances st <> allocDatas inst st (Struct.datas m)
datas <- liftIO $ (dataInstances st <>) <$> allocDatas (Struct.datas m)
State.put $ st {
funcInstances = functions,
tableInstances = tables,
@@ -890,12 +897,12 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
makeStoreInstr @Word16 ctx { stack = rest } offset 2 $ fromIntegral v
step ctx@EvalCtx{ stack = (VI64 v:rest) } (I64Store32 MemArg { offset }) =
makeStoreInstr @Word32 ctx { stack = rest } offset 4 $ fromIntegral v
step ctx@EvalCtx{ stack = st } CurrentMemory = do
step ctx@EvalCtx{ stack = st } MemorySize = do
let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
memory <- readIORef memoryRef
size <- ((`quot` pageSize) . fromIntegral) <$> ByteArray.getSizeofMutableByteArray memory
return $ Done ctx { stack = VI32 (fromIntegral size) : st }
step ctx@EvalCtx{ stack = (VI32 n:rest) } GrowMemory = do
step ctx@EvalCtx{ stack = (VI32 n:rest) } MemoryGrow = do
let MemoryInstance { lim = limit@(Limit _ maxLen), memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
memory <- readIORef memoryRef
size <- (`quot` pageSize) <$> ByteArray.getSizeofMutableByteArray memory
src/Language/Wasm/Parser.y
+37 -6
View File
@@ -168,6 +168,10 @@ import Language.Wasm.Lexer (
'i64.store32' { Lexeme _ (TKeyword "i64.store32") }
'memory.size' { Lexeme _ (TKeyword "memory.size") }
'memory.grow' { Lexeme _ (TKeyword "memory.grow") }
'memory.fill' { Lexeme _ (TKeyword "memory.fill") }
'memory.copy' { Lexeme _ (TKeyword "memory.copy") }
'memory.init' { Lexeme _ (TKeyword "memory.init") }
'data.drop' { Lexeme _ (TKeyword "data.drop") }
'table.init' { Lexeme _ (TKeyword "table.init") }
'table.copy' { Lexeme _ (TKeyword "table.copy") }
'table.fill' { Lexeme _ (TKeyword "table.fill") }
@@ -472,8 +476,12 @@ plaininstr :: { PlainInstr }
| 'i64.store8' memarg1 { I64Store8 $2 }
| 'i64.store16' memarg2 { I64Store16 $2 }
| 'i64.store32' memarg4 { I64Store32 $2 }
| 'memory.size' { CurrentMemory }
| 'memory.grow' { GrowMemory }
| 'memory.size' { MemorySize }
| 'memory.grow' { MemoryGrow }
| 'memory.fill' { MemoryFill }
| 'memory.copy' { MemoryCopy }
| 'memory.init' index { MemoryInit $2 }
| 'data.drop' index { DataDrop $2 }
-- table instructions
| 'table.init' index opt(index) {
case $3 of
@@ -1268,8 +1276,12 @@ data PlainInstr =
| I64Store8 MemArg
| I64Store16 MemArg
| I64Store32 MemArg
| CurrentMemory
| GrowMemory
| MemorySize
| MemoryGrow
| MemoryFill
| MemoryCopy
| MemoryInit DataIndex
| DataDrop DataIndex
-- Table instructions
| TableInit TableIndex ElemIndex
| TableGrow TableIndex
@@ -1757,8 +1769,18 @@ desugarize fields = do
synInstrToStruct _ (PlainInstr (I64Store8 memArg)) = return $ S.I64Store8 memArg
synInstrToStruct _ (PlainInstr (I64Store16 memArg)) = return $ S.I64Store16 memArg
synInstrToStruct _ (PlainInstr (I64Store32 memArg)) = return $ S.I64Store32 memArg
synInstrToStruct _ (PlainInstr CurrentMemory) = return $ S.CurrentMemory
synInstrToStruct _ (PlainInstr GrowMemory) = return $ S.GrowMemory
synInstrToStruct _ (PlainInstr MemorySize) = return $ S.MemorySize
synInstrToStruct _ (PlainInstr MemoryGrow) = return $ S.MemoryGrow
synInstrToStruct _ (PlainInstr MemoryFill) = return $ S.MemoryFill
synInstrToStruct _ (PlainInstr MemoryCopy) = return $ S.MemoryCopy
synInstrToStruct FunCtx { ctxMod } (PlainInstr (MemoryInit dataIdx)) =
case getDataIndex ctxMod dataIdx of
Just dataIdx -> return $ S.MemoryInit dataIdx
Nothing -> Left "unknown data"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (DataDrop dataIdx)) =
case getDataIndex ctxMod dataIdx of
Just dataIdx -> return $ S.DataDrop dataIdx
Nothing -> Left "unknown data"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableInit tableIdx elemIdx)) =
case getTableIndex ctxMod tableIdx of
Just tableIdx ->
@@ -2120,6 +2142,15 @@ desugarize fields = do
extractDataSegment datas (MFData dataSegment) = dataSegment : datas
extractDataSegment datas _ = datas
getDataIndex :: Module -> GlobalIndex -> Maybe Natural
getDataIndex mod@Module { datas } (Named id) =
let isIdent (_, DataSegment { ident }) = ident == Just id in
let dataIndexes = map fst $ filter isIdent $ zip [0..] datas in
case dataIndexes of
[idx] -> return idx
_ -> Nothing
getDataIndex _ (Index idx) = Just idx
-- start
synStartToStruct :: Module -> StartFunction -> S.StartFunction
synStartToStruct mod (StartFunction funIdx) =
src/Language/Wasm/Structure.hs
+6 -2
View File
@@ -178,8 +178,12 @@ data Instruction index =
| I64Store8 MemArg
| I64Store16 MemArg
| I64Store32 MemArg
| CurrentMemory
| GrowMemory
| MemorySize
| MemoryGrow
| MemoryFill
| MemoryCopy
| MemoryInit DataIndex
| DataDrop DataIndex
-- Table instructions
| TableInit TableIndex ElemIndex
| TableGrow TableIndex
src/Language/Wasm/Validate.hs
+3 -2
View File
@@ -386,10 +386,10 @@ getInstrType (I64Store16 memarg) = do
getInstrType (I64Store32 memarg) = do
checkMemoryInstr 4 memarg
return $ [I32, I64] ==> empty
getInstrType CurrentMemory = do
getInstrType MemorySize = do
Ctx { mems } <- ask
if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return $ empty ==> I32
getInstrType GrowMemory = do
getInstrType MemoryGrow = do
Ctx { mems } <- ask
if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return $ I32 ==> I32
getInstrType (TableInit tableIdx elemIdx) = do
@@ -712,6 +712,7 @@ datasShouldBeValid m@Module { datas, mems, imports } =
if memIdx < (fromIntegral $ length memImports + length mems)
then check
else Left (MemoryIndexOutOfRange memIdx)
isDataValid ctx (DataSegment PassiveData _) = return ()
startShouldBeValid :: Validator
startShouldBeValid Module { start = Nothing } = return ()
tests/Test.hs
+1 -1
View File
@@ -19,7 +19,7 @@ main = do
files <-
filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
<$> Directory.listDirectory "tests/spec"
let files = ["data.wast"]
let files = ["memory_init.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do