implement bit shift operations

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) =

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 }

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

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