fail on too big align value deserialization

src/Language/Wasm/Binary.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Language.Wasm.Binary (
     dumpModule,
@@ -16,6 +17,8 @@ import Data.Bits
 import Data.Word (Word8, Word32, Word64)
 import Data.Int (Int8, Int32, Int64)
 import Data.Serialize
+import Control.Monad (when)
+import Data.Primitive.ByteArray as BA
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Lazy as TL
@@ -221,6 +224,7 @@ instance Serialize ValueType where
     put I64 = putWord8 0x7E
     put F32 = putWord8 0x7D
     put F64 = putWord8 0x7C
+    put V128 = putWord8 0x7B
 
     get = do
         op <- getWord8
@@ -229,6 +233,7 @@ instance Serialize ValueType where
             0x7E -> return I64
             0x7D -> return F32
             0x7C -> return F64
+            0x7B -> return V128
             _ -> fail "unexpected byte in value type position"
 
 instance Serialize FuncType where
@@ -336,6 +341,7 @@ instance Serialize MemArg where
     put MemArg { align, offset } = putULEB128 align >> putULEB128 offset
     get = do
         align <- getULEB128 32
+        when (align >= 32) $ fail "malformed memop flags"
         offset <- getULEB128 32
         return $ MemArg { align, offset }
 
@@ -458,6 +464,10 @@ instance Serialize (Instruction Natural) where
     put (I64Const val) = putWord8 0x42 >> putSLEB128 (asInt64 val)
     put (F32Const val) = putWord8 0x43 >> putFloat32le val
     put (F64Const val) = putWord8 0x44 >> putFloat64le val
+    put (V128Const val) = do
+        putWord8 0xFD
+        putWord8 12
+        put $ BA.foldrByteArray @Word8 (:) [] val
     put I32Eqz = putWord8 0x45
     put (IRelOp BS32 IEq) = putWord8 0x46
     put (IRelOp BS32 INe) = putWord8 0x47
@@ -803,6 +813,13 @@ instance Serialize (Instruction Natural) where
                     0x06 -> return $ ITruncSatFS BS64 BS64
                     0x07 -> return $ ITruncSatFU BS64 BS64
                     _ -> fail "Unknown byte value after misc instruction byte"
+            0xFD -> do -- simd
+                ext <- getULEB128 32
+                case (ext :: Word32) of
+                    0x0C -> do
+                        bytes <- getByteString 16
+                        return $ V128Const $ BA.byteArrayFromListN 16 $ BS.unpack bytes
+                    _ -> fail "Unknown byte value after simd instruction byte"
             byte -> fail $ "Unknown byte value in place of instruction opcode: " ++ (show byte)
 
 putExpression :: Expression -> Put
@@ -877,10 +894,10 @@ instance Serialize ElemSegment where
         putVec $ map Expr elements
 
     get = do
-        op <- getWord8
         let funcIndexes = map ((:[]) . RefFunc . unIndex) <$> getVec
         let elemKind = byteGuard 0x00 >> return FuncRef
-        case op of
+        op <- getULEB128 32
+        case (op :: Word8) of
             0x00 -> do
                 offset <- getExpression
                 ElemSegment FuncRef (Active 0 offset) <$> funcIndexes

src/Language/Wasm/Lexer.x

@@ -39,13 +39,13 @@ $alpha     = [$lower $upper]
 $namepunct = [\! \# \$ \% \& \' \* \+ \- \. \/ \: \< \= \> \? \@ \∖ \^ \_ \` \| \~]
 $idchar    = [$digit $alpha $namepunct]
 $space     = [\  \x09 \x0A \x0D]
-$linechar  = [^ \x09]
+$linechar  = [^ \x09 \x0A \x0D]
 $sign      = [\+ \-]
 $doublequote = \"
 
 @keyword     = $lower $idchar*
 @reserved    = $idchar+
-@linecomment = ";;" $linechar* \x0A
+@linecomment = ";;" $linechar* [\x0A \x0D]
 @startblockcomment = "(;"
 @endblockcomment = ";)"
 @num = $digit (\_? $digit+)*
@@ -80,10 +80,10 @@ tokens :-
 <0> @id                                   { tokenStr TId }
 <0> "("                                   { constToken TOpenBracket }
 <0> ")"                                   { constToken TCloseBracket }
+<0> $sign? @hexfloat                      { parseHexFloat }
 <0> $sign? @num                           { parseDecimalSignedInt }
 <0> $sign? "0x" @hexnum                   { parseHexalSignedInt }
 <0> $sign? @float                         { parseDecFloat }
-<0> $sign? @hexfloat                      { parseHexFloat }
 <0, blockComment> @startblockcomment      { startBlockComment }
 <blockComment> [.\n]                      ;
 <blockComment> @endblockcomment           { endBlockComment }
@@ -119,22 +119,22 @@ minusNaN = negate nan
 inf = infinity
 minusInf = -infinity
 
-parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64)
+parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64, Maybe Bool)
 parseSign str =
     let Just (ch, _) = LBSUtf8.decode str in
     case ch of
