implement float cmp operations for simd

src/Language/Wasm/Interpreter.hs

@@ -1784,6 +1784,48 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             return $ Done ctx { stack = VI32 (if v1 <= v2 then 1 else 0) : rest }
         step ctx@EvalCtx{ stack = (VF64 v2:VF64 v1:rest) } (FRelOp BS64 FGe) =
             return $ Done ctx { stack = VI32 (if v1 >= v2 then 1 else 0) : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FEq) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a == wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a == wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FNe) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a /= wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a /= wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FLt) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a < wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a < wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FLe) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a <= wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a <= wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FGt) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a > wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a > wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FRelOp (BS128 shape) FGe) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> if wordToFloat a >= wordToFloat b then fromIntegral (-1) else 0
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> if wordToDouble a >= wordToDouble b then fromIntegral (-1) else 0
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
         step ctx@EvalCtx{ stack = (VI64 v:rest) } I32WrapI64 =
             return $ Done ctx { stack = VI32 (fromIntegral $ v .&. 0xFFFFFFFF) : rest }
         step ctx@EvalCtx{ stack = (VF32 v:rest) } (ITruncFU BS32 BS32) =

src/Language/Wasm/Parser.y

@@ -501,6 +501,18 @@ import Language.Wasm.Lexer (
 'f64x2.neg'           { Lexeme _ (TKeyword "f64x2.neg") }
 'f32x4.sqrt'          { Lexeme _ (TKeyword "f32x4.sqrt") }
 'f64x2.sqrt'          { Lexeme _ (TKeyword "f64x2.sqrt") }
+'f32x4.eq'            { Lexeme _ (TKeyword "f32x4.eq") }
+'f64x2.eq'            { Lexeme _ (TKeyword "f64x2.eq") }
+'f32x4.ne'            { Lexeme _ (TKeyword "f32x4.ne") }
+'f64x2.ne'            { Lexeme _ (TKeyword "f64x2.ne") }
+'f32x4.lt'            { Lexeme _ (TKeyword "f32x4.lt") }
+'f64x2.lt'            { Lexeme _ (TKeyword "f64x2.lt") }
+'f32x4.le'            { Lexeme _ (TKeyword "f32x4.le") }
+'f64x2.le'            { Lexeme _ (TKeyword "f64x2.le") }
+'f32x4.gt'            { Lexeme _ (TKeyword "f32x4.gt") }
+'f64x2.gt'            { Lexeme _ (TKeyword "f64x2.gt") }
+'f32x4.ge'            { Lexeme _ (TKeyword "f32x4.ge") }
+'f64x2.ge'            { Lexeme _ (TKeyword "f64x2.ge") }
 -- script extension
 'binary'              { Lexeme _ (TKeyword "binary") }
 'quote'               { Lexeme _ (TKeyword "quote") }
@@ -1034,6 +1046,18 @@ plaininstr :: { PlainInstr }
     | 'f64x2.neg'                        { FUnOp (BS128 F64x2) FNeg }
     | 'f32x4.sqrt'                       { FUnOp (BS128 F32x4) FSqrt }
     | 'f64x2.sqrt'                       { FUnOp (BS128 F64x2) FSqrt }
+    | 'f32x4.eq'                         { FRelOp (BS128 F32x4) FEq }
+    | 'f64x2.eq'                         { FRelOp (BS128 F64x2) FEq }
+    | 'f32x4.ne'                         { FRelOp (BS128 F32x4) FNe }
+    | 'f64x2.ne'                         { FRelOp (BS128 F64x2) FNe }
+    | 'f32x4.lt'                         { FRelOp (BS128 F32x4) FLt }
+    | 'f64x2.lt'                         { FRelOp (BS128 F64x2) FLt }
+    | 'f32x4.le'                         { FRelOp (BS128 F32x4) FLe }
+    | 'f64x2.le'                         { FRelOp (BS128 F64x2) FLe }
+    | 'f32x4.gt'                         { FRelOp (BS128 F32x4) FGt }
+    | 'f64x2.gt'                         { FRelOp (BS128 F64x2) FGt }
+    | 'f32x4.ge'                         { FRelOp (BS128 F32x4) FGe }
+    | 'f64x2.ge'                         { FRelOp (BS128 F64x2) FGe }
 
 typeuse(next)
     : '(' typeuse1(folded_instr_list(next), instruction_list(next)) {

src/Language/Wasm/Validate.hs

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

tests/Test.hs

@@ -20,7 +20,7 @@ main = do
     filter (List.isPrefixOf "simd") . 
     filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  -- let files = ["simd_f64x2_arith.wast"]
+  -- let files = ["simd_f64x2_cmp.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do