From 0d8159e5530d12d6fb373ba54663894bef4ffde9 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sun, 10 Sep 2023 10:30:40 -0600 Subject: [PATCH] reimplement script value matching logic and implement part of simd float arithmetic --- src/Language/Wasm/Interpreter.hs | 28 +++++++++++++ src/Language/Wasm/Lexer.x | 2 +- src/Language/Wasm/Parser.y | 71 ++++++++++++++++++++++++++------ src/Language/Wasm/Script.hs | 56 ++++++++++++++++++------- src/Language/Wasm/Validate.hs | 2 + tests/Test.hs | 2 +- 6 files changed, 132 insertions(+), 29 deletions(-) diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index dfcecd2..b930348 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/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) = diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x index 8c96285..21ccbb6 100644 --- a/src/Language/Wasm/Lexer.x +++ b/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 } [.\n] ; @endblockcomment { endBlockComment } diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 8ca9181..ad05bca 100644 --- a/src/Language/Wasm/Parser.y +++ b/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) -constInstructionToValue (PlainInstr (I32Const v)) = return $ S.I32Const $ integerToWord32 v -constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const <$> asFloat v -constInstructionToValue (PlainInstr (I64Const v)) = return $ S.I64Const $ integerToWord64 v -constInstructionToValue (PlainInstr (F64Const v)) = S.F64Const <$> asDouble v -constInstructionToValue (PlainInstr (V128Const v)) = S.V128Const <$> v128RepToBytes v -constInstructionToValue (PlainInstr (RefNull et)) = return $ S.RefNull et -constInstructionToValue (PlainInstr (RefExtern n)) = return $ S.RefExtern n +isNaNRep :: FloatRep -> Bool +isNaNRep (NanRep Canonical) = True +isNaNRep (NanRep Arithmetic) = True +isNaNRep _ = False + +constInstructionToValue :: Instruction -> Either String ValuePattern +constInstructionToValue (PlainInstr (I32Const v)) = return $ ExactValue $ S.I32Const $ integerToWord32 v +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]] diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index 7cb1474..39dbb5c 100644 --- a/src/Language/Wasm/Script.hs +++ b/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 [Struct.I32Const v] = Interpreter.VI32 v - asArg [Struct.F32Const v] = Interpreter.VF32 v - asArg [Struct.I64Const v] = Interpreter.VI64 v - asArg [Struct.F64Const v] = Interpreter.VF64 v - asArg [Struct.V128Const v] = Interpreter.VV128 v - asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing - asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing - asArg [Struct.RefExtern v] = Interpreter.RE (Just v) + asArg :: Parser.ValuePattern -> Interpreter.Value + asArg (Parser.ExactValue (Struct.I32Const v)) = Interpreter.VI32 v + asArg (Parser.ExactValue (Struct.F32Const v)) = Interpreter.VF32 v + asArg (Parser.ExactValue (Struct.I64Const v)) = Interpreter.VI64 v + asArg (Parser.ExactValue (Struct.F64Const v)) = Interpreter.VF64 v + 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 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.VF64 v1) (Interpreter.VF64 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) = 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 - Nothing -> printFailedAssert ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert + else printFailedAssert ("Expected " ++ show (map showArg expected) ++ ", but action returned " ++ show result) 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) = diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 552907a..4db767b 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index e1f1669..3d345f2 100644 --- a/tests/Test.hs +++ b/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