GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Ilya Rezvov
2023-09-10 10:30:40 -06:00
parent 6d6d21265a
commit 0d8159e553
6 changed files with 132 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+28
View File
@@ -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
+1 -1
View File
@@ -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
+58 -13
View File
@@ -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]]
src/Language/Wasm/Script.hs
+42 -14
View File
@@ -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) =
src/Language/Wasm/Validate.hs
+2
View File
@@ -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
+1 -1
View File
@@ -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