[commit: ghc] master: Fix CaseIdentity optimisation AGAIN (82b4059)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/82b40598ea7a9c00abdeae37bc47896f880fbbdc/ghc

>---------------------------------------------------------------

commit 82b40598ea7a9c00abdeae37bc47896f880fbbdc
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Mar 14 13:52:48 2017 +0000

    Fix CaseIdentity optimisation AGAIN
    
    In this commit
        commit 02ac2974ce8e537372bff8d9e0a6efb461ed2c59
        Author: Simon Peyton Jones <simonpj at microsoft.com>
        Date:   Wed Nov 16 10:37:47 2011 +0000
    
        Fix CaseIdentity optimisaion
    
        In fixing one bug I'd introduced another;
           case x of { T -> T; F -> F }
        wasn't getting optmised!  Trivial to fix.
    
    I introduced yet another!  This line of code in SimplUtils.mkCase1
    
        check_eq (Var v)    (DataAlt con) []   = v == dataConWorkId con
                                                 -- Optimisation only
    
    is patently false when arg_tys is non-empty.  Astonishing that it
    has not shown up before now.
    
    Easily fixed though.  This was all shown up by Trac #13417, which is
    now fixed.
    
    Merge to 8.0, 8.2.


>---------------------------------------------------------------

82b40598ea7a9c00abdeae37bc47896f880fbbdc
 compiler/simplCore/SimplUtils.hs                   | 18 +++++++++---------
 testsuite/tests/simplCore/should_compile/T13417.hs |  8 ++++++++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index 0fe262b..49bb6c4 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1886,21 +1886,21 @@ mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
     ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)
     identity_alt (con, args, rhs) = check_eq rhs con args
 
-    check_eq (Cast rhs co) con        args
+    check_eq (Cast rhs co) con args        -- See Note [RHS casts]
       = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args
-        -- See Note [RHS casts]
-    check_eq (Lit lit)  (LitAlt lit') _    = lit == lit'
+    check_eq (Tick t e) alt args
+      = tickishFloatable t && check_eq e alt args
+
+    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'
     check_eq (Var v) _ _  | v == case_bndr = True
-    check_eq (Var v)    (DataAlt con) []   = v == dataConWorkId con
+    check_eq (Var v)   (DataAlt con) args
+      | null arg_tys, null args            = v == dataConWorkId con
                                              -- Optimisation only
-    check_eq (Tick t e) alt           args = tickishFloatable t &&
-                                             check_eq e alt args
     check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $
-                                             mkConApp con (arg_tys ++
-                                                           varsToCoreExprs args)
+                                             mkConApp2 con arg_tys args
     check_eq _          _             _    = False
 
-    arg_tys = map Type (tyConAppArgs (idType case_bndr))
+    arg_tys = tyConAppArgs (idType case_bndr)
 
         -- Note [RHS casts]
         -- ~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/simplCore/should_compile/T13417.hs b/testsuite/tests/simplCore/should_compile/T13417.hs
new file mode 100644
index 0000000..a919291
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13417.hs
@@ -0,0 +1,8 @@
+module T13417 where
+
+-- Amazingly this crashed GHC 8.0.2
+
+data T a = E7
+
+cons7 :: T a -> T b
+cons7 E7 = E7
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 7bad786..5265569 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -250,3 +250,4 @@ test('T13317',
 test('T13340', normal, run_command, ['$MAKE -s --no-print-directory T13340'])
 test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
 test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
+test('T13417', normal, compile, ['-O'])