-        '-' -> (negate, 1)
+        '-' -> (negate, 1, Just True)
-        '+' -> (abs, 1)
+        '+' -> (abs, 1, Just False)
-        otherwise -> (abs, 0)
+        otherwise -> (abs, 0, Nothing)
 
-{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64) #-}
+{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64, Maybe Bool) #-}
-{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64) #-}
+{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64, Maybe Bool) #-}
 
 parseHexalSignedInt :: AlexAction Lexeme
 parseHexalSignedInt = token $ \(pos, _, s, _) len -> 
-    let (sign, slen) = parseSign s in
+    let (sign, slen, nat) = parseSign s in
     let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in
-    Lexeme (Just pos) $ TIntLit $ sign num
+    Lexeme (Just pos) $ TIntLit nat $ sign num
 
 parseNanSigned :: AlexAction Lexeme
 parseNanSigned = token $ \(pos, _, s, _) len -> 
@@ -148,9 +148,9 @@ parseNanSigned = token $ \(pos, _, s, _) len ->
 
 parseDecimalSignedInt :: AlexAction Lexeme
 parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
-    let (sign, slen) = parseSign s in
+    let (sign, slen, nat) = parseSign s in
     let num = readDecFromPrefix (len - slen) $ LBSUtf8.drop slen s in
-    Lexeme (Just pos) $ TIntLit $ sign num
+    Lexeme (Just pos) $ TIntLit nat $ sign num
 
 parseDecFloat :: AlexAction Lexeme
 parseDecFloat = token $ \(pos, _, s, _) len ->
