From a4a96af6aa7be54588eac9987489ab0acc0ead8b Mon Sep 17 00:00:00 2001
From: Ilya Rezvov <rezvov.ilya@gmail.com>
Date: Sun, 10 Sep 2023 14:27:28 -0600
Subject: [PATCH] implement unary float operations for simd

---
 src/Language/Wasm/Interpreter.hs | 22 ++++++++++++++++++++++
 src/Language/Wasm/Lexer.x        | 10 ++++++----
 src/Language/Wasm/Script.hs      |  9 ++++-----
 tests/Test.hs                    |  2 +-
 4 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs
index b930348..05354ee 100644
--- a/src/Language/Wasm/Interpreter.hs
+++ b/src/Language/Wasm/Interpreter.hs
@@ -1682,6 +1682,28 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             return $ Done ctx { stack = VF64 (nearest v) : rest }
         step ctx@EvalCtx{ stack = (VF64 v:rest) } (FUnOp BS64 FSqrt) =
             return $ Done ctx { stack = VF64 (sqrt v) : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (FUnOp (BS128 shape) FNeg) =
+            let r = case shape of
+                    F32x4 -> ByteArray.byteArrayFromList
+                        $ floatToWord . negate . wordToFloat . ByteArray.indexByteArray @Word32 v
+                            <$> [0..3]
+                    F64x2 -> ByteArray.byteArrayFromList
+                        $ doubleToWord . negate . wordToDouble . ByteArray.indexByteArray @Word64 v
+                            <$> [0..1]
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (FUnOp (BS128 shape) FSqrt) =
+            let r = case shape of
+                    F32x4 -> ByteArray.byteArrayFromList
+                        $ floatToWord . sqrt . wordToFloat . ByteArray.indexByteArray @Word32 v
+                            <$> [0..3]
+                    F64x2 -> ByteArray.byteArrayFromList
+                        $ doubleToWord . sqrt . wordToDouble . ByteArray.indexByteArray @Word64 v
+                            <$> [0..1]
+                    _ -> error "impossible due to validation"
+            in
+            return $ Done ctx { stack = VV128 r : rest }
         step ctx@EvalCtx{ stack = (VF32 v2:VF32 v1:rest) } (FBinOp BS32 FAdd) =
             return $ Done ctx { stack = VF32 (v1 + v2) : rest }
         step ctx@EvalCtx{ stack = (VF32 v2:VF32 v1:rest) } (FBinOp BS32 FSub) =
diff --git a/src/Language/Wasm/Lexer.x b/src/Language/Wasm/Lexer.x
index 21ccbb6..57f9f96 100644
--- a/src/Language/Wasm/Lexer.x
+++ b/src/Language/Wasm/Lexer.x
@@ -226,11 +226,13 @@ readHexFloat toFloat sz expLimit manitisaSize str = do
                         then ([True], 0, exp' + 1)
                         else (rounded, 1, exp')
                     else (rounded, 0, exp')
-        if exp'' > expLimit || exp'' < (negate $ expLimit + manitisaSize) then Left "constant out of range" else return ()
-        if exp'' >= (negate $ expLimit - 1)
-        then return $ toFloat $ sign .|. ((fromIntegral $ exp'' + expLimit) `shiftL` manitisaSize) .|. ((fromBits (tail bits') + a) `shiftL` (manitisaSize + 1 - length bits'))
+        e <- if exp'' > expLimit then Left "const out of range"
+                else if exp'' < (negate $ expLimit + manitisaSize) then return $ negate $ expLimit + manitisaSize + 1
+                else return exp''
+        if e >= (negate $ expLimit - 1)
+        then return $ toFloat $ sign .|. ((fromIntegral $ e + expLimit) `shiftL` manitisaSize) .|. ((fromBits (tail bits') + a) `shiftL` (manitisaSize + 1 - length bits'))
         else do
-            let shift = expLimit + manitisaSize - length bits' - abs exp''
+            let shift = expLimit + manitisaSize - length bits' - abs e
             if shift < 0
             then return $ toFloat sign
             else return $ toFloat $ sign .|. ((fromBits bits' + a) `shiftL` shift)
diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs
index 39dbb5c..71069d8 100644
--- a/src/Language/Wasm/Script.hs
+++ b/src/Language/Wasm/Script.hs
@@ -164,13 +164,12 @@ runScript onAssertFail script = do
         isValueMatch val v@(Parser.ExactValue _) = isValueEqual val $ asArg v
         isValueMatch (Interpreter.VF32 v) Parser.CanonicalNan = identicalIEEE v nan || identicalIEEE v (abs nan)
         isValueMatch (Interpreter.VF32 v) Parser.ArithmeticNan =
-            -- floatToWord v .&. floatToWord (abs nan) == floatToWord (abs nan)
-            isNaN v
+            let posNan = 0x7F800000 in
+            floatToWord v .&. posNan == posNan
         isValueMatch (Interpreter.VF64 v) Parser.CanonicalNan = identicalIEEE v nan || identicalIEEE v (abs nan)
         isValueMatch (Interpreter.VF64 v) Parser.ArithmeticNan =
-            -- let posNan = doubleToWord (abs nan) in
-            -- doubleToWord v .&. posNan == posNan
-            isNaN v
+            let posNan = 0x7FF0000000000000 in
+            doubleToWord v .&. posNan == posNan
         isValueMatch (Interpreter.VV128 v) (Parser.VectorPat Struct.F32x4 pat) =
             let vals = Interpreter.VF32 . wordToFloat . ByteArray.indexByteArray v <$> [0..3] in
             and $ zipWith isValueMatch vals pat
diff --git a/tests/Test.hs b/tests/Test.hs
index 3d345f2..9d88f57 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_f32x4_arith.wast"]
+  -- let files = ["simd_f64x2_arith.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do