implement all simd instructiions

src/Language/Wasm/Interpreter.hs

@@ -2338,6 +2338,26 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
         step ctx@EvalCtx{ stack = (VV128 v:rest) } F32x4DemoteF64x2Zero =
             let r = doubleToFloat . ByteArray.indexByteArray v <$> [0..1] in
             return $ Done ctx { stack = VV128 (ByteArray.byteArrayFromList $ r ++ [0, 0]) : rest }
+        step ctx@EvalCtx{ stack = (VV128 x:VV128 y:rest) } I32x4DotI16x8S =
+            let dot :: Int -> Int -> Integer
+                dot n m =
+                    let x1 = fromIntegral $ asInt16 $ ByteArray.indexByteArray x n in
+                    let y1 = fromIntegral $ asInt16 $ ByteArray.indexByteArray y n in
+                    let x2 = fromIntegral $ asInt16 $ ByteArray.indexByteArray x m in
+                    let y2 = fromIntegral $ asInt16 $ ByteArray.indexByteArray y m in
+                    (x1 * y1) + (x2 * y2)
+            in
+            let r = fromIntegral <$> [dot 0 1, dot 2 3, dot 4 5, dot 6 7] in
+            return $ Done ctx { stack = VV128 (ByteArray.byteArrayFromList @Word32 $ r) : rest }
+        step ctx@EvalCtx{ stack = (VV128 x:VV128 y:rest) } I16x8Q15MulrSatS =
+            let clamp low high v = if v > high then high else if v < low then low else v in
+            let mulq15 a b =
+                    let x = fromIntegral $ asInt16 a in
+                    let y = fromIntegral $ asInt16 b in
+                    fromIntegral $ clamp (-0x8000) 0x7FFF $ ((x * y :: Integer) + 0x4000) `shiftR` 15
+            in
+            let r = lanewise I16x8 x y mulq15 in
+            return $ Done ctx { stack = VV128 r : rest }
         step EvalCtx{ stack } instr = error $ "Error during evaluation of instruction: " ++ show instr ++ ". Stack " ++ show stack
 eval _ _ _ HostInstance { funcType, hostCode } args = Just <$> hostCode args
 

src/Language/Wasm/Parser.y

@@ -588,6 +588,8 @@ import Language.Wasm.Lexer (
 'i32x4.trunc_sat_f32x4_u'       { Lexeme _ (TKeyword "i32x4.trunc_sat_f32x4_u") }
 'i32x4.trunc_sat_f64x2_s_zero'  { Lexeme _ (TKeyword "i32x4.trunc_sat_f64x2_s_zero") }
 'i32x4.trunc_sat_f64x2_u_zero'  { Lexeme _ (TKeyword "i32x4.trunc_sat_f64x2_u_zero") }
+'i32x4.dot_i16x8_s'             { Lexeme _ (TKeyword "i32x4.dot_i16x8_s") }
+'i16x8.q15mulr_sat_s'           { Lexeme _ (TKeyword "i16x8.q15mulr_sat_s") }
 -- script extension
 'binary'                        { Lexeme _ (TKeyword "binary") }
 'quote'                         { Lexeme _ (TKeyword "quote") }
@@ -1208,6 +1210,8 @@ plaininstr :: { PlainInstr }
     | 'i32x4.trunc_sat_f32x4_u'          { I32x4TruncSatF False BS32 }
     | 'i32x4.trunc_sat_f64x2_s_zero'     { I32x4TruncSatF True BS64 }
     | 'i32x4.trunc_sat_f64x2_u_zero'     { I32x4TruncSatF False BS64 }
+    | 'i32x4.dot_i16x8_s'                { I32x4DotI16x8S }
+    | 'i16x8.q15mulr_sat_s'              { I16x8Q15MulrSatS }
 
 typeuse(next)
     : '(' typeuse1(folded_instr_list(next), instruction_list(next)) {
@@ -1943,6 +1947,8 @@ data PlainInstr =
     | F32x4DemoteF64x2Zero
     | V128IExtend SimdShape SimdShape {- high -} Bool {- signed -} Bool
     | I32x4TruncSatF {- signed -} Bool {- Float Size -} BitSize
+    | I32x4DotI16x8S
+    | I16x8Q15MulrSatS
     deriving (Show, Eq)
 
 data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)
@@ -2550,6 +2556,8 @@ desugarize fields = do
         synInstrToStruct _ (PlainInstr (V128Narrow t f s)) = return $ S.V128Narrow t f s
         synInstrToStruct _ (PlainInstr (V128IExtend t f h s)) = return $ S.V128IExtend t f h s
         synInstrToStruct _ (PlainInstr (I32x4TruncSatF s sz)) = return $ S.I32x4TruncSatF s sz
+        synInstrToStruct _ (PlainInstr I32x4DotI16x8S) = return $ S.I32x4DotI16x8S
+        synInstrToStruct _ (PlainInstr I16x8Q15MulrSatS) = return $ S.I16x8Q15MulrSatS
         synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } BlockInstr {label, blockType, body} = do
             let ctx' = ctx { ctxLabels = label : ctxLabels ctx }
             bt <- case blockType of

src/Language/Wasm/Structure.hs

@@ -277,6 +277,8 @@ data Instruction index =
     | 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

@@ -631,6 +631,10 @@ 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

tests/Test.hs

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