fail on too big align value deserialization

Stack lts-16.5 -> 20.23 and URLs in Cabal

.gitignore

@@ -8,3 +8,5 @@ dist-newstyle/
 doc/
 setup-config
 wasm-*-docs.tar.gz
+cache
+packagedb

README.md

@@ -20,9 +20,10 @@
   * [ ] Text Representation pretty-printer
   * [ ] Command line tool for calling interpreter/compiler/validator
   * [ ] Codegen interface for type enforced generating valid WASM code
+  * [ ] Support for building if, loop, block
 
 ## Development
-Clond sources to directory and use `stack` for running tests:
+Clone sources to directory and use `stack` for running tests:
 ```
 stack build && stack test
 ```

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
@@ -244,7 +249,13 @@ instance Serialize FuncType where
 
 instance Serialize ElemType where
     put FuncRef = putWord8 0x70
-    get = byteGuard 0x70 >> return FuncRef
+    put ExternRef = putWord8 0x6F
+    get = do
+        op <- getWord8
+        case op of
+            0x70 -> return FuncRef
+            0x69 -> return ExternRef
+            _ -> fail "unknown reference type"
 
 instance Serialize Limit where
     put (Limit min Nothing) = putWord8 0x00 >> putULEB128 min
@@ -320,10 +331,17 @@ instance Serialize Index where
     put (Index idx) = putULEB128 idx
     get = Index <$> getULEB128 32
 
+newtype Expr = Expr { unExpr :: Expression } deriving (Show, Eq)
+
+instance Serialize Expr where
+    put (Expr expr) = putExpression expr
+    get = Expr <$> getExpression
+
 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 }
 
@@ -353,16 +371,50 @@ instance Serialize (Instruction Natural) where
     put (BrTable labels label) = putWord8 0x0E >> putVec (map Index labels) >> putULEB128 label
     put Return = putWord8 0x0F
     put (Call funcIdx) = putWord8 0x10 >> putULEB128 funcIdx
-    put (CallIndirect typeIdx) = putWord8 0x11 >> putULEB128 typeIdx >> putWord8 0x00
+    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
@@ -387,13 +439,35 @@ instance Serialize (Instruction Natural) where
     put (I64Store8 memArg) = putWord8 0x3C >> put memArg
     put (I64Store16 memArg) = putWord8 0x3D >> put memArg
     put (I64Store32 memArg) = putWord8 0x3E >> put memArg
-    put CurrentMemory = putWord8 0x3F >> putWord8 0x00
+    put MemorySize = putWord8 0x3F >> putWord8 0x00
-    put GrowMemory = putWord8 0x40 >> 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)
     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
@@ -553,11 +627,15 @@ instance Serialize (Instruction Natural) where
             0x10 -> Call <$> getULEB128 32
             0x11 -> do
                 typeIdx <- getULEB128 32
-                byteGuard 0x00
+                tableIdx <- getULEB128 32
-                return $ CallIndirect typeIdx
+                return $ CallIndirect tableIdx typeIdx
+            -- Reference instructions
+            0xD0 -> RefNull <$> get
+            0xD1 -> return RefIsNull
+            0xD2 -> RefFunc <$> getULEB128 32
             -- Parametric instructions
             0x1A -> return $ Drop
-            0x1B -> return $ Select
+            0x1B -> return $ Select Nothing
             -- Variable instructions
             0x20 -> GetLocal <$> getULEB128 32
             0x21 -> SetLocal <$> getULEB128 32
@@ -588,8 +666,8 @@ instance Serialize (Instruction Natural) where
             0x3C -> I64Store8 <$> get
             0x3D -> I64Store16 <$> get
             0x3E -> I64Store32 <$> get
-            0x3F -> byteGuard 0x00 >> (return $ CurrentMemory)
+            0x3F -> byteGuard 0x00 >> (return $ MemorySize)
-            0x40 -> byteGuard 0x00 >> (return $ GrowMemory)
+            0x40 -> byteGuard 0x00 >> (return $ MemoryGrow)
             -- Numeric instructions
             0x41 -> I32Const <$> getSLEB128 32
             0x42 -> I64Const <$> getSLEB128 64
@@ -735,7 +813,14 @@ 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"
+            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
 putExpression expr = do
@@ -793,11 +878,56 @@ instance Serialize Export where
     get = Export <$> getName <*> get
 
 instance Serialize ElemSegment where
-    put (ElemSegment tableIndex offset funcIndexes) = do
+    put (ElemSegment elemType Passive elements) = do
+        putWord8 0x05
+        put elemType
+        putVec $ map Expr elements
+    put (ElemSegment elemType (Active tableIndex offset) elements) = do
+        putWord8 0x06
         putULEB128 tableIndex
         putExpression offset
-        putVec $ map Index funcIndexes
+        put elemType
-    get = ElemSegment <$> getULEB128 32 <*> getExpression <*> (map unIndex <$> getVec)
+        putVec $ map Expr elements
+    put (ElemSegment elemType Declarative elements) = do
+        putWord8 0x07
+        put elemType
+        putVec $ map Expr elements
+
+    get = do
+        let funcIndexes = map ((:[]) . RefFunc . unIndex) <$> getVec
+        let elemKind = byteGuard 0x00 >> return FuncRef
+        op <- getULEB128 32
+        case (op :: Word8) of
+            0x00 -> do
+                offset <- getExpression
+                ElemSegment FuncRef (Active 0 offset) <$> funcIndexes
+            0x01 -> do
+                elemType <- elemKind
+                ElemSegment elemType Passive <$> funcIndexes
+            0x02 -> do
+                tableIndex <- getULEB128 32
+                offset <- getExpression
+                elemType <- elemKind
+                ElemSegment elemType (Active tableIndex offset) <$> funcIndexes
+            0x03 -> do
+                elemType <- elemKind
+                ElemSegment elemType Declarative <$> funcIndexes
+            0x04 -> do
+                offset <- getExpression
+                ElemSegment FuncRef (Active 0 offset) <$> funcIndexes
+            0x05 -> do
+                elemType <- get
+                ElemSegment elemType Passive . map unExpr <$> getVec
+            0x06 -> do
+                tableIndex <- getULEB128 32
+                offset <- getExpression
+                elemType <- get
+                ElemSegment elemType (Active tableIndex offset) <$> getVec
+            0x07 -> do
+                elemType <- get
+                ElemSegment elemType Declarative <$> getVec
+            _ ->
+                fail "unknown element segment type"
 
 data LocalTypeRange = LocalTypeRange Natural ValueType deriving (Show, Eq)
 
