From f23dc20d5738503a750dfebccc863b4ecbe085d2 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sun, 20 Aug 2023 21:00:46 -0600 Subject: [PATCH] fix more tests --- src/Language/Wasm/Binary.hs | 90 +++++++++++++++++++++++++++++--- src/Language/Wasm/Interpreter.hs | 27 +++++----- src/Language/Wasm/Script.hs | 6 ++- stack.yaml | 2 +- tests/Test.hs | 2 +- wasm.cabal | 2 +- 6 files changed, 102 insertions(+), 27 deletions(-) diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index da90919..64ccc62 100644 --- a/src/Language/Wasm/Binary.hs +++ b/src/Language/Wasm/Binary.hs @@ -366,15 +366,49 @@ instance Serialize (Instruction Natural) where put Return = putWord8 0x0F put (Call funcIdx) = putWord8 0x10 >> putULEB128 funcIdx put (CallIndirect tableIdx typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putULEB128 tableIdx + -- Reference instructions + put (RefNull refType) = putWord8 0xD0 >> put refType + put RefIsNull = putWord8 0xD1 + put (RefFunc index) = putWord8 0xD2 >> putULEB128 index -- Parametric instructions put Drop = putWord8 0x1A - put (Select _) = putWord8 0x1B + put (Select Nothing) = putWord8 0x1B + put (Select (Just types)) = putWord8 0x1C >> putVec types -- Variable instructions put (GetLocal idx) = putWord8 0x20 >> putULEB128 idx put (SetLocal idx) = putWord8 0x21 >> putULEB128 idx put (TeeLocal idx) = putWord8 0x22 >> putULEB128 idx put (GetGlobal idx) = putWord8 0x23 >> putULEB128 idx put (SetGlobal idx) = putWord8 0x24 >> putULEB128 idx + -- Table instructions + put (TableGet idx) = putWord8 0x25 >> putULEB128 idx + put (TableSet idx) = putWord8 0x26 >> putULEB128 idx + put (TableInit tableIdx elemIdx) = do + putWord8 0xFC + putULEB128 (0x0C :: Word32) + putULEB128 tableIdx + putULEB128 elemIdx + put (ElemDrop elemIdx) = do + putWord8 0xFC + putULEB128 (0x0D :: Word32) + putULEB128 elemIdx + put (TableCopy fromIdx toIdx) = do + putWord8 0xFC + putULEB128 (0x0E :: Word32) + putULEB128 fromIdx + putULEB128 toIdx + put (TableGrow tableIdx) = do + putWord8 0xFC + putULEB128 (0x0F :: Word32) + putULEB128 tableIdx + put (TableSize tableIdx) = do + putWord8 0xFC + putULEB128 (0x10 :: Word32) + putULEB128 tableIdx + put (TableFill tableIdx) = do + putWord8 0xFC + putULEB128 (0x11 :: Word32) + putULEB128 tableIdx -- Memory instructions put (I32Load memArg) = putWord8 0x28 >> put memArg put (I64Load memArg) = putWord8 0x29 >> put memArg @@ -401,6 +435,24 @@ instance Serialize (Instruction Natural) where put (I64Store32 memArg) = putWord8 0x3E >> put memArg put MemorySize = putWord8 0x3F >> putWord8 0x00 put MemoryGrow = putWord8 0x40 >> putWord8 0x00 + put (MemoryInit dataIdx) = do + putWord8 0xFC + putULEB128 (0x08 :: Word32) + putULEB128 dataIdx + putWord8 0 + put (DataDrop dataIdx) = do + putWord8 0xFC + putULEB128 (0x09 :: Word32) + putULEB128 dataIdx + put MemoryCopy = do + putWord8 0xFC + putULEB128 (0x0A :: Word32) + putWord8 0 + putWord8 0 + put MemoryFill = do + putWord8 0xFC + putULEB128 (0x0B :: Word32) + putWord8 0 -- Numeric instructions put (I32Const val) = putWord8 0x41 >> putSLEB128 (asInt32 val) put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val) @@ -567,6 +619,10 @@ instance Serialize (Instruction Natural) where typeIdx <- getULEB128 32 tableIdx <- getULEB128 32 return $ CallIndirect tableIdx typeIdx + -- Reference instructions + 0xD0 -> RefNull <$> get + 0xD1 -> return RefIsNull + 0xD2 -> RefFunc <$> getULEB128 32 -- Parametric instructions 0x1A -> return $ Drop 0x1B -> return $ Select Nothing @@ -747,7 +803,7 @@ instance Serialize (Instruction Natural) where 0x06 -> return $ ITruncSatFS BS64 BS64 0x07 -> return $ ITruncSatFU BS64 BS64 _ -> fail "Unknown byte value after misc instruction byte" - _ -> fail "Unknown byte value in place of instruction opcode" + byte -> fail $ "Unknown byte value in place of instruction opcode: " ++ (show byte) putExpression :: Expression -> Put putExpression expr = do @@ -844,7 +900,7 @@ instance Serialize ElemSegment where ElemSegment FuncRef (Active 0 offset) <$> funcIndexes 0x05 -> do elemType <- get - ElemSegment elemType Passive <$> getVec + ElemSegment elemType Passive . map unExpr <$> getVec 0x06 -> do tableIndex <- getULEB128 32 offset <- getExpression @@ -882,16 +938,34 @@ instance Serialize Function where instance Serialize DataSegment where put (DataSegment (ActiveData memIdx offset) init) = do + putWord8 0x02 putULEB128 memIdx putExpression offset putULEB128 $ LBS.length init putLazyByteString init + put (DataSegment PassiveData init) = do + putWord8 0x01 + putULEB128 $ LBS.length init + putLazyByteString init get = do - memIdx <- getULEB128 32 - offset <- getExpression - len <- getULEB128 32 - init <- getLazyByteString len - return $ DataSegment (ActiveData memIdx offset) init + op <- getULEB128 32 + case (op :: Word8) of + 0x00 -> do + offset <- getExpression + len <- getULEB128 32 + init <- getLazyByteString len + return $ DataSegment (ActiveData 0 offset) init + 0x01 -> do + len <- getULEB128 32 + init <- getLazyByteString len + return $ DataSegment PassiveData init + 0x02 -> do + memIdx <- getULEB128 32 + offset <- getExpression + len <- getULEB128 32 + init <- getLazyByteString len + return $ DataSegment (ActiveData memIdx offset) init + byte -> fail $ "unknown data segment type: " ++ show byte instance Serialize Module where put mod = do diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 2134e49..0e5c8b3 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -427,13 +427,13 @@ calcInstance (Store fs ts ms gs es ds) imps mod = do if limitMatch lim limit then return idx else throwError "incompatible import type" - checkImportType imp@(Import _ _ (ImportTable (TableType limit _))) = do + checkImportType imp@(Import _ _ (ImportTable (TableType limit et))) = do idx <- getImpIdx imp tableAddr <- case idx of ExternTable tableAddr -> return tableAddr _ -> throwError "incompatible import type" - let TableInstance { t = TableType lim _ } = ts ! tableAddr - if limitMatch lim limit + let TableInstance { t = TableType lim et' } = ts ! tableAddr + if limitMatch lim limit && et == et' then return idx else throwError "incompatible import type" @@ -566,19 +566,18 @@ initialize inst Module {elems, datas, start} = do refs <- liftIO $ mapM (evalConstExpr inst st) elements let funcs = map (\(RF ref) -> (funcaddrs inst !) . fromIntegral <$> ref) refs let idx = tableaddrs inst ! fromIntegral tableIndex - let last = from + length funcs - let TableInstance lim elems = tableInstances st ! idx - len <- MVector.length <$> (liftIO $ readIORef elems) - Monad.when (last > len) $ throwError "out of bounds table access" return (idx, elemaddrs inst ! elemN, from, funcs) initElem :: (Address, Address, Int, [Maybe Address]) -> Initialize () initElem (tableIdx, elemIdx, from, funcs) = do Store {tableInstances, elemInstances} <- State.get elems <- liftIO $ readIORef $ items $ tableInstances ! tableIdx - let ElemInstance {isDropped} = elemInstances ! elemIdx - liftIO $ writeIORef isDropped True - Monad.forM_ (zip [from..] funcs) $ uncurry $ MVector.unsafeWrite elems + if from + length funcs > MVector.length elems + then throwError "out of bounds table access" + else do + let ElemInstance {isDropped} = elemInstances ! elemIdx + liftIO $ writeIORef isDropped True + Monad.forM_ (zip [from..] funcs) $ uncurry $ MVector.unsafeWrite elems checkData :: DataSegment -> Initialize (Maybe (Int, MemoryStore, LBS.ByteString)) checkData DataSegment {dataMode = ActiveData memIndex offset, chunk} = do @@ -586,18 +585,18 @@ initialize inst Module {elems, datas, start} = do 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 - len <- ByteArray.getSizeofMutableByteArray mem - Monad.when (last > len) $ throwError "out of bounds memory access" return $ Just (from, mem, chunk) checkData DataSegment {dataMode = PassiveData, chunk} = return Nothing initData :: Maybe (Int, MemoryStore, LBS.ByteString) -> Initialize () initData Nothing = return () - initData (Just (from, mem, chunk)) = + initData (Just (from, mem, chunk)) = do + let last = from + (fromIntegral $ LBS.length chunk) + len <- ByteArray.getSizeofMutableByteArray mem + Monad.when (last > len) $ throwError "out of bounds memory access" mapM_ (\(i,b) -> ByteArray.writeByteArray mem i b) $ zip [from..] $ LBS.unpack chunk instantiate :: Store -> Imports -> Valid.ValidModule -> IO (Either String ModuleInstance, Store) diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 078b4e6..a5e827a 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -13,6 +13,7 @@ import Control.Monad.IO.Class (liftIO) import Numeric.IEEE (identicalIEEE) import qualified Control.DeepSeq as DeepSeq import Data.Maybe (fromJust, isNothing) +import Debug.Trace (trace) import Language.Wasm.Parser ( Ident(..), @@ -166,7 +167,7 @@ runScript onAssertFail script = do let Right m = Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule in (ident, m) buildModule (BinaryModDef ident binaryRep) = - let Right m = Binary.decodeModuleLazy binaryRep in + let Right m = Binary.decodeModuleLazy binaryRep in (ident, m) checkModuleInvalid :: Struct.Module -> IO () @@ -261,8 +262,9 @@ runScript onAssertFail script = do let (_, m) = buildModule moduleDef in case Validate.validate m of Right m -> do - st <- fst <$> State.get + (st, pos) <- State.get (res, store') <- liftIO $ Interpreter.instantiate (store st) (buildImports st) m + State.put (st { store = store' }, pos) case res of Left err | err == TL.unpack failureString -> return () Left "Start function terminated with trap" -> diff --git a/stack.yaml b/stack.yaml index 84e1882..ef0185b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,4 +3,4 @@ packages: - '.' extra-deps: [] flags: {} -extra-package-dbs: [] +extra-package-dbs: [] \ No newline at end of file diff --git a/tests/Test.hs b/tests/Test.hs index 6baa8df..e9b9a7b 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 = ["bulk.wast"] + -- let files = ["linking.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do diff --git a/wasm.cabal b/wasm.cabal index 5931f97..d730767 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -67,7 +67,7 @@ library , text >=1.1 && < 3 , transformers >=0.4 && < 0.7 , utf8-string >=1.0 && < 1.1 - , vector >=0.12 && < 0.14 + , vector >=0.12.2 && < 0.14 default-language: Haskell2010 test-suite test