reimplement script value matching logic and implement part of simd float arithmetic

src/Language/Wasm/Interpreter.hs

@@ -1710,6 +1710,34 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             return $ Done ctx { stack = VF64 (zeroAwareMax v1 v2) : rest }
         step ctx@EvalCtx{ stack = (VF64 v2:VF64 v1:rest) } (FBinOp BS64 FCopySign) =
             return $ Done ctx { stack = VF64 (copySign v1 v2) : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FBinOp (BS128 shape) FAdd) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> floatToWord $ wordToFloat a + wordToFloat b
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> doubleToWord $ wordToDouble a + wordToDouble b
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FBinOp (BS128 shape) FSub) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> floatToWord $ wordToFloat a - wordToFloat b
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> doubleToWord $ wordToDouble a - wordToDouble b
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FBinOp (BS128 shape) FMul) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> floatToWord $ wordToFloat a * wordToFloat b
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> doubleToWord $ wordToDouble a * wordToDouble b
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (FBinOp (BS128 shape) FDiv) =
+            let r = case shape of
+                    F32x4 -> lanewise @Word32 shape v1 v2 $ \a b -> floatToWord $ wordToFloat a / wordToFloat b
+                    F64x2 -> lanewise @Word64 shape v1 v2 $ \a b -> doubleToWord $ wordToDouble a / wordToDouble b
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
         step ctx@EvalCtx{ stack = (VF32 v2:VF32 v1:rest) } (FRelOp BS32 FEq) =
             return $ Done ctx { stack = VI32 (if v1 == v2 then 1 else 0) : rest }
         step ctx@EvalCtx{ stack = (VF32 v2:VF32 v1:rest) } (FRelOp BS32 FNe) =

src/Language/Wasm/Lexer.x

@@ -80,10 +80,10 @@ tokens :-
 <0> @id                                   { tokenStr TId }
 <0> "("                                   { constToken TOpenBracket }
 <0> ")"                                   { constToken TCloseBracket }
+<0> $sign? @hexfloat                      { parseHexFloat }
 <0> $sign? @num                           { parseDecimalSignedInt }
 <0> $sign? "0x" @hexnum                   { parseHexalSignedInt }
 <0> $sign? @float                         { parseDecFloat }
-<0> $sign? @hexfloat                      { parseHexFloat }
 <0, blockComment> @startblockcomment      { startBlockComment }
 <blockComment> [.\n]                      ;
 <blockComment> @endblockcomment           { endBlockComment }

src/Language/Wasm/Parser.y

