implement extract_lane and replace_lane

src/Language/Wasm/Interpreter.hs

@@ -1574,6 +1574,21 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
                         ByteArray.unsafeFreezeByteArray arr
                     _ -> error "impossible due to validation"
             return $ Done ctx { stack = VV128 val : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } V128AnyTrue =
+            let w0 = ByteArray.indexByteArray @Word64 v 0 in
+            let w1 = ByteArray.indexByteArray @Word64 v 1 in
+            let r = if w0 == 0 && w1 == 0 then 0 else 1 in
+            return $ Done ctx { stack = VI32 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (V128AllTrue shape) =
+            let r = case shape of
+                    I8x16 -> all (/= 0) $ ByteArray.indexByteArray @Word8 v <$> [0..15]
+                    I16x8 -> all (/= 0) $ ByteArray.indexByteArray @Word16 v <$> [0..8]
+                    I32x4 -> all (/= 0) $ ByteArray.indexByteArray @Word32 v <$> [0..4]
+                    I64x2 -> all (/= 0) $ ByteArray.indexByteArray @Word64 v <$> [0..2]
+                    F32x4 -> all (/= 0) $ wordToFloat . ByteArray.indexByteArray @Word32 v <$> [0..4]
+                    F64x2 -> all (/= 0) $ wordToDouble . ByteArray.indexByteArray @Word64 v <$> [0..2]
+            in
+            return $ Done ctx { stack = VI32 (if r then 1 else 0) : 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,8 +80,10 @@ tokens :-
 <0> @id                                   { tokenStr TId }
 <0> "("                                   { constToken TOpenBracket }
 <0> ")"                                   { constToken TCloseBracket }
-<0> $sign? @num                           { parseDecimalSignedInt }
+<0> @num                                  { parseDecimalSignedInt True }
-<0> $sign? "0x" @hexnum                   { parseHexalSignedInt }
+<0> "0x" @hexnum                          { parseHexalSignedInt True }
+<0> $sign @num                            { parseDecimalSignedInt False }
+<0> $sign "0x" @hexnum                    { parseHexalSignedInt False }
 <0> $sign? @float                         { parseDecFloat }
 <0> $sign? @hexfloat                      { parseHexFloat }
 <0, blockComment> @startblockcomment      { startBlockComment }
@@ -130,11 +132,11 @@ parseSign str =
 {-# SPECIALIZE parseSign :: LBS.ByteString -> ((Integer -> Integer), Int64) #-}
 {-# SPECIALIZE parseSign :: LBS.ByteString -> ((Double -> Double), Int64) #-}
 
-parseHexalSignedInt :: AlexAction Lexeme
+parseHexalSignedInt :: Bool -> AlexAction Lexeme
-parseHexalSignedInt = token $ \(pos, _, s, _) len -> 
+parseHexalSignedInt nat = token $ \(pos, _, s, _) len -> 
     let (sign, slen) = parseSign s in
     let num = readHexFromPrefix (len - 2 - slen) $ LBSUtf8.drop (2 + slen) s in
-    Lexeme (Just pos) $ TIntLit $ sign num
+    Lexeme (Just pos) $ TIntLit nat $ sign num
 
 parseNanSigned :: AlexAction Lexeme
 parseNanSigned = token $ \(pos, _, s, _) len -> 
@@ -146,11 +148,11 @@ 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 :: AlexAction Lexeme
+parseDecimalSignedInt :: Bool -> AlexAction Lexeme
-parseDecimalSignedInt = token $ \(pos, _, s, _) len ->
+parseDecimalSignedInt nat = token $ \(pos, _, s, _) len ->
     let (sign, slen) = parseSign s in
     let num = readDecFromPrefix (len - slen) $ LBSUtf8.drop slen s in
-    Lexeme (Just pos) $ TIntLit $ sign num
+    Lexeme (Just pos) $ TIntLit nat $ sign num
 
 parseDecFloat :: AlexAction Lexeme
 parseDecFloat = token $ \(pos, _, s, _) len ->
@@ -364,7 +366,7 @@ data NaN
     deriving (Show, Eq)
 
 data Token = TKeyword LBS.ByteString
-    | TIntLit Integer
+    | TIntLit {- Natural -} Bool Integer
     | TFloatLit FloatRep
     | TStringLit LBS.ByteString
     | TId LBS.ByteString

src/Language/Wasm/Parser.y

@@ -408,7 +408,8 @@ import Language.Wasm.Lexer (
 'output'              { Lexeme _ (TKeyword "output") }
 -- script extension end
 id                    { Lexeme _ (TId $$) }
-int                   { Lexeme _ (TIntLit $$) }
+signed                { Lexeme _ (TIntLit False $$) }
+nat                   { Lexeme _ (TIntLit True $$) }
 f64                   { Lexeme _ (TFloatLit $$) }
 offset                { Lexeme _ (TKeyword (asOffset -> Just $$)) }
 align                 { Lexeme _ (TKeyword (asAlign -> Just $$)) }
@@ -439,6 +440,10 @@ valtype :: { ValueType }
     | 'funcref' { Func }
     | 'externref' { Extern }
 
+int :: {Integer}
+    : signed { $1 }
+    | nat { $1 }
+
 index :: { Index }
     : u32 { Index $1 }
     | ident { Named $1 }
@@ -524,6 +529,9 @@ v128_const :: { V128Rep }
         F64x2Const [$2, $3]
     }
 
+lane_index :: { Natural }
+    : nat {% if $1 < 256 then Right $ fromIntegral $1 else Left "malformed lane index"}
+
 plaininstr :: { PlainInstr }
     -- control instructions
     : 'unreachable'                  { Unreachable }
@@ -733,9 +741,11 @@ plaininstr :: { PlainInstr }
     | 'f32.reinterpret_i32'              { FReinterpretI BS32 }
     | 'f64.reinterpret_i64'              { FReinterpretI BS64 }
     -- simd
-    | 'i8x16.shuffle' i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 i8 {
+    | 'i8x16.shuffle' u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 u32 {%
-        I8x16Shuffle $ map fromIntegral
+        let idxs = [$2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17] in
-            [$2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14, $15, $16, $17]
+        if any (\i -> i < 0 || i > 0xFF) idxs
+        then Left "malformed lane index"
+        else Right $ I8x16Shuffle $ map fromIntegral idxs
     }
     | 'i8x16.swizzle'                    { I8x16Swizzle }
     | 'v128.any_true'                    { V128AnyTrue }
@@ -751,20 +761,20 @@ plaininstr :: { PlainInstr }
     | 'i64x2.all_true'                   { V128AllTrue I64x2 }
     | 'f32x4.all_true'                   { V128AllTrue F32x4 }
     | 'f64x2.all_true'                   { V128AllTrue F64x2 }
-    | 'i8x16.extract_lane_s' u32     { V128ExtractLane I8x16 $2 True }
+    | 'i8x16.extract_lane_s' lane_index  { V128ExtractLane I8x16 $2 True }
-    | 'i16x8.extract_lane_s' u32     { V128ExtractLane I16x8 $2 True }
+    | 'i16x8.extract_lane_s' lane_index  { V128ExtractLane I16x8 $2 True }
-    | 'i8x16.extract_lane_u' u32     { V128ExtractLane I8x16 $2 False }
+    | 'i8x16.extract_lane_u' lane_index  { V128ExtractLane I8x16 $2 False }
-    | 'i16x8.extract_lane_u' u32     { V128ExtractLane I16x8 $2 False }
+    | 'i16x8.extract_lane_u' lane_index  { V128ExtractLane I16x8 $2 False }
-    | 'i32x4.extract_lane' u32       { V128ExtractLane I32x4 $2 False }
+    | 'i32x4.extract_lane' lane_index    { V128ExtractLane I32x4 $2 False }
-    | 'i64x2.extract_lane' u32       { V128ExtractLane I64x2 $2 False }
+    | 'i64x2.extract_lane' lane_index    { V128ExtractLane I64x2 $2 False }
-    | 'f32x4.extract_lane' u32       { V128ExtractLane F32x4 $2 False }
+    | 'f32x4.extract_lane' lane_index    { V128ExtractLane F32x4 $2 False }
-    | 'f64x2.extract_lane' u32       { V128ExtractLane F64x2 $2 False }
+    | 'f64x2.extract_lane' lane_index    { V128ExtractLane F64x2 $2 False }
-    | 'i8x16.replace_lane' u32       { V128ReplaceLane I8x16 $2 }
+    | 'i8x16.replace_lane' lane_index    { V128ReplaceLane I8x16 $2 }
-    | 'i16x8.replace_lane' u32       { V128ReplaceLane I16x8 $2 }
+    | 'i16x8.replace_lane' lane_index    { V128ReplaceLane I16x8 $2 }
-    | 'i32x4.replace_lane' u32       { V128ReplaceLane I32x4 $2 }
+    | 'i32x4.replace_lane' lane_index    { V128ReplaceLane I32x4 $2 }
-    | 'i64x2.replace_lane' u32       { V128ReplaceLane I64x2 $2 }
+    | 'i64x2.replace_lane' lane_index    { V128ReplaceLane I64x2 $2 }
-    | 'f32x4.replace_lane' u32       { V128ReplaceLane F32x4 $2 }
+    | 'f32x4.replace_lane' lane_index    { V128ReplaceLane F32x4 $2 }
-    | 'f64x2.replace_lane' u32       { V128ReplaceLane F64x2 $2 }
+    | 'f64x2.replace_lane' lane_index    { V128ReplaceLane F64x2 $2 }
     | 'i8x16.add'                        { IBinOp (BS128 I8x16) IAdd }
     | 'i16x8.add'                        { IBinOp (BS128 I16x8) IAdd }
     | 'i32x4.add'                        { IBinOp (BS128 I32x4) IAdd }

src/Language/Wasm/Script.hs

@@ -188,6 +188,7 @@ runScript onAssertFail script = do
         getFailureString (Validate.FunctionIndexOutOfRange idx) = ["unknown function", "unknown function " <> TL.pack (show idx)]
         getFailureString (Validate.GlobalIndexOutOfRange idx) = ["unknown global", "unknown global " <> TL.pack (show idx)]
         getFailureString Validate.LabelIndexOutOfRange = ["unknown label"]
+        getFailureString Validate.LaneIndexOutOfRange = ["invalid lane index"]
         getFailureString Validate.TypeIndexOutOfRange = ["unknown type"]
         getFailureString Validate.MinMoreThanMaxInMemoryLimit = ["size minimum must not be greater than maximum"]
         getFailureString Validate.MemoryLimitExceeded = ["memory size must be at most 65536 pages (4GiB)"]

src/Language/Wasm/Validate.hs

@@ -40,6 +40,7 @@ data ValidationError =
     | ElemIndexOutOfRange Natural
     | DataIndexOutOfRange Natural
     | LabelIndexOutOfRange
+    | LaneIndexOutOfRange
     | TypeIndexOutOfRange
     | ResultTypeDoesntMatch
     | TypeMismatch { actual :: Arrow, expected :: Arrow }
@@ -524,13 +525,16 @@ getInstrType _ (FReinterpretI BS32) = return $ I32 ==> F32
 getInstrType _ (FReinterpretI BS64) = return $ I64 ==> F64
 getInstrType _ I8x16Swizzle =
     return $ [V128, V128] ==> V128
-getInstrType _ (I8x16Shuffle _) =
+getInstrType _ (I8x16Shuffle idxs) = do
+    when (any (>= 32) idxs) $ throwError LaneIndexOutOfRange
     return $ [V128, V128] ==> V128
 getInstrType _ (V128Splat shape) =
     return $ getShapeElemType shape ==> V128
-getInstrType _ (V128ExtractLane shape _ _) =
+getInstrType _ (V128ExtractLane shape idx _) = do
+    when (idx >= lanesCount shape) $ throwError LaneIndexOutOfRange
     return $ V128 ==> getShapeElemType shape
-getInstrType _ (V128ReplaceLane shape _) =
+getInstrType _ (V128ReplaceLane shape idx) = do
+    when (idx >= lanesCount shape) $ throwError LaneIndexOutOfRange
     return $ [V128, getShapeElemType shape] ==> V128
 getInstrType _ (V128AllTrue _) =
     return $ V128 ==> I32
@@ -545,6 +549,16 @@ getShapeElemType I64x2 = I64
 getShapeElemType F32x4 = F32
 getShapeElemType F64x2 = F64
 
+lanesCount :: SimdShape -> Natural
+lanesCount shape = case shape of
+    I8x16 -> 16
+    I16x8 -> 8
+    I32x4 -> 4
+    I64x2 -> 2
+    F32x4 -> 4
+    F64x2 -> 2
+    I128x1 -> 1
+
 replace :: (Eq a) => a -> a -> [a] -> [a]
 replace _ _ [] = []
 replace x y (v:r) = (if x == v then y else v) : replace x y r

tests/Test.hs

@@ -20,7 +20,7 @@ main = do
     filter (List.isPrefixOf "simd") . 
     filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  let files = ["simd_lane.wast"]
+  -- let files = ["simd_lane.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do