@@ -824,17 +954,35 @@ instance Serialize Function where
         return $ Function 0 locals body
 
 instance Serialize DataSegment where
-    put (DataSegment memIdx offset init) = do
+    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
+        op <- getULEB128 32
-        offset <- getExpression
+        case (op :: Word8) of
-        len <- getULEB128 32
+            0x00 -> do
-        init <- getLazyByteString len
+                offset <- getExpression
-        return $ DataSegment memIdx offset init
+                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/Builder.hs

@@ -197,7 +197,7 @@ select pred a b = select' (produce pred) (produce a) (produce b)
             a
             res <- b
             pred
-            appendExpr [Select]
+            appendExpr [Select Nothing]
             return res
 
 iBinOp :: (Producer a, Producer b, OutType a ~ OutType b, IsInt (OutType a) ~ True) => IBinOp -> a -> b -> GenFun (OutType a)
@@ -643,10 +643,10 @@ store32 addr val offset align = do
     appendExpr [I64Store32 $ MemArg (fromIntegral offset) (fromIntegral align)]
 
 memorySize :: GenFun (Proxy I32)
-memorySize = appendExpr [CurrentMemory] >> return Proxy
+memorySize = appendExpr [MemorySize] >> return Proxy
 
 growMemory :: (Producer size, OutType size ~ Proxy I32) => size -> GenFun ()
-growMemory size = produce size >> appendExpr [GrowMemory]
+growMemory size = produce size >> appendExpr [MemoryGrow]
 
 call :: (Returnable res) => Fn res -> [GenFun a] -> GenFun res
 call (Fn idx) args = sequence_ args >> appendExpr [Call idx] >> return returnableValue
@@ -655,7 +655,7 @@ callIndirect :: (Producer index, OutType index ~ Proxy I32, Returnable res) => T
 callIndirect (TypeDef idx) index args = do
     sequence_ args
     produce index
-    appendExpr [CallIndirect idx]
+    appendExpr [CallIndirect 0 idx]
     return returnableValue
 
 br :: Label t -> GenFun ()
@@ -975,7 +975,7 @@ table min max = do
 dataSegment :: (Producer offset, OutType offset ~ Proxy I32) => offset -> LBS.ByteString -> GenMod ()
 dataSegment offset bytes =
     modify $ \(st@GenModState { target = m }) -> st {
-        target = m { datas = datas m ++ [DataSegment 0 (genExpr 0 (produce offset)) bytes] }
+        target = m { datas = datas m ++ [DataSegment (ActiveData 0 (genExpr 0 (produce offset))) bytes] }
     }
 
 asWord32 :: Int32 -> Word32

src/Language/Wasm/Lexer.x

@@ -5,6 +5,8 @@ module Language.Wasm.Lexer (
     Lexeme(..),
     Token(..),
     AlexPosn(..),
+    FloatRep(..),
+    NaN(..),
     scanner,
     asFloat,
     asDouble,
@@ -22,6 +24,8 @@ import Data.List (isPrefixOf)
 import Text.Read (readEither)
 import Data.Bits
 import Numeric (showHex)
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
 
 }
 
@@ -35,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+)*
@@ -76,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 }
@@ -115,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 -> 
@@ -144,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 ->
@@ -222,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)
@@ -295,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
@@ -358,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,8 +11,10 @@ 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)
 
 import Language.Wasm.Parser (
         Ident(..),
@@ -29,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 ()
 
@@ -55,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]),
@@ -72,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,
@@ -117,12 +123,22 @@ 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 _                   = error "Only const instructions supported as arguments for actions"
+        asArg (Parser.ExactValue (Struct.V128Const v)) = Interpreter.VV128 v
+        asArg (Parser.ExactValue (Struct.RefNull Struct.FuncRef)) = Interpreter.RF Nothing
+        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
@@ -137,10 +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
@@ -161,7 +198,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 ()
@@ -169,15 +206,16 @@ runScript onAssertFail script = do
 
         getFailureString :: Validate.ValidationError -> [TL.Text]
         getFailureString (Validate.TypeMismatch _ _) = ["type mismatch"]
+        getFailureString (Validate.RefTypeMismatch _ _) = ["type mismatch"]
         getFailureString Validate.ResultTypeDoesntMatch = ["type mismatch"]
         getFailureString Validate.MoreThanOneMemory = ["multiple memories"]
-        getFailureString Validate.MoreThanOneTable = ["multiple tables"]
         getFailureString (Validate.LocalIndexOutOfRange idx) = ["unknown local", "unknown local " <> TL.pack (show idx)]
         getFailureString (Validate.MemoryIndexOutOfRange idx) = ["unknown memory", "unknown memory " <> TL.pack (show idx)]
         getFailureString (Validate.TableIndexOutOfRange idx) = ["unknown table", "unknown table " <> TL.pack (show idx)]
-        getFailureString Validate.FunctionIndexOutOfRange = ["unknown function", "unknown function 0"]
+        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)"]
@@ -188,7 +226,10 @@ runScript onAssertFail script = do
         getFailureString Validate.GlobalIsImmutable = ["global is immutable"]
         getFailureString Validate.InvalidStartFunctionType = ["start function"]
         getFailureString Validate.InvalidTableType = ["size minimum must not be greater than maximum"]
-        getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]]
+        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]]
 
         printFailedAssert :: String -> Assertion -> AssertM ()
         printFailedAssert msg assert = do
