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

fix more tests

Browse Source
This commit is contained in:
Ilya Rezvov
2023-08-20 21:00:46 -06:00
parent 2b822a8d44
commit f23dc20d57
6 changed files with 102 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Binary.hs
+82 -8
View File
@@ -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
src/Language/Wasm/Interpreter.hs
+13 -14
View File
@@ -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)
src/Language/Wasm/Script.hs
+4 -2
View File
@@ -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" ->
stack.yaml
+1 -1
View File
@@ -3,4 +3,4 @@ packages:
- '.'
extra-deps: []
flags: {}
extra-package-dbs: []
extra-package-dbs: []
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 = ["bulk.wast"]
-- let files = ["linking.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do
wasm.cabal
+1 -1
View File
@@ -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