diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index af22ace..925d806 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -41,7 +41,7 @@ import qualified Data.Primitive.Types as Primitive import qualified Control.Monad.Primitive as Primitive import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int32, Int64) +import Data.Int (Int8, Int16, Int32, Int64) import Numeric.Natural (Natural) import qualified Control.Monad as Monad import Data.Bits ( @@ -84,6 +84,17 @@ data Value = | RE (Maybe Natural) deriving (Eq, Show) +asInt8 :: Word8 -> Int8 +asInt8 w = + if w < 0x80 + then fromIntegral w + else -1 * fromIntegral (0xFF - w + 1) + +asInt16 :: Word16 -> Int16 +asInt16 w = + if w < 0x8000 + then fromIntegral w + else -1 * fromIntegral (0xFFFF - w + 1) asInt32 :: Word32 -> Int32 asInt32 w = @@ -97,6 +108,16 @@ asInt64 w = then fromIntegral w else -1 * fromIntegral (0xFFFFFFFFFFFFFFFF - w + 1) +asWord8 :: Int8 -> Word8 +asWord8 i + | i >= 0 = fromIntegral i + | otherwise = 0xFF - (fromIntegral (abs i)) + 1 + +asWord16 :: Int16 -> Word16 +asWord16 i + | i >= 0 = fromIntegral i + | otherwise = 0xFFFF - (fromIntegral (abs i)) + 1 + asWord32 :: Int32 -> Word32 asWord32 i | i >= 0 = fromIntegral i @@ -1419,6 +1440,30 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct 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 = (VI32 s:VV128 v:rest) } (IBinOp (BS128 shape) IShl) = + let r = case shape of + I8x16 -> ByteArray.byteArrayFromList $ (`shiftL` (fromIntegral s `rem` 8)) . ByteArray.indexByteArray @Word8 v <$> [0..15] + I16x8 -> ByteArray.byteArrayFromList $ (`shiftL` (fromIntegral s `rem` 16)) . ByteArray.indexByteArray @Word16 v <$> [0..7] + I32x4 -> ByteArray.byteArrayFromList $ (`shiftL` (fromIntegral s `rem` 32)) . ByteArray.indexByteArray @Word32 v <$> [0..3] + I64x2 -> ByteArray.byteArrayFromList $ (`shiftL` (fromIntegral s `rem` 64)) . ByteArray.indexByteArray @Word64 v <$> [0..1] + in + return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VI32 s:VV128 v:rest) } (IBinOp (BS128 shape) IShrU) = + let r = case shape of + I8x16 -> ByteArray.byteArrayFromList $ (`shiftR` (fromIntegral s `rem` 8)) . ByteArray.indexByteArray @Word8 v <$> [0..15] + I16x8 -> ByteArray.byteArrayFromList $ (`shiftR` (fromIntegral s `rem` 16)) . ByteArray.indexByteArray @Word16 v <$> [0..7] + I32x4 -> ByteArray.byteArrayFromList $ (`shiftR` (fromIntegral s `rem` 32)) . ByteArray.indexByteArray @Word32 v <$> [0..3] + I64x2 -> ByteArray.byteArrayFromList $ (`shiftR` (fromIntegral s `rem` 64)) . ByteArray.indexByteArray @Word64 v <$> [0..1] + in + return $ Done ctx { stack = VV128 r : rest } + step ctx@EvalCtx{ stack = (VI32 s:VV128 v:rest) } (IBinOp (BS128 shape) IShrS) = + let r = case shape of + I8x16 -> ByteArray.byteArrayFromList $ (asWord8 . (`shiftR` (fromIntegral s `rem` 8)) . asInt8) . ByteArray.indexByteArray @Word8 v <$> [0..15] + I16x8 -> ByteArray.byteArrayFromList $ (asWord16 . (`shiftR` (fromIntegral s `rem` 16)) . asInt16) . ByteArray.indexByteArray @Word16 v <$> [0..7] + I32x4 -> ByteArray.byteArrayFromList $ (asWord32 . (`shiftR` (fromIntegral s `rem` 32)) . asInt32) . ByteArray.indexByteArray @Word32 v <$> [0..3] + I64x2 -> ByteArray.byteArrayFromList $ (asWord64 . (`shiftR` (fromIntegral s `rem` 64)) . asInt64) . ByteArray.indexByteArray @Word64 v <$> [0..1] + 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) = diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 0a7721e..315177a 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -413,6 +413,18 @@ import Language.Wasm.Lexer ( 'i16x8.sub' { Lexeme _ (TKeyword "i16x8.sub") } 'i32x4.sub' { Lexeme _ (TKeyword "i32x4.sub") } 'i64x2.sub' { Lexeme _ (TKeyword "i64x2.sub") } +'i8x16.shl' { Lexeme _ (TKeyword "i8x16.shl") } +'i16x8.shl' { Lexeme _ (TKeyword "i16x8.shl") } +'i32x4.shl' { Lexeme _ (TKeyword "i32x4.shl") } +'i64x2.shl' { Lexeme _ (TKeyword "i64x2.shl") } +'i8x16.shr_u' { Lexeme _ (TKeyword "i8x16.shr_u") } +'i16x8.shr_u' { Lexeme _ (TKeyword "i16x8.shr_u") } +'i32x4.shr_u' { Lexeme _ (TKeyword "i32x4.shr_u") } +'i64x2.shr_u' { Lexeme _ (TKeyword "i64x2.shr_u") } +'i8x16.shr_s' { Lexeme _ (TKeyword "i8x16.shr_s") } +'i16x8.shr_s' { Lexeme _ (TKeyword "i16x8.shr_s") } +'i32x4.shr_s' { Lexeme _ (TKeyword "i32x4.shr_s") } +'i64x2.shr_s' { Lexeme _ (TKeyword "i64x2.shr_s") } 'i8x16.bitmask' { Lexeme _ (TKeyword "i8x16.bitmask") } 'i16x8.bitmask' { Lexeme _ (TKeyword "i16x8.bitmask") } 'i32x4.bitmask' { Lexeme _ (TKeyword "i32x4.bitmask") } @@ -863,6 +875,18 @@ plaininstr :: { PlainInstr } | 'i16x8.sub' { IBinOp (BS128 I16x8) ISub } | 'i32x4.sub' { IBinOp (BS128 I32x4) ISub } | 'i64x2.sub' { IBinOp (BS128 I64x2) ISub } + | 'i8x16.shl' { IBinOp (BS128 I8x16) IShl } + | 'i16x8.shl' { IBinOp (BS128 I16x8) IShl } + | 'i32x4.shl' { IBinOp (BS128 I32x4) IShl } + | 'i64x2.shl' { IBinOp (BS128 I64x2) IShl } + | 'i8x16.shr_u' { IBinOp (BS128 I8x16) IShrU } + | 'i16x8.shr_u' { IBinOp (BS128 I16x8) IShrU } + | 'i32x4.shr_u' { IBinOp (BS128 I32x4) IShrU } + | 'i64x2.shr_u' { IBinOp (BS128 I64x2) IShrU } + | 'i8x16.shr_s' { IBinOp (BS128 I8x16) IShrS } + | 'i16x8.shr_s' { IBinOp (BS128 I16x8) IShrS } + | 'i32x4.shr_s' { IBinOp (BS128 I32x4) IShrS } + | 'i64x2.shr_s' { IBinOp (BS128 I64x2) IShrS } | 'i8x16.bitmask' { V128BitMask I8x16 } | 'i16x8.bitmask' { V128BitMask I16x8 } | 'i32x4.bitmask' { V128BitMask I32x4 } diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 7e561ed..0f572b0 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -548,6 +548,8 @@ 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 _) op) | op == IShl || op == IShrS || op == IShrU = + return $ [V128, I32] ==> V128 getInstrType _ (IBinOp (BS128 _) _) = return $ [V128, V128] ==> V128 getInstrType _ I32Eqz = return $ I32 ==> I32 getInstrType _ I64Eqz = return $ I64 ==> I32 diff --git a/tests/Test.hs b/tests/Test.hs index 8ca11db..ec2f356 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_boolean.wast"] + -- let files = ["simd_bit_shift.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do