@@ -206,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) =
@@ -253,12 +294,14 @@ 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" ->
                             State.modify $ \(st, pos) -> (st { store = store' }, pos)
-                        _ -> printFailedAssert ("Module linking should fail with trap during execution of a start function") assert
+                        r -> printFailedAssert "Module linking should fail with trap during execution of a start function" assert
                 Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
         runAssert assert@(AssertExhaustion action failureString) = do
             result <- runActionInAssert action

src/Language/Wasm/Structure.hs

@@ -4,8 +4,10 @@
 
 module Language.Wasm.Structure (
     Module(..),
+    DataMode(..),
     DataSegment(..),
     ElemSegment(..),
+    ElemMode(..),
     StartFunction(..),
     Export(..),
     ExportDesc(..),
@@ -31,6 +33,7 @@ module Language.Wasm.Structure (
     FuncType(..),
     ValueType(..),
     BlockType(..),
+    SimdShape(..),
     ParamsType,
     ResultType,
     LocalsType,
@@ -51,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
@@ -65,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
@@ -83,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)
 
@@ -102,12 +123,17 @@ type LocalIndex = Natural
 type GlobalIndex = Natural
 type MemoryIndex = Natural
 type TableIndex = Natural
+type DataIndex = Natural
+type ElemIndex = Natural
 
 data ValueType =
     I32
     | I64
     | F32
     | F64
+    | V128
+    | Func
+    | Extern
     deriving (Show, Eq, Generic, NFData)
 
 type ResultType = [ValueType]
@@ -133,10 +159,15 @@ data Instruction index =
     | BrTable [index] index
     | Return
     | Call index
-    | CallIndirect index
+    | CallIndirect index index
+    -- Reference instructions
+    | RefNull ElemType
+    | RefIsNull
+    | RefFunc index
+    | RefExtern Natural
     -- Parametric instructions
     | Drop
-    | Select
+    | Select (Maybe [ValueType])
     -- Variable instructions
     | GetLocal index
     | SetLocal index
@@ -148,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
@@ -162,18 +210,37 @@ 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
     | I64Store16 MemArg
     | I64Store32 MemArg
-    | CurrentMemory
+    | MemorySize
-    | GrowMemory
+    | MemoryGrow
+    | MemoryFill
+    | MemoryCopy
+    | MemoryInit DataIndex
+    | DataDrop DataIndex
+    -- Table instructions
+    | TableInit TableIndex ElemIndex
+    | TableGrow TableIndex
+    | TableSize TableIndex
+    | TableFill TableIndex
+    | TableGet TableIndex
+    | TableSet TableIndex
+    | TableCopy TableIndex TableIndex
+    | ElemDrop ElemIndex
     -- Numeric instructions
     | I32Const Word32
     | I64Const Word64
     | F32Const Float
     | F64Const Double
+    | V128Const ByteArray.ByteArray
     | IUnOp BitSize IUnOp
     | IBinOp BitSize IBinOp
     | I32Eqz
@@ -195,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]
@@ -207,7 +291,7 @@ data Function = Function {
 
 data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq, Generic, NFData)
 
-data ElemType = FuncRef deriving (Show, Eq, Generic, NFData)
+data ElemType = FuncRef | ExternRef deriving (Show, Eq, Generic, NFData)
 
 data TableType = TableType Limit ElemType deriving (Show, Eq, Generic, NFData)
 
@@ -222,15 +306,25 @@ data Global = Global {
     initializer :: Expression
 } deriving (Show, Eq, Generic, NFData)
 
+data ElemMode =
+    Passive
+    | Active TableIndex Expression
+    | Declarative
+    deriving (Show, Eq, Generic, NFData)
+
 data ElemSegment = ElemSegment {
-    tableIndex :: TableIndex,
+    elemType :: ElemType,
-    offset :: Expression,
+    mode :: ElemMode,
-    funcIndexes :: [FuncIndex]
+    elements :: [Expression]
 } deriving (Show, Eq, Generic, NFData)
 
+data DataMode =
+    PassiveData
+    | ActiveData MemoryIndex Expression
+    deriving (Show, Eq, Generic, NFData)
+
 data DataSegment = DataSegment {
-    memIndex :: MemoryIndex,
+    dataMode :: DataMode,
-    offset :: Expression,
     chunk :: LBS.ByteString
 } deriving (Show, Eq, Generic, NFData)
 

src/Language/Wasm/Validate.hs

@@ -15,11 +15,11 @@ import Language.Wasm.Structure
 import qualified Data.Set as Set
 import Data.List (foldl')
 import qualified Data.Text.Lazy as TL
-import Data.Maybe (fromMaybe, maybeToList, catMaybes)
+import Data.Maybe (fromMaybe, catMaybes)
 import Numeric.Natural (Natural)
 import Prelude hiding ((<>))
 
-import Control.Monad (foldM)
+import Control.Monad (foldM, forM_, when, unless)
 import Control.Monad.Reader (ReaderT, runReaderT, withReaderT, ask)
 import Control.Monad.Except (Except, runExcept, throwError)
 
@@ -32,20 +32,24 @@ data ValidationError =
     | MemoryLimitExceeded
     | AlignmentOverflow
     | MoreThanOneMemory
-    | MoreThanOneTable
+    | FunctionIndexOutOfRange Natural
-    | FunctionIndexOutOfRange
     | TableIndexOutOfRange Natural
     | MemoryIndexOutOfRange Natural
     | LocalIndexOutOfRange Natural
     | GlobalIndexOutOfRange Natural
+    | ElemIndexOutOfRange Natural
+    | DataIndexOutOfRange Natural
     | LabelIndexOutOfRange
+    | LaneIndexOutOfRange
     | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
     | TypeMismatch { actual :: Arrow, expected :: Arrow }
+    | RefTypeMismatch ElemType ElemType
     | InvalidResultArity
     | InvalidConstantExpr
     | InvalidStartFunctionType
     | GlobalIsImmutable
+    | UndeclaredFunctionRef Natural
     deriving (Show, Eq)
 
 type ValidationResult = Either ValidationError ()
@@ -62,13 +66,14 @@ instance Monoid ValidationResult where
 
 isValid :: ValidationResult -> Bool
 isValid (Right ()) = True
-isValid (Left reason) = Debug.trace ("Module mismatched with reason " ++ show reason) $ False
+isValid (Left reason) = False
 
 type Validator = Module -> ValidationResult
 
 data VType =
     Val ValueType
     | Var
+    | NonRefVar
     | Any
     deriving (Show, Eq)
 
@@ -103,6 +108,11 @@ asArrow (FuncType params results) = Arrow (map Val params) (map Val $ reverse re
 isArrowMatch :: Arrow -> Arrow -> Bool
 isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
     where
+        isRef :: VType -> Bool
+        isRef (Val Func) = True
+        isRef (Val Extern) = True
+        isRef _            = False
+
         isEndMatch :: End -> End -> Bool
         isEndMatch (Any:l) (Any:r) =
             let (leftTail, rightTail) = unzip $ zip (takeWhile (/= Any) $ reverse l) (takeWhile (/= Any) $ reverse r) in
@@ -119,6 +129,12 @@ isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
         isEndMatch (x:l) (Var:r) =
             let subst = replace Var x in
             isEndMatch (subst l) (subst r)
+        isEndMatch (NonRefVar:l) (x:r) =
+            let subst = replace NonRefVar x in
+            isEndMatch (subst l) (subst r)
+        isEndMatch (x:l) (NonRefVar:r) =
+            let subst = replace NonRefVar x in
+            isEndMatch (subst l) (subst r)
         isEndMatch (Val v:l) (Val v':r) = v == v' && isEndMatch l r
         isEndMatch [] [] = True
         isEndMatch _ _ = False
@@ -126,13 +142,16 @@ 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],
     globals :: [GlobalType],
     locals :: [ValueType],
     labels :: [[ValueType]],
     returns :: [ValueType],
-    importedGlobals :: Natural
+    importedGlobals :: Natural,
+    refs :: Set.Set Natural
 } deriving (Show, Eq)
 
 type Checker = ReaderT Ctx (Except ValidationError)
@@ -174,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 
@@ -197,24 +219,28 @@ getResultType (TypeIndex typeIdx) = do
     Ctx { types } <- ask
     maybeToEither TypeIndexOutOfRange $ results <$> types !? typeIdx
 
-getInstrType :: Instruction Natural -> Checker Arrow
+elemTypeToRefType :: ElemType -> ValueType 
-getInstrType Unreachable = return $ Any ==> Any
+elemTypeToRefType FuncRef = Func
-getInstrType Nop = return $ empty ==> empty
+elemTypeToRefType ExternRef = Extern
-getInstrType Block { blockType, body } = do
+
+getInstrType :: [VType] -> Instruction Natural -> Checker Arrow
+getInstrType _ Unreachable = return $ Any ==> Any
+getInstrType _ Nop = return $ empty ==> empty
+getInstrType _ Block { blockType, body } = do
     bt@(Arrow from _) <- getBlockType blockType
     resultType <- getResultType blockType
     t <- withLabel resultType $ getExpressionTypeWithInput from body
     if isArrowMatch t bt
     then return bt
     else throwError $ TypeMismatch t bt
-getInstrType Loop { blockType, body } = do
+getInstrType _ Loop { blockType, body } = do
     bt@(Arrow from _) <- getBlockType blockType
     resultType <- getResultType blockType
     t <- withLabel (map (\(Val v) -> v) from) $ getExpressionTypeWithInput from body
     if isArrowMatch t bt
     then return bt
     else throwError $ TypeMismatch t bt
-getInstrType If { blockType, true, false } = do
+getInstrType _ If { blockType, true, false } = do
     bt@(Arrow from _) <- getBlockType blockType
     resultType <- getResultType blockType
     l <- withLabel resultType $ getExpressionTypeWithInput from true
@@ -227,185 +253,411 @@ getInstrType If { blockType, true, false } = do
             else (throwError $ TypeMismatch r bt)
         )
     else throwError $ TypeMismatch l bt
-getInstrType (Br lbl) = do
+getInstrType _ (Br lbl) = do
     r <- map Val <$> getLabel lbl
     return $ (Any : r) ==> Any
-getInstrType (BrIf lbl) = do
+getInstrType _ (BrIf lbl) = do
     r <- map Val <$> getLabel lbl
     return $ (r ++ [Val I32]) ==> r
-getInstrType (BrTable lbls lbl) = do
+getInstrType stack (BrTable lbls lbl) = do
     r <- getLabel lbl
-    rs <- mapM getLabel lbls
+    let returns lbl = do
-    if all (== r) rs
+            args <- map Val <$> getLabel lbl
+            res <- matchStack stack (Val I32 : reverse args) []
+            return (args, res)
+    alternatives <- mapM returns lbls
+    (_, def) <- returns lbl
+    if all (\(args, res) -> res == def && length args == length r) alternatives
     then return $ ([Any] ++ (map Val r) ++ [Val I32]) ==> Any
     else throwError ResultTypeDoesntMatch
-getInstrType Return = do
+getInstrType _ Return = do
     Ctx { returns } <- ask
     return $ (Any : (map Val returns)) ==> Any
-getInstrType (Call fun) = do
+getInstrType _ (Call fun) = do
     Ctx { funcs } <- ask
-    maybeToEither FunctionIndexOutOfRange $ asArrow <$> funcs !? fun
+    maybeToEither (FunctionIndexOutOfRange fun) $ asArrow <$> funcs !? fun
-getInstrType (CallIndirect sign) = do
+getInstrType _ (CallIndirect tableIdx sign) = do
-    Ctx { types, tables } <- ask
+    Ctx { types, tableTypes = tables } <- ask
-    if length tables < 1
+    if length tables <= fromIntegral tableIdx
-    then throwError (TableIndexOutOfRange 0)
+    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
+getInstrType _ Drop = do
     var <- freshVar
     return $ var ==> empty
-getInstrType Select = do
+getInstrType _ (Select Nothing) = do
-    var <- freshVar
+    var <- return NonRefVar
     return $ [var, var, Val I32] ==> var
-getInstrType (GetLocal local) = do
+getInstrType _ (Select (Just vt)) =
+    case vt of
+        [t] -> return $ [t, t, I32] ==> t
+        _ -> throwError InvalidResultArity
+getInstrType _ (RefNull elType) = do
+    let t = case elType of { FuncRef -> Func; ExternRef -> Extern }
+    return $ empty ==> Val t
+getInstrType _ RefIsNull = do
+    var <- freshVar
+    return $ var ==> Val I32
+getInstrType _ (RefFunc funIdx) = do
+    Ctx { funcs, refs } <- ask
+    if fromIntegral funIdx < length funcs
+    then do
+        unless (Set.member funIdx refs) $
+            throwError $ UndeclaredFunctionRef $ fromIntegral funIdx
+        return $ empty ==> Val Func
+    else throwError $ FunctionIndexOutOfRange $ fromIntegral funIdx
+getInstrType _ (GetLocal local) = do
     Ctx { locals }  <- ask
     t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
     return $ empty ==> Val t
-getInstrType (SetLocal local) = do
+getInstrType _ (SetLocal local) = do
     Ctx { locals } <- ask
     t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
     return $ Val t ==> empty
-getInstrType (TeeLocal local) = do
+getInstrType _ (TeeLocal local) = do
     Ctx { locals } <- ask
     t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
     return $ Val t ==> Val t
-getInstrType (GetGlobal global) = do
+getInstrType _ (GetGlobal global) = do
     Ctx { globals } <- ask
     t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global
     return $ empty ==> t
-getInstrType (SetGlobal global) = do
+getInstrType _ (SetGlobal global) = do
     Ctx { globals } <- ask
     t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global
     shouldBeMut $ globals !! fromIntegral global
     return $ t ==> empty
-getInstrType (I32Load memarg) = do
+getInstrType _ (I32Load memarg) = do
     checkMemoryInstr 4 memarg
     return $ I32 ==> I32
-getInstrType (I64Load memarg) = do
+getInstrType _ (I64Load memarg) = do
     checkMemoryInstr 8 memarg
     return $ I32 ==> I64
-getInstrType (F32Load memarg) = do
+getInstrType _ (F32Load memarg) = do
     checkMemoryInstr 4 memarg
     return $ I32 ==> F32
-getInstrType (F64Load memarg) = do
+getInstrType _ (F64Load memarg) = do
     checkMemoryInstr 8 memarg
     return $ I32 ==> F64
-getInstrType (I32Load8S memarg) = do
+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
-getInstrType (I32Load8U memarg) = do
+getInstrType _ (I32Load8U memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> I32
-getInstrType (I32Load16S memarg) = do
+getInstrType _ (I32Load16S memarg) = do
     checkMemoryInstr 2 memarg
     return $ I32 ==> I32
-getInstrType (I32Load16U memarg) = do
+getInstrType _ (I32Load16U memarg) = do
     checkMemoryInstr 2 memarg
     return $ I32 ==> I32
-getInstrType (I64Load8S memarg) = do
+getInstrType _ (I64Load8S memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> I64
-getInstrType (I64Load8U memarg) = do
+getInstrType _ (I64Load8U memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> I64
-getInstrType (I64Load16S memarg) = do
+getInstrType _ (I64Load16S memarg) = do
     checkMemoryInstr 2 memarg
     return $ I32 ==> I64
-getInstrType (I64Load16U memarg) = do
+getInstrType _ (I64Load16U memarg) = do
     checkMemoryInstr 2 memarg
     return $ I32 ==> I64
-getInstrType (I64Load32S memarg) = do
+getInstrType _ (I64Load32S memarg) = do
     checkMemoryInstr 4 memarg
     return $ I32 ==> I64
-getInstrType (I64Load32U memarg) = do
+getInstrType _ (I64Load32U memarg) = do
     checkMemoryInstr 4 memarg
     return $ I32 ==> I64
-getInstrType (I32Store memarg) = do
+getInstrType _ (I32Store memarg) = do
     checkMemoryInstr 4 memarg
     return $ [I32, I32] ==> empty
-getInstrType (I64Store memarg) = do
+getInstrType _ (I64Store memarg) = do
     checkMemoryInstr 8 memarg
     return $ [I32, I64] ==> empty
-getInstrType (F32Store memarg) = do
+getInstrType _ (F32Store memarg) = do
     checkMemoryInstr 4 memarg
     return $ [I32, F32] ==> empty
-getInstrType (F64Store memarg) = do
+getInstrType _ (F64Store memarg) = do
     checkMemoryInstr 8 memarg
     return $ [I32, F64] ==> empty
-getInstrType (I32Store8 memarg) = do
+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
-getInstrType (I32Store16 memarg) = do
+getInstrType _ (I32Store16 memarg) = do
     checkMemoryInstr 2 memarg
     return $ [I32, I32] ==> empty
-getInstrType (I64Store8 memarg) = do
+getInstrType _ (I64Store8 memarg) = do
     checkMemoryInstr 1 memarg
     return $ [I32, I64] ==> empty
-getInstrType (I64Store16 memarg) = do
+getInstrType _ (I64Store16 memarg) = do
     checkMemoryInstr 2 memarg
     return $ [I32, I64] ==> empty
-getInstrType (I64Store32 memarg) = do
+getInstrType _ (I64Store32 memarg) = do
     checkMemoryInstr 4 memarg
     return $ [I32, I64] ==> empty
-getInstrType CurrentMemory = do
+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)
-getInstrType GrowMemory = do
+    return $ empty ==> I32
-    Ctx { mems } <- ask 
+getInstrType _ MemoryGrow = do
-    if length mems < 1 then throwError (MemoryIndexOutOfRange 0) else return $ I32 ==> I32
+    Ctx { mems } <- ask
-getInstrType (I32Const _) = return $ empty ==> I32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
-getInstrType (I64Const _) = return $ empty ==> I64
+    return $ I32 ==> I32
-getInstrType (F32Const _) = return $ empty ==> F32
+getInstrType _ MemoryFill = do
-getInstrType (F64Const _) = return $ empty ==> F64
+    Ctx { mems } <- ask
-getInstrType (IUnOp BS32 _) = return $ I32 ==> I32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
-getInstrType (IUnOp BS64 _) = return $ I64 ==> I64
+    return $ [I32, I32, I32] ==> empty
-getInstrType (IBinOp BS32 _) = return $ [I32, I32] ==> I32
+getInstrType _ MemoryCopy = do
-getInstrType (IBinOp BS64 _) = return $ [I64, I64] ==> I64
+    Ctx { mems } <- ask
-getInstrType I32Eqz = return $ I32 ==> I32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
-getInstrType I64Eqz = return $ I64 ==> I32
+    return $ [I32, I32, I32] ==> empty
-getInstrType (IRelOp BS32 _) = return $ [I32, I32] ==> I32
+getInstrType _ (MemoryInit dataIdx) = do
-getInstrType (IRelOp BS64 _) = return $ [I64, I64] ==> I32
+    Ctx { mems, datas } <- ask
-getInstrType (FUnOp BS32 _) = return $ F32 ==> F32
+    when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
-getInstrType (FUnOp BS64 _) = return $ F64 ==> F64
+    when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
-getInstrType (FBinOp BS32 _) = return $ [F32, F32] ==> F32
+    return $ [I32, I32, I32] ==> empty
-getInstrType (FBinOp BS64 _) = return $ [F64, F64] ==> F64
+getInstrType _ (DataDrop dataIdx) = do
-getInstrType (FRelOp BS32 _) = return $ [F32, F32] ==> I32
+    Ctx { datas } <- ask
-getInstrType (FRelOp BS64 _) = return $ [F64, F64] ==> I32
+    when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
-getInstrType I32WrapI64 = return $ I64 ==> I32
+    return $ empty ==> empty
-getInstrType (ITruncFU BS32 BS32) = return $ F32 ==> I32
+getInstrType _ (TableInit tableIdx elemIdx) = do
-getInstrType (ITruncFU BS32 BS64) = return $ F64 ==> I32
+    Ctx { tableTypes = tables, elems } <- ask
-getInstrType (ITruncFU BS64 BS32) = return $ F32 ==> I64
+    when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
-getInstrType (ITruncFU BS64 BS64) = return $ F64 ==> I64
+    when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
-getInstrType (ITruncFS BS32 BS32) = return $ F32 ==> I32
+    let TableType _ tableType = tables !! fromIntegral tableIdx
-getInstrType (ITruncFS BS32 BS64) = return $ F64 ==> I32
+    let elemType = elems !! fromIntegral elemIdx
-getInstrType (ITruncFS BS64 BS32) = return $ F32 ==> I64
+    when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
-getInstrType (ITruncFS BS64 BS64) = return $ F64 ==> I64
+    return $ [I32, I32, I32] ==> empty
-getInstrType (ITruncSatFU BS32 BS32) = return $ F32 ==> I32
+getInstrType _ (TableCopy toIdx fromIdx) = do
-getInstrType (ITruncSatFU BS32 BS64) = return $ F64 ==> I32
+    Ctx { tableTypes = tables } <- ask
-getInstrType (ITruncSatFU BS64 BS32) = return $ F32 ==> I64
+    let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx)
-getInstrType (ITruncSatFU BS64 BS64) = return $ F64 ==> I64
+    when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx)
-getInstrType (ITruncSatFS BS32 BS32) = return $ F32 ==> I32
+    when (length tables <= to) $ throwError (TableIndexOutOfRange toIdx)
-getInstrType (ITruncSatFS BS32 BS64) = return $ F64 ==> I32
+    let TableType _ fromType = tables !! from
-getInstrType (ITruncSatFS BS64 BS32) = return $ F32 ==> I64
+    let TableType _ toType = tables !! to
-getInstrType (ITruncSatFS BS64 BS64) = return $ F64 ==> I64
+    when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType)
-getInstrType I64ExtendSI32 = return $ I32 ==> I64
+    return $ [I32, I32, I32] ==> empty
-getInstrType I64ExtendUI32 = return $ I32 ==> I64
+getInstrType _ (TableFill tableIdx) = do
-getInstrType (FConvertIU BS32 BS32) = return $ I32 ==> F32
+    Ctx { tableTypes = tables } <- ask
-getInstrType (FConvertIU BS32 BS64) = return $ I64 ==> F32
+    when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
-getInstrType (FConvertIU BS64 BS32) = return $ I32 ==> F64
+    let TableType _ tableType = tables !! fromIntegral tableIdx
-getInstrType (FConvertIU BS64 BS64) = return $ I64 ==> F64
+    return $ [I32, elemTypeToRefType tableType, I32] ==> empty
-getInstrType (FConvertIS BS32 BS32) = return $ I32 ==> F32
+getInstrType _ (TableSize tableIdx) = do
-getInstrType (FConvertIS BS32 BS64) = return $ I64 ==> F32
+    Ctx { tableTypes = tables } <- ask
-getInstrType (FConvertIS BS64 BS32) = return $ I32 ==> F64
+    when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
-getInstrType (FConvertIS BS64 BS64) = return $ I64 ==> F64
+    return $ empty ==> I32
-getInstrType F32DemoteF64 = return $ F64 ==> F32
+getInstrType _ (TableGrow tableIdx) = do
-getInstrType F64PromoteF32 = return $ F32 ==> F64
+    Ctx { tableTypes = tables } <- ask
-getInstrType (IReinterpretF BS32) = return $ F32 ==> I32
+    when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
-getInstrType (IReinterpretF BS64) = return $ F64 ==> I64
+    let TableType _ tableType = tables !! fromIntegral tableIdx
-getInstrType (FReinterpretI BS32) = return $ I32 ==> F32
+    return $ [elemTypeToRefType tableType, I32] ==> I32
-getInstrType (FReinterpretI BS64) = return $ I64 ==> F64
+getInstrType _ (TableGet tableIdx) = do
+    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 { tableTypes = tables } <- ask
+    when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
+    let TableType _ tableType = tables !! fromIntegral tableIdx
+    return $ [I32, elemTypeToRefType tableType] ==> empty
+getInstrType _ (ElemDrop elemIdx) = do
+    Ctx { elems } <- ask
+    when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
+    return $ empty ==> empty
+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
+getInstrType _ (ITruncFU BS64 BS32) = return $ F32 ==> I64
+getInstrType _ (ITruncFU BS64 BS64) = return $ F64 ==> I64
+getInstrType _ (ITruncFS BS32 BS32) = return $ F32 ==> I32
+getInstrType _ (ITruncFS BS32 BS64) = return $ F64 ==> I32
+getInstrType _ (ITruncFS BS64 BS32) = return $ F32 ==> I64
+getInstrType _ (ITruncFS BS64 BS64) = return $ F64 ==> I64
+getInstrType _ (ITruncSatFU BS32 BS32) = return $ F32 ==> I32
+getInstrType _ (ITruncSatFU BS32 BS64) = return $ F64 ==> I32
+getInstrType _ (ITruncSatFU BS64 BS32) = return $ F32 ==> I64
+getInstrType _ (ITruncSatFU BS64 BS64) = return $ F64 ==> I64
+getInstrType _ (ITruncSatFS BS32 BS32) = return $ F32 ==> I32
+getInstrType _ (ITruncSatFS BS32 BS64) = return $ F64 ==> I32
+getInstrType _ (ITruncSatFS BS64 BS32) = return $ F32 ==> I64
+getInstrType _ (ITruncSatFS BS64 BS64) = return $ F64 ==> I64
+getInstrType _ I64ExtendSI32 = return $ I32 ==> I64
+getInstrType _ I64ExtendUI32 = return $ I32 ==> I64
+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 _ _ [] = []
@@ -416,25 +668,46 @@ getExpressionTypeWithInput inp = fmap (inp `Arrow`) . foldM go inp
     where
         go :: [VType] -> Instruction Natural -> Checker [VType]
         go stack instr = do
-            (f `Arrow` t) <- getInstrType instr
+            (f `Arrow` t) <- getInstrType stack instr
             matchStack stack (reverse f) t
-        
+
-        matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType]
+isRef :: ValueType -> Bool
-        matchStack stack@(Any:_) _arg res = return $ res ++ stack
+isRef (Func)   = True
-        matchStack (Val v:stack) (Val v':args) res =
+isRef (Extern) = True
-            if v == v'
+isRef _        = False
-            then matchStack stack args res
+
-            else throwError $ TypeMismatch ((reverse $ Val v':args) `Arrow` res) ([] `Arrow` (Val v:stack))
+matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType]
-        matchStack _ (Any:_) res = return $ res
+matchStack stack@(Any:_) _arg res = return $ res ++ stack
-        matchStack (Val v:stack) (Var:args) res =
+matchStack (Val v:stack) (Val v':args) res =
-            let subst = replace Var (Val v) in
+    if v == v'
-            matchStack stack (subst args) (subst res)
+    then matchStack stack args res
-        matchStack (Var:stack) (Val v:args) res =
+    else throwError $ TypeMismatch ((reverse $ Val v':args) `Arrow` res) ([] `Arrow` (Val v:stack))
-            let subst = replace Var (Val v) in
+matchStack _ (Any:_) res = return $ res
-            matchStack stack (subst args) (subst res)
+matchStack (Val v:stack) (Var:args) res =
-        matchStack stack [] res = return $ res ++ stack
+    let subst = replace Var (Val v) in
-        matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` [])
+    matchStack stack (subst args) (subst res)
-        matchStack _ _ _ = error "inconsistent checker state"
+matchStack (Var:stack) (Val v:args) res =
+    let subst = replace Var (Val v) in
+    matchStack stack (subst args) (subst res)
+matchStack (Val v:stack) (NonRefVar:args) res =
+    let subst = replace NonRefVar (Val v) in
+    if isRef v
+    then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty)
+    else matchStack stack (subst args) (subst res)
+matchStack (NonRefVar:stack) (Val v:args) res =
+    let subst = replace NonRefVar (Val v) in
+    if isRef v
+    then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty)
+    else matchStack stack (subst args) (subst res)
+matchStack (Var:stack) (NonRefVar:args) res =
+    let subst = replace NonRefVar NonRefVar in
+    matchStack stack (subst args) (subst res)
+matchStack (NonRefVar:stack) (Var:args) res =
+    let subst = replace Var NonRefVar in
+    matchStack stack (subst args) (subst res)
+matchStack stack [] res = return $ res ++ stack
+matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` [])
+matchStack st args res = error $ "inconsistent checker state: " ++ show (st, args, res)
 
 getExpressionType :: Expression -> Checker Arrow
 getExpressionType = getExpressionTypeWithInput []
@@ -445,6 +718,9 @@ 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
     Ctx {globals, importedGlobals} <- ask
     if importedGlobals <= idx
@@ -464,20 +740,26 @@ getFuncTypes Module {types, functions, imports} =
         getFuncType _ = Nothing
 
 ctxFromModule :: [ValueType] -> [[ValueType]] -> [ValueType] -> Module -> Ctx
-ctxFromModule locals labels returns m@Module {types, tables, mems, globals, imports} =
+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
     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,
         globals = globalImports ++ map (\(Global g _) -> g) globals,
         locals,
         labels,
         returns,
-        importedGlobals = fromIntegral $ length globalImports
+        importedGlobals = fromIntegral $ length globalImports,
+        refs = Set.unions $ map getElemRefs elems
+            ++ map getGlobalRefs globals
+            ++ map getExportRefs exports
     }
     where
         getTableType (Import _ _ (ImportTable tableType)) = Just tableType
@@ -489,6 +771,19 @@ ctxFromModule locals labels returns m@Module {types, tables, mems, globals, impo
         getGlobalType (Import _ _ (ImportGlobal gl)) = Just gl
         getGlobalType _ = Nothing
 
+        getElemRefs ElemSegment{ elemType = FuncRef, elements} =
+            foldl extractRef Set.empty elements
+            where
+                extractRef refs [RefFunc idx] = Set.insert idx refs
+                extractRef refs _ = refs
+        getElemRefs _ = Set.empty
+
+        getGlobalRefs Global {initializer = [RefFunc idx]} = Set.singleton idx
+        getGlobalRefs _ = Set.empty
+
+        getExportRefs Export {desc = ExportFunc idx} = Set.singleton idx
+        getExportRefs _ = Set.empty
+
 isFunctionValid :: Function -> Validator
 isFunctionValid Function {funcType, localTypes = locals, body} mod@Module {types} =
     if fromIntegral funcType < length types
@@ -509,10 +804,7 @@ tablesShouldBeValid :: Validator
 tablesShouldBeValid Module { imports, tables } =
     let tableImports = filter isTableImport imports in
     let res = foldMap (\Import { desc = ImportTable t } -> isValidTableType t) tableImports in
-    let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in
+    foldl' (\r (Table t) -> r <> isValidTableType t) res tables
-    if length tableImports + length tables <= 1
-        then res'
-        else Left MoreThanOneTable
     where
         isValidTableType :: TableType -> ValidationResult
         isValidTableType (TableType (Limit min max) _) =
@@ -557,24 +849,30 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
     foldMap (isElemValid ctx) elems
     where
         isElemValid :: Ctx -> ElemSegment -> ValidationResult
-        isElemValid ctx (ElemSegment tableIdx offset funs) =
+        isElemValid ctx (ElemSegment elemType mode elements) = do
-            let check = runChecker ctx $ do
+            forM_ elements $ \elem -> runChecker ctx $ do
+                arr <- getExpressionType elem
+                isConstExpression elem
+                unless (isValidRef elemType arr)
+                    $ throwError $ RefTypeMismatch elemType elemType
+            case mode of
+                Active tableIdx offset -> runChecker ctx $ do
                     isConstExpression offset
                     t <- getExpressionType offset
-                    if isArrowMatch (empty ==> I32) t
+                    unless (isArrowMatch (empty ==> I32) t) $ do
-                    then return ()
+                        throwError $ TypeMismatch t (empty ==> I32)
-                    else throwError $ TypeMismatch t (empty ==> I32) 
+                    let tableImports = filter isTableImport imports
-            in
+                    when (tableIdx >= fromIntegral (length tableImports + length tables)) $ do
-            let tableImports = filter isTableImport imports in
+                        throwError $ TableIndexOutOfRange tableIdx
-            let isTableIndexValid =
+                    let TableType _ tableType = tableTypes ctx !! (fromIntegral tableIdx)
-                    if tableIdx < (fromIntegral $ length tableImports + length tables)
+                    when (tableType /= elemType) $ do
-                    then return ()
+                        throwError $ RefTypeMismatch elemType tableType
-                    else Left (TableIndexOutOfRange tableIdx)
+                _ -> return ()
-            in
+        
-            let funImports = filter isFuncImport imports in
+        isValidRef :: ElemType -> Arrow -> Bool
-            let funsLength = fromIntegral $ length functions + length funImports in
+        isValidRef FuncRef arr | arr == (empty ==> Func) = True
-            let isFunsValid = foldMap (\i -> if i < funsLength then return () else Left FunctionIndexOutOfRange) funs in
+        isValidRef ExternRef arr | arr == (empty ==> Extern) = True
-            check <> isFunsValid <> isTableIndexValid
+        isValidRef _ _ = False
 
 datasShouldBeValid :: Validator
 datasShouldBeValid m@Module { datas, mems, imports } =
@@ -582,7 +880,7 @@ datasShouldBeValid m@Module { datas, mems, imports } =
     foldMap (isDataValid ctx) datas
     where
         isDataValid :: Ctx -> DataSegment -> ValidationResult
-        isDataValid ctx (DataSegment memIdx offset _) =
+        isDataValid ctx (DataSegment (ActiveData memIdx offset) _) =
             let check = runChecker ctx $ do
                     isConstExpression offset
                     t <- getExpressionType offset
@@ -594,6 +892,7 @@ datasShouldBeValid m@Module { datas, mems, imports } =
             if memIdx < (fromIntegral $ length memImports + length mems)
             then check
             else Left (MemoryIndexOutOfRange memIdx)
+        isDataValid ctx (DataSegment PassiveData _) = return ()
 
 startShouldBeValid :: Validator
 startShouldBeValid Module { start = Nothing } = return ()
@@ -602,7 +901,7 @@ startShouldBeValid m@Module { start = Just (StartFunction idx) } =
     let i = fromIntegral idx in
     if length types > i
     then if FuncType [] [] == types !! i then return () else Left InvalidStartFunctionType
-    else Left FunctionIndexOutOfRange
+    else Left $ FunctionIndexOutOfRange $ fromIntegral i
 
 exportsShouldBeValid :: Validator
 exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals } =
@@ -615,7 +914,7 @@ exportsShouldBeValid Module { exports, imports, functions, mems, tables, globals
 
         isExportValid :: Export -> ValidationResult
         isExportValid (Export _ (ExportFunc funIdx)) =
-            if fromIntegral funIdx < length funcImports + length functions then return () else Left FunctionIndexOutOfRange
+            if fromIntegral funIdx < length funcImports + length functions then return () else Left (FunctionIndexOutOfRange funIdx)
         isExportValid (Export _ (ExportTable tableIdx)) =
             if fromIntegral tableIdx < length tableImports + length tables then return () else Left (TableIndexOutOfRange tableIdx)
         isExportValid (Export _ (ExportMemory memIdx)) =

stack.yaml

@@ -1,6 +1,6 @@
-resolver: lts-16.5
+resolver: lts-20.23 
 packages:
 - '.'
 extra-deps: []
 flags: {}
-extra-package-dbs: []
+extra-package-dbs: []

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 531707
+    sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/5.yaml
+    size: 650253
-    sha256: 9751e25e0af5713a53ddcfcc79564b082c71b1b357fadef0d85672a5b5ba3703
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml
-  original: lts-16.5
+  original: lts-20.23

tests/Test.hs

@@ -16,20 +16,16 @@ import qualified Data.List as List
 
 main :: IO ()
 main = do
-  let groups = [
+  files <-
-          ("Core Tests", "tests/spec"),
+    filter (List.isSuffixOf ".wast")
-          ("Reference Types Proposal", "tests/spec/proposals/reference-types")
+      <$> Directory.listDirectory "tests/spec"
-        ]
+  -- let files = ["align.wast"]
-  testGroups <- (`mapM` groups) $ \(groupName, dir) -> do
+  scriptTestCases <- (`mapM` files) $ \file -> do
-    files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory dir
+    test <- LBS.readFile ("tests/spec/" ++ file)
-    -- let files = ["const.wast"]
+    return $ testCase file $ do
-    scriptTestCases <- (`mapM` files) $ \file -> do
+      case Wasm.parseScript test of
-      test <- LBS.readFile (dir ++ "/" ++ file)
+        Right script -> 
-      return $ testCase file $ do
+          Script.runScript (\msg assert -> assertFailure ("Failed assert: " ++ msg ++ ". Assert " ++ show assert)) script
-        case Wasm.parseScript test of
+        Left error ->
-          Right script -> 
+          assertFailure $ "Failed to parse with error: " ++ show error
-            Script.runScript (\msg assert -> assertFailure ("Failed assert: " ++ msg ++ ". Assert " ++ show assert)) script
+  defaultMain $ testGroup "Wasm Core Test Suit" scriptTestCases
-          Left error ->
-            assertFailure $ "Failed to parse with error: " ++ show error
-    return $ testGroup groupName scriptTestCases
-  defaultMain $ testGroup "Wasm Test Suit" testGroups

wasm.cabal

@@ -1,6 +1,6 @@
 cabal-version:  2.2
 name:           wasm
-version:        1.0.1.0
+version:        1.1.2
 synopsis:       WebAssembly Language Toolkit and Interpreter
 description:
   Library for parsing and interpreting WebAssembly, including:
@@ -16,9 +16,9 @@ license:        MIT
 license-file:   LICENSE
 build-type:     Simple
 category:       Language
-homepage:       https:github.com/SPY/haskell-wasm
+homepage:       https://github.com/SPY/haskell-wasm
-bug-reports:    https:github.com/SPY/haskell-wasm/issues
+bug-reports:    https://github.com/SPY/haskell-wasm/issues
-tested-with:    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4
+tested-with:    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.2.7
 extra-source-files:
     README.md
     src/Language/Wasm/Parser.y
@@ -27,20 +27,20 @@ extra-source-files:
 source-repository head
   type: git
   location: https://github.com/SPY/haskell-wasm
-    
+
 library
   exposed-modules:
       Language.Wasm.Script
       Language.Wasm.Lexer
       Language.Wasm.Structure
-      Language.Wasm
-  other-modules:
-      Language.Wasm.Binary
-      Language.Wasm.Builder
-      Language.Wasm.FloatUtils
       Language.Wasm.Interpreter
       Language.Wasm.Parser
       Language.Wasm.Validate
+      Language.Wasm.Binary
+      Language.Wasm.Builder
+      Language.Wasm
+  other-modules:
+      Language.Wasm.FloatUtils
       Paths_wasm
   autogen-modules:
       Paths_wasm
@@ -56,18 +56,18 @@ 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
     , deepseq >=1.4 && < 1.5
     , ieee754 >=0.8 && < 0.9
-    , mtl >=2.2.1 && < 2.3
+    , mtl >=2.2.1 && < 2.4
     , primitive >=0.7 && < 0.8
-    , text >=1.1 && < 1.3
+    , text >=1.1 && < 3
-    , transformers >=0.4 && < 0.6
+    , transformers >=0.4 && < 0.7
     , utf8-string >=1.0 && < 1.1
-    , vector >=0.12 && < 0.13
+    , vector >=0.12.2 && < 0.14
   default-language: Haskell2010
 
 test-suite test