validate and interprete bulk memory instructions

src/Language/Wasm/Interpreter.hs

@@ -920,6 +920,48 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
                     else return $ -1
                 )
             return $ Done ctx { stack = VI32 (asWord32 $ fromIntegral result) : rest }
+        step ctx@EvalCtx{ stack = (VI32 n:VI32 v:VI32 d:rest) } MemoryFill = do
+            let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
+            memory <- readIORef memoryRef
+            size <- ByteArray.getSizeofMutableByteArray memory
+            let dest = fromIntegral d
+            let len = fromIntegral n
+            if dest + len > size
+            then return Trap
+            else do
+                ByteArray.setByteArray @Word8 memory dest len $ fromIntegral v
+                return $ Done ctx { stack = rest }
+        step ctx@EvalCtx{ stack = (VI32 n:VI32 s:VI32 d:rest) } MemoryCopy = do
+            let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
+            memory <- readIORef memoryRef
+            size <- ByteArray.getSizeofMutableByteArray memory
+            let src = fromIntegral s
+            let dest = fromIntegral d
+            let len = fromIntegral n
+            if dest + len > size || src + len > size
+            then return Trap
+            else do
+                ByteArray.copyMutableByteArray memory dest memory src len
+                return $ Done ctx { stack = rest }
+        step ctx@EvalCtx{ stack = (VI32 n:VI32 s:VI32 d:rest) } (MemoryInit dataIdx) = do
+            let DataInstance {bytes, isDropped} = dataInstances store ! (dataaddrs moduleInstance ! fromIntegral dataIdx)
+            let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
+            memory <- readIORef memoryRef
+            size <- fromIntegral <$> ByteArray.getSizeofMutableByteArray memory
+            let src = fromIntegral s
+            let dest = fromIntegral d
+            let len = fromIntegral n
+            dropped <- readIORef isDropped
+            if dropped || src + len > LBS.length bytes || dest + len > size
+            then return Trap
+            else do
+                mapM_ (uncurry $ ByteArray.writeByteArray memory) $ zip [fromIntegral d..] $
+                    LBS.unpack $ LBS.take len $ LBS.drop src bytes
+                return $ Done ctx { stack = rest }
+        step ctx (DataDrop dataIdx) = do
+            let DataInstance {isDropped} = dataInstances store ! (dataaddrs moduleInstance ! fromIntegral dataIdx)
+            writeIORef isDropped True
+            return $ Done ctx
         step ctx@EvalCtx{ stack = (VI32 n:VI32 s:VI32 d:rest) } (TableInit tableIdx elemIdx) = do
             let tableAddr = tableaddrs moduleInstance ! fromIntegral tableIdx
             let TableInstance { items } = tableInstances store ! tableAddr

src/Language/Wasm/Parser.y

@@ -906,10 +906,11 @@ memory_limits_export_import1 :: { Maybe Ident -> [ModuleField] }
     | 'data' datastring ')' ')' {
         \ident ->
             let m = fromIntegral $ LBS.length $2 in
+            let lim = if m `mod` 0x10000 == 0 then m `div` 0x10000 else m `div` 0x10000 + 1 in
             -- TODO: unhardcode memory index
             let memIdx = fromMaybe (Index 0) $ Named `fmap` ident in
             [
-                MFMem $ Memory [] ident $ Limit m $ Just m,
+                MFMem $ Memory [] ident $ Limit lim $ Just lim,
                 MFData $ DataSegment Nothing (ActiveData memIdx [PlainInstr $ I32Const 0]) $2
             ]
     }

src/Language/Wasm/Script.hs

@@ -194,6 +194,7 @@ runScript onAssertFail script = do
         getFailureString Validate.InvalidStartFunctionType = ["start function"]
         getFailureString Validate.InvalidTableType = ["size minimum must not be greater than maximum"]
         getFailureString (Validate.ElemIndexOutOfRange idx) = ["unknown elem segment " <> TL.pack (show idx)]
+        getFailureString (Validate.DataIndexOutOfRange idx) = ["unknown data segment", "unknown data segment " <> TL.pack (show idx)]
         getFailureString (Validate.UndeclaredFunctionRef _) = ["undeclared function reference"]
         getFailureString r = [TL.concat ["not implemented ", TL.pack $ show r]]
 

src/Language/Wasm/Validate.hs

@@ -38,6 +38,7 @@ data ValidationError =
     | LocalIndexOutOfRange Natural
     | GlobalIndexOutOfRange Natural
     | ElemIndexOutOfRange Natural
+    | DataIndexOutOfRange Natural
     | LabelIndexOutOfRange
     | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
@@ -142,6 +143,7 @@ data Ctx = Ctx {
     funcs :: [FuncType],
     tables :: [TableType],
     elems :: [ElemType],
+    datas :: [DataMode],
     mems :: [Limit],
     globals :: [GlobalType],
     locals :: [ValueType],
@@ -388,10 +390,29 @@ getInstrType (I64Store32 memarg) = do
     return $ [I32, I64] ==> empty
 getInstrType MemorySize = do
     Ctx { mems } <- ask 
-    if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return $ empty ==> I32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
+    return $ empty ==> I32
 getInstrType MemoryGrow = do
     Ctx { mems } <- ask
-    if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return $ I32 ==> I32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
+    return $ I32 ==> I32
+getInstrType MemoryFill = do
+    Ctx { mems } <- ask
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
+    return $ [I32, I32, I32] ==> empty
+getInstrType MemoryCopy = do
+    Ctx { mems } <- ask
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
+    return $ [I32, I32, I32] ==> empty
+getInstrType (MemoryInit dataIdx) = do
+    Ctx { mems, datas } <- ask
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
+    when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
+    return $ [I32, I32, I32] ==> empty
+getInstrType (DataDrop dataIdx) = do
+    Ctx { datas } <- ask
+    when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
+    return $ empty ==> empty
 getInstrType (TableInit tableIdx elemIdx) = do
     Ctx { tables, elems } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
@@ -563,7 +584,8 @@ getFuncTypes Module {types, functions, imports} =
         getFuncType _ = Nothing
 
 ctxFromModule :: [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
-ctxFromModule locals labels returns m@Module {types, tables, mems, globals, imports, elems, exports} =
+ctxFromModule locals labels returns m =
+    let Module {types, tables, mems, globals, imports, elems, exports, datas} = m in
     let tableImports = catMaybes $ map getTableType imports in
     let memsImports = catMaybes $ map getMemType imports in
     let globalImports = catMaybes $ map getGlobalType imports in
@@ -572,6 +594,7 @@ ctxFromModule locals labels returns m@Module {types, tables, mems, globals, impo
         funcs = getFuncTypes m,
         tables = tableImports ++ map (\(Table t) -> t) tables,
         elems = map elemType elems,
+        datas = map dataMode datas,
         mems = memsImports ++ map (\(Memory l) -> l) mems,
         globals = globalImports ++ map (\(Global g _) -> g) globals,
         locals,

tests/Test.hs

@@ -19,7 +19,7 @@ main = do
   files <-
     filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  let files = ["memory_init.wast"]
+  let files = ["bulk.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do