Resolves #830 - Fix floating point comparison operations

typelead · Aug 4, 2018 · 4566f4b · 4566f4b
1 parent 03640ae
commit 4566f4b
Show file tree

Hide file tree

Showing 3 changed files with 29 additions and 26 deletions.
diff --git a/codec-jvm b/codec-jvm
diff --git a/compiler/Eta/CodeGen/Expr.hs b/compiler/Eta/CodeGen/Expr.hs
@@ -545,19 +545,19 @@ comparisonPrimOp primop
         cmpOp CharGeOp = liftUnsignedOp ifge
         cmpOp CharGtOp = liftUnsignedOp ifgt
 
-        cmpOp DoubleEqOp = liftTypedCmpOp jdouble ifeq
-        cmpOp DoubleNeOp = liftTypedCmpOp jdouble ifne
-        cmpOp DoubleGeOp = liftTypedCmpOp jdouble ifge
-        cmpOp DoubleLeOp = liftTypedCmpOp jdouble ifle
-        cmpOp DoubleGtOp = liftTypedCmpOp jdouble ifgt
-        cmpOp DoubleLtOp = liftTypedCmpOp jdouble iflt
-
-        cmpOp FloatEqOp = liftTypedCmpOp jfloat ifeq
-        cmpOp FloatNeOp = liftTypedCmpOp jfloat ifne
-        cmpOp FloatGeOp = liftTypedCmpOp jfloat ifge
-        cmpOp FloatLeOp = liftTypedCmpOp jfloat ifle
-        cmpOp FloatGtOp = liftTypedCmpOp jfloat ifgt
-        cmpOp FloatLtOp = liftTypedCmpOp jfloat iflt
+        cmpOp DoubleEqOp = liftNormalOp if_dcmpeq
+        cmpOp DoubleNeOp = liftNormalOp if_dcmpne
+        cmpOp DoubleGeOp = liftNormalOp if_dcmpge
+        cmpOp DoubleLeOp = liftNormalOp if_dcmple
+        cmpOp DoubleGtOp = liftNormalOp if_dcmpgt
+        cmpOp DoubleLtOp = liftNormalOp if_dcmplt
+
+        cmpOp FloatEqOp = liftNormalOp if_fcmpeq
+        cmpOp FloatNeOp = liftNormalOp if_fcmpne
+        cmpOp FloatGeOp = liftNormalOp if_fcmpge
+        cmpOp FloatLeOp = liftNormalOp if_fcmple
+        cmpOp FloatGtOp = liftNormalOp if_fcmpgt
+        cmpOp FloatLtOp = liftNormalOp if_fcmplt
 
         cmpOp AddrEqOp = liftTypedCmpOp jlong ifeq
         cmpOp AddrNeOp = liftTypedCmpOp jlong ifne

diff --git a/compiler/Eta/CodeGen/Prim.hs b/compiler/Eta/CodeGen/Prim.hs
@@ -667,12 +667,12 @@ simpleOp CharLeOp = Just $ unsignedCmp ifle
 simpleOp CharLtOp = Just $ unsignedCmp iflt
 
 -- Double# ops
-simpleOp DoubleEqOp = Just $ typedCmp jdouble ifeq
-simpleOp DoubleNeOp = Just $ typedCmp jdouble ifne
-simpleOp DoubleGeOp = Just $ typedCmp jdouble ifge
-simpleOp DoubleLeOp = Just $ typedCmp jdouble ifle
-simpleOp DoubleGtOp = Just $ typedCmp jdouble ifgt
-simpleOp DoubleLtOp = Just $ typedCmp jdouble iflt
+simpleOp DoubleEqOp = Just $ floatCmp if_dcmpeq
+simpleOp DoubleNeOp = Just $ floatCmp if_dcmpne
+simpleOp DoubleGeOp = Just $ floatCmp if_dcmpge
+simpleOp DoubleLeOp = Just $ floatCmp if_dcmple
+simpleOp DoubleGtOp = Just $ floatCmp if_dcmpgt
+simpleOp DoubleLtOp = Just $ floatCmp if_dcmplt
 
 simpleOp DoubleAddOp = Just $ normalOp dadd
 simpleOp DoubleSubOp = Just $ normalOp dsub
@@ -697,12 +697,12 @@ simpleOp DoubleTanhOp = Just $ normalOp $ doubleMathEndoOp "tanh"
 simpleOp DoublePowerOp = Just $ normalOp $ doubleMathOp "pow" [jdouble, jdouble] jdouble
 
 -- Float# ops
-simpleOp FloatEqOp = Just $ typedCmp jfloat ifeq
-simpleOp FloatNeOp = Just $ typedCmp jfloat ifne
-simpleOp FloatGeOp = Just $ typedCmp jfloat ifge
-simpleOp FloatLeOp = Just $ typedCmp jfloat ifle
-simpleOp FloatGtOp = Just $ typedCmp jfloat ifgt
-simpleOp FloatLtOp = Just $ typedCmp jfloat iflt
+simpleOp FloatEqOp = Just $ floatCmp if_fcmpeq
+simpleOp FloatNeOp = Just $ floatCmp if_fcmpne
+simpleOp FloatGeOp = Just $ floatCmp if_fcmpge
+simpleOp FloatLeOp = Just $ floatCmp if_fcmple
+simpleOp FloatGtOp = Just $ floatCmp if_fcmpgt
+simpleOp FloatLtOp = Just $ floatCmp if_fcmplt
 
 simpleOp FloatAddOp = Just $ normalOp fadd
 simpleOp FloatSubOp = Just $ normalOp fsub
@@ -1048,6 +1048,9 @@ typedCmp ft ifop [arg1, arg2]
  <> ifop (iconst jint 1) (iconst jint 0)
 typedCmp _ _ _ = error $ "typedCmp: bad typedCmp"
 
+floatCmp :: (Code -> Code -> Code) -> [Code] -> Code
+floatCmp ifop args = fold args <> ifop (iconst jint 1) (iconst jint 0)
+
 unsignedCmp :: (Code -> Code -> Code) -> [Code] -> Code
 unsignedCmp ifop args
   = typedCmp jlong ifop $ map unsignedExtend args