From 662b57326c9afec1ec252d621cf0fcf86eb4025b Mon Sep 17 00:00:00 2001
From: Ilya Rezvov <rezvov.ilya@gmail.com>
Date: Sun, 12 Jan 2025 21:25:53 -0700
Subject: [PATCH] parse and implement I32x4TruncSatF32x4 instruction

---
 src/Language/Wasm/Interpreter.hs | 13 +++++++++++++
 src/Language/Wasm/Parser.y       |  6 ++++++
 src/Language/Wasm/Structure.hs   |  1 +
 src/Language/Wasm/Validate.hs    |  2 ++
 tests/Test.hs                    |  2 +-
 5 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs
index 05bded0..7f45338 100644
--- a/src/Language/Wasm/Interpreter.hs
+++ b/src/Language/Wasm/Interpreter.hs
@@ -2277,6 +2277,19 @@ 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 v:rest) } (I32x4TruncSatF32x4 signed) =
+            let
+                floatTruncSat :: Bool -> Float -> Word32
+                floatTruncSat True v  | isNaN v = 0
+                floatTruncSat True v  | v >= 2^31 = 0x7fffffff
+                floatTruncSat True v  | v < -2^31 - 1 = 0x80000000
+                floatTruncSat True v  = asWord32 $ truncate v
+                floatTruncSat False v | v <= -1 || isNaN v = 0
+                floatTruncSat False v | v >= 2^32 = 0xffffffff
+                floatTruncSat False v = truncate v
+            in
+            let r = floatTruncSat signed . ByteArray.indexByteArray @Float v <$> [0..3] in
+            return $ Done ctx { stack = VV128 (ByteArray.byteArrayFromList @Word32 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
 
diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y
index 5642d77..52be730 100644
--- a/src/Language/Wasm/Parser.y
+++ b/src/Language/Wasm/Parser.y
@@ -584,6 +584,8 @@ import Language.Wasm.Lexer (
 'i64x2.extend_high_i32x4_u' { Lexeme _ (TKeyword "i64x2.extend_high_i32x4_u") }
 'i64x2.extend_low_i32x4_s'  { Lexeme _ (TKeyword "i64x2.extend_low_i32x4_s") }
 'i64x2.extend_low_i32x4_u'  { Lexeme _ (TKeyword "i64x2.extend_low_i32x4_u") }
+'i32x4.trunc_sat_f32x4_s'   { Lexeme _ (TKeyword "i32x4.trunc_sat_f32x4_s") }
+'i32x4.trunc_sat_f32x4_u'   { Lexeme _ (TKeyword "i32x4.trunc_sat_f32x4_u") }
 -- script extension
 'binary'              { Lexeme _ (TKeyword "binary") }
 'quote'               { Lexeme _ (TKeyword "quote") }
@@ -1200,6 +1202,8 @@ plaininstr :: { PlainInstr }
     | 'i64x2.extend_high_i32x4_u'        { V128IExtend I64x2 I32x4 True False }
     | 'i64x2.extend_low_i32x4_s'         { V128IExtend I64x2 I32x4 False True }
     | 'i64x2.extend_low_i32x4_u'         { V128IExtend I64x2 I32x4 False False }
+    | 'i32x4.trunc_sat_f32x4_s'          { I32x4TruncSatF32x4 True }
+    | 'i32x4.trunc_sat_f32x4_u'          { I32x4TruncSatF32x4 False }
 
 typeuse(next)
     : '(' typeuse1(folded_instr_list(next), instruction_list(next)) {
@@ -1934,6 +1938,7 @@ data PlainInstr =
     | F64x2PromoteLowF32x4
     | F32x4DemoteF64x2Zero
     | V128IExtend SimdShape SimdShape {- high -} Bool {- signed -} Bool
+    | I32x4TruncSatF32x4 {- signed -} Bool
     deriving (Show, Eq)
 
 data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)
@@ -2540,6 +2545,7 @@ desugarize fields = do
         synInstrToStruct _ (PlainInstr F32x4DemoteF64x2Zero) = return $ S.F32x4DemoteF64x2Zero
         synInstrToStruct _ (PlainInstr (V128Narrow t f s)) = return $ S.V128Narrow t f s
         synInstrToStruct _ (PlainInstr (V128IExtend t f h s)) = return $ S.V128IExtend t f h s
+        synInstrToStruct _ (PlainInstr (I32x4TruncSatF32x4 s)) = return $ S.I32x4TruncSatF32x4 s
         synInstrToStruct ctx@FunCtx { ctxMod = Module { types } } BlockInstr {label, blockType, body} = do
             let ctx' = ctx { ctxLabels = label : ctxLabels ctx }
             bt <- case blockType of
diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs
index effe748..464ad17 100644
--- a/src/Language/Wasm/Structure.hs
+++ b/src/Language/Wasm/Structure.hs
@@ -276,6 +276,7 @@ data Instruction index =
     | F64x2PromoteLowF32x4
     | F32x4DemoteF64x2Zero
     | V128IExtend SimdShape SimdShape {- high -} Bool {- signed -} Bool
+    | I32x4TruncSatF32x4 {- signed -} Bool
     deriving (Show, Eq, Generic, NFData)
 
 type Expression = [Instruction Natural]
diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs
index 7af8303..f86de3d 100644
--- a/src/Language/Wasm/Validate.hs
+++ b/src/Language/Wasm/Validate.hs
@@ -629,6 +629,8 @@ getInstrType _ F32x4DemoteF64x2Zero =
     return $ V128 ==> V128
 getInstrType _ (V128IExtend _ _ _ _) =
     return $ V128 ==> V128
+getInstrType _ (I32x4TruncSatF32x4 _) =
+    return $ V128 ==> V128
 
 getShapeElemType :: SimdShape -> ValueType
 getShapeElemType I8x16 = I32
diff --git a/tests/Test.hs b/tests/Test.hs
index 2119088..a2fbab1 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_int_to_int_extend.wast"]
+  -- let files = ["simd_i32x4_trunc_sat_f32x4.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do