diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index e86980c..c156a27 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -45,7 +45,7 @@ import Data.Int (Int32, Int64) import Numeric.Natural (Natural) import qualified Control.Monad as Monad import Data.Bits ( - Bits, + Bits (complement), (.|.), (.&.), xor, @@ -55,7 +55,8 @@ import Data.Bits ( rotateR, popCount, countLeadingZeros, - countTrailingZeros + countTrailingZeros, + complement ) import Numeric.IEEE (IEEE, copySign, minNum, maxNum, identicalIEEE) import Control.Monad.Except (ExceptT, runExceptT, throwError) @@ -1355,6 +1356,11 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct let half = v .&. 0xFFFFFFFF in let r = if half >= 0x80000000 then asWord64 (fromIntegral half - 0x100000000) else half in return $ Done ctx { stack = VI64 r : rest } + step ctx@EvalCtx{ stack = (VV128 v:rest) } (IUnOp (BS128 _) INot) = + let w0 = ByteArray.indexByteArray @Word64 v 0 in + let w1 = ByteArray.indexByteArray @Word64 v 1 in + let r = ByteArray.byteArrayFromList [complement w0, complement w1] in + return $ Done ctx { stack = VV128 r : rest } step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (IBinOp (BS128 shape) IAdd) = let r = case shape of I8x16 -> lanewise @Word8 shape v1 v2 (+) @@ -1373,6 +1379,18 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct _ -> error "impossible due to validation" in return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (IBinOp (BS128 _) IAnd) = + let r = lanewise @Word64 I64x2 v1 v2 (.&.) in + return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (IBinOp (BS128 _) IAndNot) = + let r = lanewise @Word64 I64x2 v1 v2 (\a b -> a .&. complement b) in + return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (IBinOp (BS128 _) IOr) = + let r = lanewise @Word64 I64x2 v1 v2 (.|.) in + return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VV128 v2:VV128 v1:rest) } (IBinOp (BS128 _) IXor) = + let r = lanewise @Word64 I64x2 v1 v2 xor in + return $ Done ctx { stack = VV128 r : rest } step ctx@EvalCtx{ stack = (VF32 v:rest) } (FUnOp BS32 FAbs) = return $ Done ctx { stack = VF32 (abs v) : rest } step ctx@EvalCtx{ stack = (VF32 v:rest) } (FUnOp BS32 FNeg) = @@ -1670,6 +1688,15 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct F64x2 -> all (/= 0) $ wordToDouble . ByteArray.indexByteArray @Word64 v <$> [0..2] in return $ Done ctx { stack = VI32 (if r then 1 else 0) : rest } + step ctx@EvalCtx{ stack = (VV128 c:VV128 v2:VV128 v1:rest) } V128BitSelect = + let bitselect idx = + let w1 = ByteArray.indexByteArray @Word64 v1 idx in + let w2 = ByteArray.indexByteArray @Word64 v2 idx in + let wc = ByteArray.indexByteArray @Word64 c idx in + (w1 .&. wc) .|. (w2 .&. complement wc) + in + let r = ByteArray.byteArrayFromList @Word64 $ bitselect <$> [0, 1] 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 diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x index 7e7cd61..8c96285 100644 --- a/src/Language/Wasm/Lexer.x +++ b/src/Language/Wasm/Lexer.x @@ -80,10 +80,8 @@ tokens :- <0> @id { tokenStr TId } <0> "(" { constToken TOpenBracket } <0> ")" { constToken TCloseBracket } -<0> @num { parseDecimalSignedInt True } -<0> "0x" @hexnum { parseHexalSignedInt True } -<0> $sign @num { parseDecimalSignedInt False } -<0> $sign "0x" @hexnum { parseHexalSignedInt False } +<0> $sign? @num { parseDecimalSignedInt } +<0> $sign? "0x" @hexnum { parseHexalSignedInt } <0> $sign? @float { parseDecFloat } <0> $sign? @hexfloat { parseHexFloat } <0, blockComment> @startblockcomment { startBlockComment } @@ -121,20 +119,20 @@ minusNaN = negate nan inf = infinity minusInf = -infinity -parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64) +parseSign :: (Num a) => LBS.ByteString -> ((a -> a), Int64, Maybe Bool) parseSign str = let Just (ch, _) = LBSUtf8.decode str in case ch of - '-' -> (negate, 1) - '+' -> (abs, 1) - otherwise -> (abs, 0) + '-' -> (negate, 1, Just True) + '+' -> (abs, 1, Just False) + otherwise -> (abs, 0, Nothing) -{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64) #-} -{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64) #-} +{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64, Maybe Bool) #-} +{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64, Maybe Bool) #-} -parseHexalSignedInt :: Bool -> AlexAction Lexeme -parseHexalSignedInt nat = token $ \(pos, _, s, _) len -> - let (sign, slen) = parseSign s in +parseHexalSignedInt :: AlexAction Lexeme +parseHexalSignedInt = token $ \(pos, _, s, _) len -> + let (sign, slen, nat) = parseSign s in let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in Lexeme (Just pos) $ TIntLit nat $ sign num @@ -148,9 +146,9 @@ parseNanSigned = token $ \(pos, _, s, _) len -> let num = readHexFromPrefix (len - 6 - slen) $ LBSUtf8.drop (6 + slen) s in Lexeme (Just pos) $ TFloatLit $ NanRep $ NanHex sign $ fromIntegral num -parseDecimalSignedInt :: Bool -> AlexAction Lexeme -parseDecimalSignedInt nat = token $ \(pos, _, s, _) len -> - let (sign, slen) = parseSign s in +parseDecimalSignedInt :: AlexAction Lexeme +parseDecimalSignedInt = token $ \(pos, _, s, _) len -> + let (sign, slen, nat) = parseSign s in let num = readDecFromPrefix (len - slen) $ LBSUtf8.drop slen s in Lexeme (Just pos) $ TIntLit nat $ sign num @@ -366,7 +364,7 @@ data NaN deriving (Show, Eq) data Token = TKeyword LBS.ByteString - | TIntLit {- Natural -} Bool Integer + | TIntLit {- Natural -} (Maybe Bool) Integer | TFloatLit FloatRep | TStringLit LBS.ByteString | TId LBS.ByteString diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index c514062..30b5892 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -396,7 +396,13 @@ import Language.Wasm.Lexer ( 'i64x2.all_true' { Lexeme _ (TKeyword "i64x2.all_true") } 'f32x4.all_true' { Lexeme _ (TKeyword "f32x4.all_true") } 'f64x2.all_true' { Lexeme _ (TKeyword "f64x2.all_true") } +'v128.not' { Lexeme _ (TKeyword "v128.not") } +'v128.and' { Lexeme _ (TKeyword "v128.and") } +'v128.andnot' { Lexeme _ (TKeyword "v128.andnot") } +'v128.or' { Lexeme _ (TKeyword "v128.or") } +'v128.xor' { Lexeme _ (TKeyword "v128.xor") } 'v128.any_true' { Lexeme _ (TKeyword "v128.any_true") } +'v128.bitselect' { Lexeme _ (TKeyword "v128.bitselect") } 'i8x16.add' { Lexeme _ (TKeyword "i8x16.add") } 'i16x8.add' { Lexeme _ (TKeyword "i16x8.add") } 'i32x4.add' { Lexeme _ (TKeyword "i32x4.add") } @@ -424,8 +430,9 @@ import Language.Wasm.Lexer ( 'output' { Lexeme _ (TKeyword "output") } -- script extension end id { Lexeme _ (TId $$) } -signed { Lexeme _ (TIntLit False $$) } -nat { Lexeme _ (TIntLit True $$) } +signed_pos { Lexeme _ (TIntLit (Just False) $$) } +signed_neg { Lexeme _ (TIntLit (Just True) $$) } +nat { Lexeme _ (TIntLit Nothing $$) } f64 { Lexeme _ (TFloatLit $$) } offset { Lexeme _ (TKeyword (asOffset -> Just $$)) } align { Lexeme _ (TKeyword (asAlign -> Just $$)) } @@ -457,7 +464,8 @@ valtype :: { ValueType } | 'externref' { Extern } int :: {Integer} - : signed { $1 } + : signed_neg { $1 } + | signed_pos { $1 } | nat { $1 } index :: { Index } @@ -500,7 +508,20 @@ int64 :: { Integer } } float32 :: { FloatRep } - : int {% + : signed_neg {% + -- it is stupid, but to preserve minus bit of "-0" we have to do it + let maxInt = 340282356779733623858607532500980858880 in + if $1 <= maxInt && $1 >= -maxInt + then return $ BinRep $ if $1 == 0 then negate $ fromIntegral $1 else fromIntegral $1 + else Left "constant out of range" + } + | signed_pos {% + let maxInt = 340282356779733623858607532500980858880 in + if $1 <= maxInt && $1 >= -maxInt + then return $ BinRep $ fromIntegral $1 + else Left "constant out of range" + } + | nat {% let maxInt = 340282356779733623858607532500980858880 in if $1 <= maxInt && $1 >= -maxInt then return $ BinRep $ fromIntegral $1 @@ -509,7 +530,20 @@ float32 :: { FloatRep } | f64 { $1 } float64 :: { FloatRep } - : int {% + : signed_neg {% + -- it is stupid, but to preserve minus bit of "-0" we have to do it + let maxInt = round (maxFinite :: Double) in + if $1 <= maxInt && $1 >= -maxInt + then fmap (BinRep . if $1 == 0 then negate else id) $ doubleFromInteger $1 + else Left "constant out of range" + } + | signed_pos {% + let maxInt = round (maxFinite :: Double) in + if $1 <= maxInt && $1 >= -maxInt + then fmap BinRep $ doubleFromInteger $1 + else Left "constant out of range" + } + | nat {% let maxInt = round (maxFinite :: Double) in if $1 <= maxInt && $1 >= -maxInt then fmap BinRep $ doubleFromInteger $1 @@ -780,6 +814,12 @@ plaininstr :: { PlainInstr } else Right $ I8x16Shuffle $ map fromIntegral idxs } | 'i8x16.swizzle' { I8x16Swizzle } + | 'v128.not' { IUnOp (BS128 I128x1) INot } + | 'v128.and' { IBinOp (BS128 I128x1) IAnd } + | 'v128.andnot' { IBinOp (BS128 I128x1) IAndNot } + | 'v128.or' { IBinOp (BS128 I128x1) IOr } + | 'v128.xor' { IBinOp (BS128 I128x1) IXor } + | 'v128.bitselect' { V128BitSelect } | 'v128.any_true' { V128AnyTrue } | 'i8x16.splat' { V128Splat I8x16 } | 'i16x8.splat' { V128Splat I16x8 } @@ -1537,6 +1577,7 @@ data PlainInstr = | V128ReplaceLane SimdShape Natural | V128AllTrue SimdShape | V128AnyTrue + | V128BitSelect | I8x16Shuffle [Int] | I8x16Swizzle deriving (Show, Eq) @@ -2113,6 +2154,7 @@ desugarize fields = do synInstrToStruct _ (PlainInstr (V128ReplaceLane shape idx)) = return $ S.V128ReplaceLane shape idx synInstrToStruct _ (PlainInstr (V128AllTrue shape)) = return $ S.V128AllTrue shape synInstrToStruct _ (PlainInstr V128AnyTrue) = return $ S.V128AnyTrue + synInstrToStruct _ (PlainInstr V128BitSelect) = return $ S.V128BitSelect synInstrToStruct _ (PlainInstr (I8x16Shuffle idxs)) = return $ S.I8x16Shuffle idxs synInstrToStruct _ (PlainInstr I8x16Swizzle) = return $ S.I8x16Swizzle synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } BlockInstr {label, blockType, body} = do diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index f14dd48..6a7b0a9 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -71,6 +71,7 @@ data IUnOp = | IExtend8S | IExtend16S | IExtend32S + | INot deriving (Show, Eq, Generic, NFData) data IBinOp = @@ -82,6 +83,7 @@ data IBinOp = | IRemU | IRemS | IAnd + | IAndNot | IOr | IXor | IShl @@ -249,6 +251,7 @@ data Instruction index = | V128ReplaceLane SimdShape index | V128AllTrue SimdShape | V128AnyTrue + | V128BitSelect | I8x16Swizzle | I8x16Shuffle [Int] deriving (Show, Eq, Generic, NFData) diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 5777dd0..a953080 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -529,6 +529,7 @@ getInstrType _ (F64Const _) = return $ empty ==> F64 getInstrType _ (V128Const _) = return $ empty ==> V128 getInstrType _ (IUnOp BS32 _) = return $ I32 ==> I32 getInstrType _ (IUnOp BS64 _) = return $ I64 ==> I64 +getInstrType _ (IUnOp (BS128 _) _) = return $ V128 ==> V128 getInstrType _ (IBinOp BS32 _) = return $ [I32, I32] ==> I32 getInstrType _ (IBinOp BS64 _) = return $ [I64, I64] ==> I64 getInstrType _ (IBinOp (BS128 _) _) = return $ [V128, V128] ==> V128 @@ -592,6 +593,8 @@ getInstrType _ (V128AllTrue _) = return $ V128 ==> I32 getInstrType _ V128AnyTrue = return $ V128 ==> I32 +getInstrType _ V128BitSelect = + return $ [V128, V128, V128] ==> V128 getShapeElemType :: SimdShape -> ValueType getShapeElemType I8x16 = I32 diff --git a/tests/Test.hs b/tests/Test.hs index 361bd56..becfcf6 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_load_extend.wast"] + -- let files = ["simd_bitwise.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do