@@ -226,11 +226,13 @@ readHexFloat toFloat sz expLimit manitisaSize str = do
                         then ([True], 0, exp' + 1)
                         else (rounded, 1, exp')
                     else (rounded, 0, exp')
-        if exp'' > expLimit || exp'' < (negate $ expLimit + manitisaSize) then Left "constant out of range" else return ()
+        e <- if exp'' > expLimit then Left "const out of range"
-        if exp'' >= (negate $ expLimit - 1)
+                else if exp'' < (negate $ expLimit + manitisaSize) then return $ negate $ expLimit + manitisaSize + 1
-        then return $ toFloat $ sign .|. ((fromIntegral $ exp'' + expLimit) `shiftL` manitisaSize) .|. ((fromBits (tail bits') + a) `shiftL` (manitisaSize + 1 - length bits'))
+                else return exp''
+        if e >= (negate $ expLimit - 1)
+        then return $ toFloat $ sign .|. ((fromIntegral $ e + expLimit) `shiftL` manitisaSize) .|. ((fromBits (tail bits') + a) `shiftL` (manitisaSize + 1 - length bits'))
         else do
-            let shift = expLimit + manitisaSize - length bits' - abs exp''
+            let shift = expLimit + manitisaSize - length bits' - abs e
             if shift < 0
             then return $ toFloat sign
             else return $ toFloat $ sign .|. ((fromBits bits' + a) `shiftL` shift)
@@ -299,7 +301,9 @@ endBlockComment _inp _len = do
     alexMonadScan
 
 startStringLiteral :: AlexAction Lexeme
-startStringLiteral _inp _len = do
+startStringLiteral (_, prev, _, _) _len = do
+    when (prev `notElem` "() \x09\x0A\x0D")
+        $ alexError "string literal should start after space or parent character"
     alexSetStartCode stringLiteral
     setLexerStringFlag True
     alexMonadScan
@@ -362,7 +366,7 @@ data NaN
     deriving (Show, Eq)
 
 data Token = TKeyword LBS.ByteString
-    | TIntLit Integer
+    | TIntLit {- Natural -} (Maybe Bool) Integer
     | TFloatLit FloatRep
     | TStringLit LBS.ByteString
     | TId LBS.ByteString

src/Language/Wasm/Script.hs

@@ -11,6 +11,7 @@ import qualified Data.Text.Lazy.Encoding as TLEncoding
 import qualified Control.Monad.State as State
 import Control.Monad.IO.Class (liftIO)
 import Numeric.IEEE (identicalIEEE)
+import qualified Data.Primitive.ByteArray as ByteArray
 import qualified Control.DeepSeq as DeepSeq
 import Data.Maybe (fromJust, isNothing)
 import Debug.Trace (trace)
@@ -30,6 +31,9 @@ import qualified Language.Wasm.Structure as Struct
 import qualified Language.Wasm.Parser as Parser
 import qualified Language.Wasm.Lexer as Lexer
 import qualified Language.Wasm.Binary as Binary
+import Language.Wasm.FloatUtils (floatToWord, wordToFloat, doubleToWord, wordToDouble)
+import Numeric.IEEE (nan)
+import Data.Bits ((.&.))
 
 type OnAssertFail = String -> Assertion -> IO ()
 
@@ -56,6 +60,7 @@ runScript onAssertFail script = do
     (st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [
             ("print", hostPrint []),
             ("print_i32", hostPrint [Struct.I32]),
+            ("print_i64", hostPrint [Struct.I64]),
             ("print_i32_f32", hostPrint [Struct.I32, Struct.F32]),
             ("print_f64_f64", hostPrint [Struct.F64, Struct.F64]),
             ("print_f32", hostPrint [Struct.F32]),
@@ -73,8 +78,8 @@ runScript onAssertFail script = do
         hostGlobals = do
             let globI32 = Interpreter.makeConstGlobal $ Interpreter.VI32 666
             let globI64 = Interpreter.makeConstGlobal $ Interpreter.VI64 666
-            let globF32 = Interpreter.makeConstGlobal $ Interpreter.VF32 666
+            let globF32 = Interpreter.makeConstGlobal $ Interpreter.VF32 666.6
-            let globF64 = Interpreter.makeConstGlobal $ Interpreter.VF64 666
+            let globF64 = Interpreter.makeConstGlobal $ Interpreter.VF64 666.6
             return (
                     Interpreter.HostGlobal globI32,
                     Interpreter.HostGlobal globI64,
@@ -118,16 +123,23 @@ runScript onAssertFail script = do
         getModule st (Just (Ident i)) = Map.lookup i (modules st)
         getModule st Nothing = lastModule st
 
-        asArg :: Struct.Expression -> Interpreter.Value
+        asArg :: Parser.ValuePattern -> Interpreter.Value
-        asArg [Struct.I32Const v] = Interpreter.VI32 v
+        asArg (Parser.ExactValue (Struct.I32Const v)) = Interpreter.VI32 v
-        asArg [Struct.F32Const v] = Interpreter.VF32 v
+        asArg (Parser.ExactValue (Struct.F32Const v)) = Interpreter.VF32 v
-        asArg [Struct.I64Const v] = Interpreter.VI64 v
+        asArg (Parser.ExactValue (Struct.I64Const v)) = Interpreter.VI64 v
-        asArg [Struct.F64Const v] = Interpreter.VF64 v
+        asArg (Parser.ExactValue (Struct.F64Const v)) = Interpreter.VF64 v
-        asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing
+        asArg (Parser.ExactValue (Struct.V128Const v)) = Interpreter.VV128 v
-        asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing
+        asArg (Parser.ExactValue (Struct.RefNull Struct.FuncRef)) = Interpreter.RF Nothing
-        asArg [Struct.RefExtern v] = Interpreter.RE (Just v)
+        asArg (Parser.ExactValue (Struct.RefNull Struct.ExternRef))= Interpreter.RE Nothing
+        asArg (Parser.ExactValue (Struct.RefExtern v)) = Interpreter.RE (Just v)
         asArg expr = error $ "Only const instructions supported as arguments for actions: " ++ show expr
 
+        showArg :: Parser.ValuePattern -> String
+        showArg v@(Parser.ExactValue _) = show $ asArg v
+        showArg Parser.CanonicalNan = "nan:canonical"
+        showArg Parser.ArithmeticNan = "nan:arithmetic"
+        showArg (Parser.VectorPat _ pat) = show $ showArg <$> pat
+
         runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
         runAction st (Invoke ident name args) = do
             case getModule st ident of
@@ -141,12 +153,31 @@ runScript onAssertFail script = do
         isValueEqual :: Interpreter.Value -> Interpreter.Value -> Bool
         isValueEqual (Interpreter.VI32 v1) (Interpreter.VI32 v2) = v1 == v2
         isValueEqual (Interpreter.VI64 v1) (Interpreter.VI64 v2) = v1 == v2
-        isValueEqual (Interpreter.VF32 v1) (Interpreter.VF32 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
+        isValueEqual (Interpreter.VF32 v1) (Interpreter.VF32 v2) = identicalIEEE v1 v2
-        isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
+        isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2
+        isValueEqual (Interpreter.VV128 a) (Interpreter.VV128 b) = ByteArray.compareByteArrays a 0 b 0 16 == EQ
         isValueEqual (Interpreter.RF f1) (Interpreter.RF f2) = f1 == f2
         isValueEqual (Interpreter.RE e1) (Interpreter.RE e2) = e1 == e2
         isValueEqual _ _ = False
 
+        isValueMatch :: Interpreter.Value -> Parser.ValuePattern -> Bool
+        isValueMatch val v@(Parser.ExactValue _) = isValueEqual val $ asArg v
+        isValueMatch (Interpreter.VF32 v) Parser.CanonicalNan = identicalIEEE v nan || identicalIEEE v (abs nan)
+        isValueMatch (Interpreter.VF32 v) Parser.ArithmeticNan =
+            let posNan = 0x7F800000 in
+            floatToWord v .&. posNan == posNan
+        isValueMatch (Interpreter.VF64 v) Parser.CanonicalNan = identicalIEEE v nan || identicalIEEE v (abs nan)
+        isValueMatch (Interpreter.VF64 v) Parser.ArithmeticNan =
+            let posNan = 0x7FF0000000000000 in
+            doubleToWord v .&. posNan == posNan
+        isValueMatch (Interpreter.VV128 v) (Parser.VectorPat Struct.F32x4 pat) =
+            let vals = Interpreter.VF32 . wordToFloat . ByteArray.indexByteArray v <$> [0..3] in
+            and $ zipWith isValueMatch vals pat
+        isValueMatch (Interpreter.VV128 v) (Parser.VectorPat Struct.F64x2 pat) =
+            let vals = Interpreter.VF64 . wordToDouble . ByteArray.indexByteArray v <$> [0, 1] in
+            and $ zipWith isValueMatch vals pat
+        isValueMatch _ _ = False
+
         isNaNReturned :: Action -> Assertion -> AssertM ()
         isNaNReturned action assert = do
             result <- runActionInAssert action
@@ -184,6 +215,7 @@ runScript onAssertFail script = do
         getFailureString (Validate.FunctionIndexOutOfRange idx) = ["unknown function", "unknown function " <> TL.pack (show idx)]
         getFailureString (Validate.GlobalIndexOutOfRange idx) = ["unknown global", "unknown global " <> TL.pack (show idx)]
         getFailureString Validate.LabelIndexOutOfRange = ["unknown label"]
+        getFailureString Validate.LaneIndexOutOfRange = ["invalid lane index"]
         getFailureString Validate.TypeIndexOutOfRange = ["unknown type"]
         getFailureString Validate.MinMoreThanMaxInMemoryLimit = ["size minimum must not be greater than maximum"]
         getFailureString Validate.MemoryLimitExceeded = ["memory size must be at most 65536 pages (4GiB)"]
@@ -215,10 +247,10 @@ runScript onAssertFail script = do
             result <- runActionInAssert action
             case result of
                 Just result -> do
-                    if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected))
+                    if length result == length expected && (all id $ zipWith isValueMatch result expected)
                     then return ()
-                    else printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
+                    else printFailedAssert ("Expected " ++ show (map showArg expected) ++ ", but action returned " ++ show result) assert
-                Nothing -> printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
+                Nothing -> printFailedAssert ("Expected " ++ show (map showArg expected) ++ ", but action returned Trap") assert
         runAssert assert@(AssertReturnCanonicalNaN action) = isNaNReturned action assert
         runAssert assert@(AssertReturnArithmeticNaN action) = isNaNReturned action assert
         runAssert assert@(AssertInvalid moduleDef failureString) =

src/Language/Wasm/Structure.hs

@@ -33,6 +33,7 @@ module Language.Wasm.Structure (
     FuncType(..),
     ValueType(..),
     BlockType(..),
+    SimdShape(..),
     ParamsType,
     ResultType,
     LocalsType,
@@ -53,12 +54,15 @@ module Language.Wasm.Structure (
 
 import Numeric.Natural (Natural)
 import Data.Word (Word32, Word64)
+import qualified Data.Primitive.ByteArray as ByteArray
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Lazy as TL
 import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 
-data BitSize = BS32 | BS64 deriving (Show, Eq, Generic, NFData)
+data SimdShape = I8x16 | I16x8 | I32x4 | I64x2 | F32x4 | F64x2 | I128x1 deriving (Show, Eq, Generic, NFData)
+
+data BitSize = BS32 | BS64 | BS128 SimdShape deriving (Show, Eq, Generic, NFData)
 
 data IUnOp =
     IClz
@@ -67,17 +71,27 @@ data IUnOp =
     | IExtend8S
     | IExtend16S
     | IExtend32S
+    | INot
+    | IAbs
+    | INeg
+    | IExtAddPairwise {- Signed -} Bool
     deriving (Show, Eq, Generic, NFData)
 
 data IBinOp =
     IAdd
     | ISub
+    | IAddSatS
+    | ISubSatS
+    | IAddSatU
+    | ISubSatU
+    | IAvgrU
     | IMul
     | IDivU
     | IDivS
     | IRemU
     | IRemS
     | IAnd
+    | IAndNot
     | IOr
     | IXor
     | IShl
@@ -85,13 +99,18 @@ data IBinOp =
     | IShrS
     | IRotl
     | IRotr
+    | IMinU
+    | IMinS
+    | IMaxU
+    | IMaxS
+    | IExtMul {- Signed -} Bool {- High -} Bool
     deriving (Show, Eq, Generic, NFData)
 
 data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq, Generic, NFData)
 
 data FUnOp = FAbs | FNeg | FCeil | FFloor | FTrunc | FNearest | FSqrt deriving (Show, Eq, Generic, NFData)
 
-data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq, Generic, NFData)
+data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign | FPMin | FPMax deriving (Show, Eq, Generic, NFData)
 
 data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq, Generic, NFData)
 
@@ -112,6 +131,7 @@ data ValueType =
     | I64
     | F32
     | F64
+    | V128
     | Func
     | Extern
     deriving (Show, Eq, Generic, NFData)
@@ -159,6 +179,23 @@ data Instruction index =
     | I64Load MemArg
     | F32Load MemArg
     | F64Load MemArg
+    | V128Load MemArg
+    | V128Load8Lane MemArg Natural
+    | V128Load16Lane MemArg Natural
+    | V128Load32Lane MemArg Natural
+    | V128Load64Lane MemArg Natural
+    | V128Load8Splat MemArg
+    | V128Load16Splat MemArg
+    | V128Load32Splat MemArg
+    | V128Load64Splat MemArg
+    | V128Load32Zero MemArg
+    | V128Load64Zero MemArg
+    | V128Load8x8S MemArg
+    | V128Load8x8U MemArg
+    | V128Load16x4S MemArg
+    | V128Load16x4U MemArg
+    | V128Load32x2S MemArg
+    | V128Load32x2U MemArg
     | I32Load8S MemArg
     | I32Load8U MemArg
     | I32Load16S MemArg
@@ -173,6 +210,11 @@ data Instruction index =
     | I64Store MemArg
     | F32Store MemArg
     | F64Store MemArg
+    | V128Store MemArg
+    | V128Store8Lane MemArg Natural
+    | V128Store16Lane MemArg Natural
+    | V128Store32Lane MemArg Natural
+    | V128Store64Lane MemArg Natural
     | I32Store8 MemArg
     | I32Store16 MemArg
     | I64Store8 MemArg
@@ -198,6 +240,7 @@ data Instruction index =
     | I64Const Word64
     | F32Const Float
     | F64Const Double
+    | V128Const ByteArray.ByteArray
     | IUnOp BitSize IUnOp
     | IBinOp BitSize IBinOp
     | I32Eqz
@@ -219,6 +262,23 @@ data Instruction index =
     | F64PromoteF32
     | IReinterpretF BitSize
     | FReinterpretI BitSize
+    -- Vector instructions
+    | V128Splat SimdShape
+    | V128ExtractLane SimdShape index {- signed -} Bool
+    | V128ReplaceLane SimdShape index
+    | V128AllTrue SimdShape
+    | V128BitMask SimdShape
+    | V128AnyTrue
+    | V128BitSelect
+    | I8x16Swizzle
+    | I8x16Shuffle [Int]
+    | V128Narrow SimdShape SimdShape {- signed -} Bool
+    | F64x2PromoteLowF32x4
+    | F32x4DemoteF64x2Zero
+    | V128IExtend SimdShape SimdShape {- high -} Bool {- signed -} Bool
+    | I32x4TruncSatF {- signed -} Bool {- Float Size -} BitSize
+    | I32x4DotI16x8S
+    | I16x8Q15MulrSatS
     deriving (Show, Eq, Generic, NFData)
 
 type Expression = [Instruction Natural]

src/Language/Wasm/Validate.hs

@@ -40,6 +40,7 @@ data ValidationError =
     | ElemIndexOutOfRange Natural
     | DataIndexOutOfRange Natural
     | LabelIndexOutOfRange
+    | LaneIndexOutOfRange
     | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
     | TypeMismatch { actual :: Arrow, expected :: Arrow }
@@ -141,7 +142,7 @@ isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
 data Ctx = Ctx {
     types :: [FuncType],
     funcs :: [FuncType],
-    tables :: [TableType],
+    tableTypes :: [TableType],
     elems :: [ElemType],
     datas :: [DataMode],
     mems :: [Limit],
@@ -192,10 +193,13 @@ getLabel lbl = do
 withLabel :: [ValueType] -> Checker a -> Checker a
 withLabel result = withReaderT (\ctx -> ctx { labels = result : labels ctx })
 
-isMemArgValid :: Int -> MemArg -> Checker ()
+isMemArgValid :: Natural -> MemArg -> Checker ()
-isMemArgValid sizeInBytes MemArg { align } = if 2 ^ align <= sizeInBytes then return () else throwError AlignmentOverflow
+isMemArgValid sizeInBytes MemArg { align } =
+    if 2 ^ align <= sizeInBytes
+    then return ()
+    else throwError AlignmentOverflow
 
-checkMemoryInstr :: Int -> MemArg -> Checker ()
+checkMemoryInstr :: Natural -> MemArg -> Checker ()
 checkMemoryInstr size memarg = do
     isMemArgValid size memarg
     Ctx { mems } <- ask 
@@ -273,10 +277,12 @@ getInstrType _ (Call fun) = do
     Ctx { funcs } <- ask
     maybeToEither (FunctionIndexOutOfRange fun) $ asArrow <$> funcs !? fun
 getInstrType _ (CallIndirect tableIdx sign) = do
-    Ctx { types, tables } <- ask
+    Ctx { types, tableTypes = tables } <- ask
     if length tables <= fromIntegral tableIdx
     then throwError (TableIndexOutOfRange tableIdx)
     else do
+        let TableType _ elemType = tables !! fromIntegral tableIdx
+        when (elemType /= FuncRef) $ throwError (RefTypeMismatch FuncRef ExternRef)
         Arrow from to <- maybeToEither TypeIndexOutOfRange $ asArrow <$> types !? sign
         return $ (from ++ [Val I32]) ==> to
 getInstrType _ Drop = do
@@ -336,6 +342,61 @@ getInstrType _ (F32Load memarg) = do
 getInstrType _ (F64Load memarg) = do
     checkMemoryInstr 8 memarg
     return $ I32 ==> F64
+getInstrType _ (V128Load memarg) = do
+    checkMemoryInstr 16 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load8Lane memarg idx) = do
+    checkMemoryInstr 1 memarg
+    when (idx >= 16) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load16Lane memarg idx) = do
+    checkMemoryInstr 2 memarg
+    when (idx >= 8) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load32Lane memarg idx) = do
+    checkMemoryInstr 4 memarg
+    when (idx >= 4) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load64Lane memarg idx) = do
+    checkMemoryInstr 8 memarg
+    when (idx >= 2) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load8Splat memarg) = do
+    checkMemoryInstr 1 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load16Splat memarg) = do
+    checkMemoryInstr 2 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32Splat memarg) = do
+    checkMemoryInstr 4 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load64Splat memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32Zero memarg) = do
+    checkMemoryInstr 4 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load64Zero memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load8x8S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load8x8U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load16x4S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load16x4U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32x2S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32x2U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
 getInstrType _ (I32Load8S memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> I32
@@ -378,6 +439,25 @@ getInstrType _ (F32Store memarg) = do
 getInstrType _ (F64Store memarg) = do
     checkMemoryInstr 8 memarg
     return $ [I32, F64] ==> empty
+getInstrType _ (V128Store memarg) = do
+    checkMemoryInstr 16 memarg
+    return $ [I32, V128] ==> empty
+getInstrType _ (V128Store8Lane memarg idx) = do
+    checkMemoryInstr 1 memarg
+    when (idx >= 16) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> empty
+getInstrType _ (V128Store16Lane memarg idx) = do
+    checkMemoryInstr 2 memarg
+    when (idx >= 8) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> empty
+getInstrType _ (V128Store32Lane memarg idx) = do
+    checkMemoryInstr 4 memarg
+    when (idx >= 4) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> empty
+getInstrType _ (V128Store64Lane memarg idx) = do
+    checkMemoryInstr 8 memarg
+    when (idx >= 2) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> empty
 getInstrType _ (I32Store8 memarg) = do
     checkMemoryInstr 1 memarg
     return $ [I32, I32] ==> empty
@@ -419,7 +499,7 @@ getInstrType _ (DataDrop dataIdx) = do
     when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
     return $ empty ==> empty
 getInstrType _ (TableInit tableIdx elemIdx) = do
-    Ctx { tables, elems } <- ask
+    Ctx { tableTypes = tables, elems } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
@@ -427,7 +507,7 @@ getInstrType _ (TableInit tableIdx elemIdx) = do
     when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
     return $ [I32, I32, I32] ==> empty
 getInstrType _ (TableCopy toIdx fromIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx)
     when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx)
     when (length tables <= to) $ throwError (TableIndexOutOfRange toIdx)
@@ -436,26 +516,26 @@ getInstrType _ (TableCopy toIdx fromIdx) = do
     when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType)
     return $ [I32, I32, I32] ==> empty
 getInstrType _ (TableFill tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [I32, elemTypeToRefType tableType, I32] ==> empty
 getInstrType _ (TableSize tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     return $ empty ==> I32
 getInstrType _ (TableGrow tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [elemTypeToRefType tableType, I32] ==> I32
 getInstrType _ (TableGet tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ I32 ==> (elemTypeToRefType tableType)
 getInstrType _ (TableSet tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [I32, elemTypeToRefType tableType] ==> empty
@@ -467,20 +547,29 @@ getInstrType _ (I32Const _) = return $ empty ==> I32
 getInstrType _ (I64Const _) = return $ empty ==> I64
 getInstrType _ (F32Const _) = return $ empty ==> F32
 getInstrType _ (F64Const _) = return $ empty ==> F64
+getInstrType _ (V128Const _) = return $ empty ==> V128
 getInstrType _ (IUnOp BS32 _) = return $ I32 ==> I32
 getInstrType _ (IUnOp BS64 _) = return $ I64 ==> I64
+getInstrType _ (IUnOp (BS128 _) _) = return $ V128 ==> V128
 getInstrType _ (IBinOp BS32 _) = return $ [I32, I32] ==> I32
 getInstrType _ (IBinOp BS64 _) = return $ [I64, I64] ==> I64
+getInstrType _ (IBinOp (BS128 _) op) | op == IShl || op == IShrS || op == IShrU =
+    return $ [V128, I32] ==> V128
+getInstrType _ (IBinOp (BS128 _) _) = return $ [V128, V128] ==> V128
 getInstrType _ I32Eqz = return $ I32 ==> I32
 getInstrType _ I64Eqz = return $ I64 ==> I32
 getInstrType _ (IRelOp BS32 _) = return $ [I32, I32] ==> I32
 getInstrType _ (IRelOp BS64 _) = return $ [I64, I64] ==> I32
+getInstrType _ (IRelOp (BS128 _) _) = return $ [V128, V128] ==> V128
 getInstrType _ (FUnOp BS32 _) = return $ F32 ==> F32
 getInstrType _ (FUnOp BS64 _) = return $ F64 ==> F64
+getInstrType _ (FUnOp (BS128 _) _) = return $ V128 ==> V128
 getInstrType _ (FBinOp BS32 _) = return $ [F32, F32] ==> F32
 getInstrType _ (FBinOp BS64 _) = return $ [F64, F64] ==> F64
+getInstrType _ (FBinOp (BS128 _) _) = return $ [V128, V128] ==> V128
 getInstrType _ (FRelOp BS32 _) = return $ [F32, F32] ==> I32
 getInstrType _ (FRelOp BS64 _) = return $ [F64, F64] ==> I32
+getInstrType _ (FRelOp (BS128 _) _) = return $ [V128, V128] ==> V128
 getInstrType _ I32WrapI64 = return $ I64 ==> I32
 getInstrType _ (ITruncFU BS32 BS32) = return $ F32 ==> I32
 getInstrType _ (ITruncFU BS32 BS64) = return $ F64 ==> I32
@@ -504,17 +593,71 @@ getInstrType _ (FConvertIU BS32 BS32) = return $ I32 ==> F32
 getInstrType _ (FConvertIU BS32 BS64) = return $ I64 ==> F32
 getInstrType _ (FConvertIU BS64 BS32) = return $ I32 ==> F64
 getInstrType _ (FConvertIU BS64 BS64) = return $ I64 ==> F64
+getInstrType _ (FConvertIU (BS128 _) (BS128 _)) = return $ V128 ==> V128
 getInstrType _ (FConvertIS BS32 BS32) = return $ I32 ==> F32
 getInstrType _ (FConvertIS BS32 BS64) = return $ I64 ==> F32
 getInstrType _ (FConvertIS BS64 BS32) = return $ I32 ==> F64
 getInstrType _ (FConvertIS BS64 BS64) = return $ I64 ==> F64
+getInstrType _ (FConvertIS (BS128 _) (BS128 _)) = return $ V128 ==> V128
 getInstrType _ F32DemoteF64 = return $ F64 ==> F32
 getInstrType _ F64PromoteF32 = return $ F32 ==> F64
 getInstrType _ (IReinterpretF BS32) = return $ F32 ==> I32
 getInstrType _ (IReinterpretF BS64) = return $ F64 ==> I64
 getInstrType _ (FReinterpretI BS32) = return $ I32 ==> F32
 getInstrType _ (FReinterpretI BS64) = return $ I64 ==> F64
+getInstrType _ I8x16Swizzle =
+    return $ [V128, V128] ==> V128
+getInstrType _ (I8x16Shuffle idxs) = do
+    when (any (>= 32) idxs) $ throwError LaneIndexOutOfRange
+    return $ [V128, V128] ==> V128
+getInstrType _ (V128Splat shape) =
+    return $ getShapeElemType shape ==> V128
+getInstrType _ (V128ExtractLane shape idx _) = do
+    when (idx >= lanesCount shape) $ throwError LaneIndexOutOfRange
+    return $ V128 ==> getShapeElemType shape
+getInstrType _ (V128ReplaceLane shape idx) = do
+    when (idx >= lanesCount shape) $ throwError LaneIndexOutOfRange
+    return $ [V128, getShapeElemType shape] ==> V128
+getInstrType _ (V128AllTrue _) =
+    return $ V128 ==> I32
+getInstrType _ V128AnyTrue =
+    return $ V128 ==> I32
+getInstrType _ V128BitSelect =
+    return $ [V128, V128, V128] ==> V128
+getInstrType _ (V128BitMask _) =
+    return $ V128 ==> I32
+getInstrType _ (V128Narrow _ _ _) =
+    return $ [V128, V128] ==> V128
+getInstrType _ F64x2PromoteLowF32x4 =
+    return $ V128 ==> V128
+getInstrType _ F32x4DemoteF64x2Zero =
+    return $ V128 ==> V128
+getInstrType _ (V128IExtend _ _ _ _) =
+    return $ V128 ==> V128
+getInstrType _ (I32x4TruncSatF _ _) =
+    return $ V128 ==> V128
+getInstrType _ I32x4DotI16x8S =
+    return $[V128, V128] ==> V128
+getInstrType _ I16x8Q15MulrSatS =
+    return $ [V128, V128] ==> V128
 
+getShapeElemType :: SimdShape -> ValueType
+getShapeElemType I8x16 = I32
+getShapeElemType I16x8 = I32
+getShapeElemType I32x4 = I32
+getShapeElemType I64x2 = I64
+getShapeElemType F32x4 = F32
+getShapeElemType F64x2 = F64
+
+lanesCount :: SimdShape -> Natural
+lanesCount shape = case shape of
+    I8x16 -> 16
+    I16x8 -> 8
+    I32x4 -> 4
+    I64x2 -> 2
+    F32x4 -> 4
+    F64x2 -> 2
+    I128x1 -> 1
 
 replace :: (Eq a) => a -> a -> [a] -> [a]
 replace _ _ [] = []
@@ -575,6 +718,7 @@ isConstExpression ((I32Const _):rest) = isConstExpression rest
 isConstExpression ((I64Const _):rest) = isConstExpression rest
 isConstExpression ((F32Const _):rest) = isConstExpression rest
 isConstExpression ((F64Const _):rest) = isConstExpression rest
+isConstExpression ((V128Const _):rest) = isConstExpression rest
 isConstExpression ((RefNull _):rest) = isConstExpression rest
 isConstExpression ((RefFunc _):rest) = isConstExpression rest
 isConstExpression ((GetGlobal idx):rest) = do
@@ -604,7 +748,7 @@ ctxFromModule locals labels returns m =
     Ctx {
         types,
         funcs = getFuncTypes m,
-        tables = tableImports ++ map (\(Table t) -> t) tables,
+        tableTypes = tableImports ++ map (\(Table t) -> t) tables,
         elems = map elemType elems,
         datas = map dataMode datas,
         mems = memsImports ++ map (\(Memory l) -> l) mems,
@@ -706,8 +850,6 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
     where
         isElemValid :: Ctx -> ElemSegment -> ValidationResult
         isElemValid ctx (ElemSegment elemType mode elements) = do
-            unless (elemType == FuncRef)
-                $ throwError $ RefTypeMismatch FuncRef elemType
             forM_ elements $ \elem -> runChecker ctx $ do
                 arr <- getExpressionType elem
                 isConstExpression elem
@@ -722,6 +864,9 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
                     let tableImports = filter isTableImport imports
                     when (tableIdx >= fromIntegral (length tableImports + length tables)) $ do
                         throwError $ TableIndexOutOfRange tableIdx
+                    let TableType _ tableType = tableTypes ctx !! (fromIntegral tableIdx)
+                    when (tableType /= elemType) $ do
+                        throwError $ RefTypeMismatch elemType tableType
                 _ -> return ()
         
         isValidRef :: ElemType -> Arrow -> Bool

tests/Test.hs

@@ -17,9 +17,9 @@ import qualified Data.List as List
 main :: IO ()
 main = do
   files <-
-    filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
+    filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  -- let files = ["bulk.wast"]
+  -- let files = ["align.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do

wasm.cabal

@@ -56,7 +56,7 @@ library
     , happy:happy >=1.9.4 && < 1.21
   build-depends:
       array >=0.5 && < 0.6
-    , base >=4.6 && < 5
+    , base >=4.11 && < 5
     , bytestring >=0.10 && < 0.12
     , cereal >=0.5 && < 0.6
     , containers >=0.5 && < 0.7