implement bitwise operations

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
 

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> $sign? @num                           { parseDecimalSignedInt }
-<0> "0x" @hexnum                          { parseHexalSignedInt True }
+<0> $sign? "0x" @hexnum                   { parseHexalSignedInt }
-<0> $sign @num                            { parseDecimalSignedInt False }
-<0> $sign "0x" @hexnum                    { parseHexalSignedInt False }
 <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)
+        '-' -> (negate, 1, Just True)
-        '+' -> (abs, 1)
+        '+' -> (abs, 1, Just False)
-        otherwise -> (abs, 0)
+        otherwise -> (abs, 0, Nothing)
 
-{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64) #-}
+{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64, Maybe Bool) #-}
-{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64) #-}
+{-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64, Maybe Bool) #-}
 
-parseHexalSignedInt :: Bool -> AlexAction Lexeme
+parseHexalSignedInt :: AlexAction Lexeme
-parseHexalSignedInt nat = token $ \(pos, _, s, _) len -> 
+parseHexalSignedInt = token $ \(pos, _, s, _) len -> 
-    let (sign, slen) = parseSign s in
+    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 :: AlexAction Lexeme
-parseDecimalSignedInt nat = token $ \(pos, _, s, _) len ->
+parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
-    let (sign, slen) = parseSign s in
+    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

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 $$) }
+signed_pos            { Lexeme _ (TIntLit (Just False) $$) }
-nat                   { Lexeme _ (TIntLit True $$) }
+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

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)

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

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