msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

implement bitwise operations

Browse Source
This commit is contained in:
Ilya Rezvov
2023-09-08 18:08:35 -06:00
parent f16ccb85a9
commit 3944bf9113
6 changed files with 98 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+29 -2
View File
@@ -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
+15 -17
View File
@@ -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
src/Language/Wasm/Parser.y
+47 -5
View File
@@ -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
src/Language/Wasm/Structure.hs
+3
View File
@@ -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
+3
View File
@@ -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
+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_load_extend.wast"]
-- let files = ["simd_bitwise.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do