Fix CaseIdentity optimisation AGAIN
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 14 Mar 2017 13:52:48 +0000 (13:52 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 14 Mar 2017 13:55:30 +0000 (13:55 +0000)
In this commit
    commit 02ac2974ce8e537372bff8d9e0a6efb461ed2c59
    Author: Simon Peyton Jones <simonpj@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.

compiler/simplCore/SimplUtils.hs
testsuite/tests/simplCore/should_compile/T13417.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index 0fe262b..49bb6c4 100644 (file)
@@ -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 (file)
index 0000000..a919291
--- /dev/null
@@ -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
index 7bad786..5265569 100644 (file)
@@ -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'])