From d2d13a4f6750e30389552974bd7465712d522735 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 14 Mar 2017 13:52:48 +0000 Subject: Fix CaseIdentity optimisation AGAIN In this commit commit 02ac2974ce8e537372bff8d9e0a6efb461ed2c59 Author: Simon Peyton Jones 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. (cherry picked from commit 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(-) create mode 100644 testsuite/tests/simplCore/should_compile/T13417.hs diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index a3eb3570c4..ab270c5a86 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -1821,21 +1821,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 0000000000..a919291bb7 --- /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 c276834547..38d43039a8 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -237,3 +237,4 @@ test('T12076', extra_clean(['T12076a.hi', 'T12076a.o']), multimod_compile, ['T12 test('T12076lit', normal, compile, ['-O']) test('T12076sat', normal, compile, ['-O']) test('par01', only_ways(['optasm']), compile, ['-ddump-prep -dsuppress-uniques -O2']) +test('T13417', normal, compile, ['-O']) -- cgit v1.2.1