diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-03-14 13:52:48 +0000 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-03-14 10:09:05 -0400 |
| commit | d2d13a4f6750e30389552974bd7465712d522735 (patch) | |
| tree | 981f611c8b4d7c78b6845a9e8e49e06c0607b417 | |
| parent | c873012bdc1f349cbee75cf514c0d3403d21a5bc (diff) | |
| download | haskell-ghc-8.0.tar.gz | |
Fix CaseIdentity optimisation AGAINghc-8.0
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.
(cherry picked from commit 82b40598ea7a9c00abdeae37bc47896f880fbbdc)
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T13417.hs | 8 | ||||
| -rw-r--r-- | 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 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']) |