Fix treatment of -0.0

Here we fix a few mis-optimizations that could occur in code with
floating point comparisons with -0.0. These issues arose from our
insistence on rewriting equalities into case analyses and the
simplifier's ignorance of floating-point semantics.

For instance, in Trac #10215 (and the similar issue Trac #9238) we
turned `ds == 0.0` into a case analysis,

```
case ds of
    __DEFAULT -> ...
    0.0 -> ...
```

Where the second alternative matches where `ds` is +0.0 and *also* -0.0.
However, the simplifier doesn't realize this and will introduce a local
inlining of `ds = -- +0.0` as it believes this is the only
value that matches this pattern.

Instead of teaching the simplifier about floating-point semantics
we simply prohibit case analysis on floating-point scrutinees and keep
this logic in the comparison primops, where it belongs.

We do several things here,

 - Add test cases from relevant tickets
 - Clean up a bit of documentation
 - Desugar literal matches against floats into applications of the
   appropriate equality primitive instead of case analysis
 - Add a CoreLint to ensure we don't pattern match on floats in Core

Test Plan: validate with included testcases

Reviewers: goldfire, simonpj, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1061

GHC Trac Issues: #10215, #9238

5 files changed, 32 insertions, 0 deletions

diff --git a/testsuite/tests/deSugar/should_run/T10215.hs b/testsuite/tests/deSugar/should_run/T10215.hs
new file mode 100644
index 0000000000..9a2d224970
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T10215.hs
@@ -0,0 +1,9 @@
+testF :: Float -> Bool
+testF x = x == 0 && not (isNegativeZero x)
+
+testD :: Double -> Bool
+testD x = x == 0 && not (isNegativeZero x)
+
+main :: IO ()
+main = do print $ testF (-0.0)
+          print $ testD (-0.0)
diff --git a/testsuite/tests/deSugar/should_run/T10215.stdout b/testsuite/tests/deSugar/should_run/T10215.stdout
new file mode 100644
index 0000000000..abb239365b
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T10215.stdout
@@ -0,0 +1,3 @@
+False
+False
+
diff --git a/testsuite/tests/deSugar/should_run/T9238.hs b/testsuite/tests/deSugar/should_run/T9238.hs
new file mode 100644
index 0000000000..79eeeb76af
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9238.hs
@@ -0,0 +1,16 @@
+compareDouble :: Double -> Double -> Ordering
+compareDouble x y =
+       case (isNaN x, isNaN y) of
+       (True, True)   -> EQ
+       (True, False)  -> LT
+       (False, True)  -> GT
+       (False, False) ->
+          -- Make -0 less than 0
+          case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of
+          (True, True, True, False) -> LT
+          (True, True, False, True) -> GT
+          _                         -> x `compare` y
+
+main = do
+    let l = [-0, 0]
+    print [ (x, y, compareDouble x y) | x <- l, y <- l ]
diff --git a/testsuite/tests/deSugar/should_run/T9238.stdout b/testsuite/tests/deSugar/should_run/T9238.stdout
new file mode 100644
index 0000000000..8dbd09d20d
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T9238.stdout
@@ -0,0 +1,2 @@
+[(-0.0,-0.0,EQ),(-0.0,0.0,LT),(0.0,-0.0,GT),(0.0,0.0,EQ)]
+
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 228b90dd0f..bc72b01568 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -46,5 +46,7 @@ test('DsStaticPointers',
      ],
      compile_and_run, [''])
 test('T8952', normal, compile_and_run, [''])
+test('T9238', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
+test('T10215', normal, compile_and_run, [''])
 test('DsStrictData', normal, compile_and_run, [''])