@@ -38,7 +38,8 @@ module Language.Wasm.Parser (
     Command(..),
     Action(..),
     Assertion(..),
-    Meta(..)
+    Meta(..),
+    ValuePattern(..)
 ) where
 
 import Language.Wasm.Structure (
@@ -488,6 +489,18 @@ import Language.Wasm.Lexer (
 'i16x8.ge_u'         { Lexeme _ (TKeyword "i16x8.ge_u") }
 'i32x4.ge_u'         { Lexeme _ (TKeyword "i32x4.ge_u") }
 'i64x2.ge_u'         { Lexeme _ (TKeyword "i64x2.ge_u") }
+'f32x4.add'          { Lexeme _ (TKeyword "f32x4.add") }
+'f64x2.add'          { Lexeme _ (TKeyword "f64x2.add") }
+'f32x4.sub'          { Lexeme _ (TKeyword "f32x4.sub") }
+'f64x2.sub'          { Lexeme _ (TKeyword "f64x2.sub") }
+'f32x4.mul'          { Lexeme _ (TKeyword "f32x4.mul") }
+'f64x2.mul'          { Lexeme _ (TKeyword "f64x2.mul") }
+'f32x4.div'          { Lexeme _ (TKeyword "f32x4.div") }
+'f64x2.div'          { Lexeme _ (TKeyword "f64x2.div") }
+'f32x4.neg'          { Lexeme _ (TKeyword "f32x4.neg") }
+'f64x2.neg'          { Lexeme _ (TKeyword "f64x2.neg") }
+'f32x4.sqrt'         { Lexeme _ (TKeyword "f32x4.sqrt") }
+'f64x2.sqrt'         { Lexeme _ (TKeyword "f64x2.sqrt") }
 -- script extension
 'binary'              { Lexeme _ (TKeyword "binary") }
 'quote'               { Lexeme _ (TKeyword "quote") }
@@ -1009,6 +1022,18 @@ plaininstr :: { PlainInstr }
     | 'i16x8.ge_u'                       { IRelOp (BS128 I16x8) IGeU }
     | 'i32x4.ge_u'                       { IRelOp (BS128 I32x4) IGeU }
     | 'i64x2.ge_u'                       { IRelOp (BS128 I64x2) IGeU }
+    | 'f32x4.add'                        { FBinOp (BS128 F32x4) FAdd }
+    | 'f64x2.add'                        { FBinOp (BS128 F64x2) FAdd }
+    | 'f32x4.sub'                        { FBinOp (BS128 F32x4) FSub }
+    | 'f64x2.sub'                        { FBinOp (BS128 F64x2) FSub }
+    | 'f32x4.mul'                        { FBinOp (BS128 F32x4) FMul }
+    | 'f64x2.mul'                        { FBinOp (BS128 F64x2) FMul }
+    | 'f32x4.div'                        { FBinOp (BS128 F32x4) FDiv }
+    | 'f64x2.div'                        { FBinOp (BS128 F64x2) FDiv }
+    | 'f32x4.neg'                        { FUnOp (BS128 F32x4) FNeg }
+    | 'f64x2.neg'                        { FUnOp (BS128 F64x2) FNeg }
+    | 'f32x4.sqrt'                       { FUnOp (BS128 F32x4) FSqrt }
+    | 'f64x2.sqrt'                       { FUnOp (BS128 F64x2) FSqrt }
 
 typeuse(next)
     : '(' typeuse1(folded_instr_list(next), instruction_list(next)) {
@@ -1461,13 +1486,13 @@ module1 :: { ModuleDef }
 
 action1 :: { Action }
     : 'invoke' opt(ident) string list(folded_instr) ')' {%
-        fmap (Invoke $2 $3) $ (mapM (mapM constInstructionToValue) $4)
+        fmap (Invoke $2 $3) $ (mapM (constInstructionToValue . head) $4)
     }
     | 'get' opt(ident) string ')' { Get $2 $3 }
 
 assertion1 :: { (Maybe AlexPosn, Assertion) }
     : 'assert_return' '(' action1 list(folded_instr) ')' {%
-        fmap ((\a -> ($1, a)) . AssertReturn $3) $ (mapM (mapM constInstructionToValue) $4)
+        fmap ((\a -> ($1, a)) . AssertReturn $3) $ (mapM (constInstructionToValue . head) $4)
     }
     | 'assert_return_canonical_nan' '(' action1 ')' { ($1, AssertReturnCanonicalNaN $3) }
     | 'assert_return_arithmetic_nan' '(' action1 ')' { ($1, AssertReturnArithmeticNaN $3) }
@@ -1912,15 +1937,22 @@ data Command
     | Meta Meta
     deriving (Show, Eq)
 
+data ValuePattern =
+    ExactValue (S.Instruction Natural)
+    | CanonicalNan
+    | ArithmeticNan
+    | VectorPat SimdShape [ValuePattern]
+    deriving (Show, Eq)
+
 data Action
-    = Invoke (Maybe Ident) TL.Text [S.Expression]
+    = Invoke (Maybe Ident) TL.Text [ValuePattern]
     | Get (Maybe Ident) TL.Text
     deriving (Show, Eq)
 
 type FailureString = TL.Text
 
 data Assertion
-    = AssertReturn Action [S.Expression]
+    = AssertReturn Action [ValuePattern]
     | AssertReturnCanonicalNaN Action
     | AssertReturnArithmeticNaN Action
     | AssertTrap (Either Action ModuleDef) FailureString
@@ -1959,14 +1991,27 @@ v128RepToBytes (F32x4Const floats) =
 v128RepToBytes (F64x2Const doubles) =
     ByteArray.byteArrayFromListN 2 <$> mapM (fmap doubleToWord . asDouble) doubles
 
-constInstructionToValue :: Instruction -> Either String (S.Instruction Natural)
+isNaNRep :: FloatRep -> Bool
-constInstructionToValue (PlainInstr (I32Const v)) = return $ S.I32Const $ integerToWord32 v
+isNaNRep (NanRep Canonical) = True
-constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const <$> asFloat v
+isNaNRep (NanRep Arithmetic) = True
-constInstructionToValue (PlainInstr (I64Const v)) = return $ S.I64Const $ integerToWord64 v
+isNaNRep _ = False
-constInstructionToValue (PlainInstr (F64Const v)) = S.F64Const <$> asDouble v
+
-constInstructionToValue (PlainInstr (V128Const v)) = S.V128Const <$> v128RepToBytes v
+constInstructionToValue :: Instruction -> Either String ValuePattern
-constInstructionToValue (PlainInstr (RefNull et)) = return $ S.RefNull et
+constInstructionToValue (PlainInstr (I32Const v)) = return $ ExactValue $ S.I32Const $ integerToWord32 v
-constInstructionToValue (PlainInstr (RefExtern n)) = return $ S.RefExtern n
+constInstructionToValue (PlainInstr (F32Const (NanRep Canonical))) = return CanonicalNan
+constInstructionToValue (PlainInstr (F32Const (NanRep Arithmetic))) = return ArithmeticNan
+constInstructionToValue (PlainInstr (F32Const v)) = ExactValue . S.F32Const <$> asFloat v
+constInstructionToValue (PlainInstr (I64Const v)) = return $ ExactValue $ S.I64Const $ integerToWord64 v
+constInstructionToValue (PlainInstr (F64Const (NanRep Canonical))) = return CanonicalNan
+constInstructionToValue (PlainInstr (F64Const (NanRep Arithmetic))) = return ArithmeticNan
+constInstructionToValue (PlainInstr (F64Const v)) = ExactValue . S.F64Const <$> asDouble v
+constInstructionToValue (PlainInstr (V128Const (F32x4Const floats))) | any isNaNRep floats =
+    VectorPat F32x4 <$> mapM (constInstructionToValue . PlainInstr . F32Const) floats
+constInstructionToValue (PlainInstr (V128Const (F64x2Const floats))) | any isNaNRep floats =
+    VectorPat F64x2 <$> mapM (constInstructionToValue . PlainInstr . F64Const) floats
+constInstructionToValue (PlainInstr (V128Const v)) = ExactValue . S.V128Const <$> v128RepToBytes v
+constInstructionToValue (PlainInstr (RefNull et)) = return $ ExactValue $ S.RefNull et
+constInstructionToValue (PlainInstr (RefExtern n)) = return $ ExactValue $ S.RefExtern n
 constInstructionToValue _ = Left "Only const instructions supported as arguments for actions"
 
 funcIndexToExpr :: [FuncIndex] -> [[Instruction]]

src/Language/Wasm/Script.hs

@@ -31,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 ()
 
@@ -120,17 +123,23 @@ runScript onAssertFail script = do
         getModule st (Just (Ident i)) = Map.lookup i (modules st)
         getModule st Nothing = lastModule st
 
-        asArg :: Struct.Expression -> Interpreter.Value
+        asArg :: Parser.ValuePattern -> Interpreter.Value
-        asArg [Struct.I32Const v] = Interpreter.VI32 v
+        asArg (Parser.ExactValue (Struct.I32Const v)) = Interpreter.VI32 v
-        asArg [Struct.F32Const v] = Interpreter.VF32 v
+        asArg (Parser.ExactValue (Struct.F32Const v)) = Interpreter.VF32 v
-        asArg [Struct.I64Const v] = Interpreter.VI64 v
+        asArg (Parser.ExactValue (Struct.I64Const v)) = Interpreter.VI64 v
-        asArg [Struct.F64Const v] = Interpreter.VF64 v
+        asArg (Parser.ExactValue (Struct.F64Const v)) = Interpreter.VF64 v
-        asArg [Struct.V128Const v] = Interpreter.VV128 v
+        asArg (Parser.ExactValue (Struct.V128Const v)) = Interpreter.VV128 v
-        asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing
+        asArg (Parser.ExactValue (Struct.RefNull Struct.FuncRef)) = Interpreter.RF Nothing
-        asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing
+        asArg (Parser.ExactValue (Struct.RefNull Struct.ExternRef))= Interpreter.RE Nothing
-        asArg [Struct.RefExtern v] = Interpreter.RE (Just v)
+        asArg (Parser.ExactValue (Struct.RefExtern v)) = Interpreter.RE (Just v)
         asArg expr = error $ "Only const instructions supported as arguments for actions: " ++ show expr
 
+        showArg :: Parser.ValuePattern -> String
+        showArg v@(Parser.ExactValue _) = show $ asArg v
+        showArg Parser.CanonicalNan = "nan:canonical"
+        showArg Parser.ArithmeticNan = "nan:arithmetic"
+        showArg (Parser.VectorPat _ pat) = show $ showArg <$> pat
+
         runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
         runAction st (Invoke ident name args) = do
             case getModule st ident of
@@ -144,13 +153,32 @@ 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 =
+            -- floatToWord v .&. floatToWord (abs nan) == floatToWord (abs nan)
+            isNaN v
+        isValueMatch (Interpreter.VF64 v) Parser.CanonicalNan = identicalIEEE v nan || identicalIEEE v (abs nan)
+        isValueMatch (Interpreter.VF64 v) Parser.ArithmeticNan =
+            -- let posNan = doubleToWord (abs nan) in
+            -- doubleToWord v .&. posNan == posNan
+            isNaN v
+        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
@@ -220,10 +248,10 @@ runScript onAssertFail script = do
             result <- runActionInAssert action
             case result of
                 Just result -> do
-                    if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected))
+                    if length result == length expected && (all id $ zipWith isValueMatch result expected)
                     then return ()
-                    else printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
+                    else printFailedAssert ("Expected " ++ show (map showArg expected) ++ ", but action returned " ++ show result) assert
-                Nothing -> printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
+                Nothing -> printFailedAssert ("Expected " ++ show (map showArg expected) ++ ", but action returned Trap") assert
         runAssert assert@(AssertReturnCanonicalNaN action) = isNaNReturned action assert
         runAssert assert@(AssertReturnArithmeticNaN action) = isNaNReturned action assert
         runAssert assert@(AssertInvalid moduleDef failureString) =

src/Language/Wasm/Validate.hs

@@ -558,8 +558,10 @@ 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 _ I32WrapI64 = return $ I64 ==> 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_i16x8_cmp.wast"]
+  let files = ["simd_f32x4_arith.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do