diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 2f8654e..e9e9e64 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -916,6 +916,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 diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index ff31ac5..79a00ab 100644 --- a/src/Language/Wasm/Parser.y +++ b/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 ] } diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 44cc990..078b4e6 100644 --- a/src/Language/Wasm/Script.hs +++ b/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]] diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index e9ff636..dbd34f4 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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, diff --git a/tests/Test.hs b/tests/Test.hs index 9b5e61c..6baa8df 100644 --- a/tests/Test.hs +++ b/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