[commit: ghc] master: Be a bit more aggressive about let-to-case (0e6d42f)

git at git.haskell.org git at git.haskell.org
Wed Sep 12 14:08:44 UTC 2018 

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/0e6d42fe76958648243f99c49e648769c1ea658c/ghc

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

commit 0e6d42fe76958648243f99c49e648769c1ea658c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Sep 12 13:06:53 2018 +0100

    Be a bit more aggressive about let-to-case
    
    This patch takes up the missed opportunity described in
    Trac #15631, by convering a case into a let slightly
    more agressively. See Simplify.hs
    Note [Case-to-let for strictly-used binders]
    
    There is no measurable perf impact for good or ill. But
    the code is simpler and easier to explain.


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

0e6d42fe76958648243f99c49e648769c1ea658c
 compiler/simplCore/Simplify.hs                     | 52 +++++++++++++++-------
 testsuite/tests/simplCore/should_compile/Makefile  |  5 +++
 testsuite/tests/simplCore/should_compile/T15631.hs | 11 +++++
 .../tests/simplCore/should_compile/T15631.stdout   |  7 +++
 testsuite/tests/simplCore/should_compile/all.T     |  5 ++-
 5 files changed, 62 insertions(+), 18 deletions(-)

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index c8870c9..e359c43 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -2247,7 +2247,7 @@ We treat the unlifted and lifted cases separately:
   However, we can turn the case into a /strict/ let if the 'r' is
   used strictly in the body.  Then we won't lose divergence; and
   we won't build a thunk because the let is strict.
-  See also Note [Eliminating redundant seqs]
+  See also Note [Case-to-let for strictly-used binders]
 
   NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
   We want to turn
@@ -2256,13 +2256,18 @@ We treat the unlifted and lifted cases separately:
      let r = absentError "foo" in ...MkT r...
 
 
-Note [Eliminating redundant seqs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Case-to-let for strictly-used binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we have this:
-   case x of r { _ -> ..r.. }
-where 'r' is used strictly in (..r..), the case is effectively a 'seq'
-on 'x', but since 'r' is used strictly anyway, we can safely transform to
-   (...x...)
+   case <scrut> of r { _ -> ..r.. }
+
+where 'r' is used strictly in (..r..), we can safely transform to
+   let r = <scrut> in ...r...
+
+This is a Good Thing, because 'r' might be dead (if the body just
+calls error), or might be used just once (in which case it can be
+inlined); or we might be able to float the let-binding up or down.
+E.g. Trac #15631 has an example.
 
 Note that this can change the error behaviour.  For example, we might
 transform
@@ -2278,7 +2283,24 @@ transformation bit us in practice.
 
 See also Note [Empty case alternatives] in CoreSyn.
 
-Just for reference, the original code (added Jan 13) looked like this:
+Historical notes
+
+There have been various earlier versions of this patch:
+
+* By Sept 18 the code looked like this:
+     || scrut_is_demanded_var scrut
+
+    scrut_is_demanded_var :: CoreExpr -> Bool
+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
+    scrut_is_demanded_var _          = False
+
+  This only fired if the scrutinee was a /variable/, which seems
+  an unnecessary restriction. So in Trac #15631 I relaxed it to allow
+  arbitrary scrutinees.  Less code, less to explain -- but the change
+  had 0.00% effect on nofib.
+
+* Previously, in Jan 13 the code looked like this:
      || case_bndr_evald_next rhs
 
     case_bndr_evald_next :: CoreExpr -> Bool
@@ -2289,8 +2311,8 @@ Just for reference, the original code (added Jan 13) looked like this:
     case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
     case_bndr_evald_next _               = False
 
-(This came up when fixing Trac #7542. See also Note [Eta reduction of
-an eval'd function] in CoreUtils.)
+  This patch was part of fixing Trac #7542. See also
+  Note [Eta reduction of an eval'd function] in CoreUtils.)
 
 
 Further notes about case elimination
@@ -2405,7 +2427,7 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   | all_dead_bndrs
   , if isUnliftedType (idType case_bndr)
     then exprOkForSpeculation scrut
-    else exprIsHNF scrut || scrut_is_demanded_var scrut
+    else exprIsHNF scrut || case_bndr_is_demanded
   = do { tick (CaseElim case_bndr)
        ; (floats1, env') <- simplNonRecX env case_bndr scrut
        ; (floats2, expr') <- simplExprF env' rhs cont
@@ -2424,12 +2446,8 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
     all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
     is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
 
-    scrut_is_demanded_var :: CoreExpr -> Bool
-            -- See Note [Eliminating redundant seqs]
-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
-    scrut_is_demanded_var _          = False
-
+    case_bndr_is_demanded = isStrictDmd (idDemandInfo case_bndr)
+    -- See Note [Case-to-let for strictly-used binders]
 
 rebuildCase env scrut case_bndr alts cont
   = reallyRebuildCase env scrut case_bndr alts cont
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 1233b8c..277a5a6 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -246,3 +246,8 @@ T14140:
 	$(RM) -f T14140.o T14140.hi
 	-'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T14140.hs | grep '[2-9]# *->'
 # Expecting no output from the grep, hence "-"
+
+T15631:
+	$(RM) -f T15631.o T15631.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T15631.hs | grep 'case'
+# Expecting one fewwer case expressions after fixing Trac #15631
diff --git a/testsuite/tests/simplCore/should_compile/T15631.hs b/testsuite/tests/simplCore/should_compile/T15631.hs
new file mode 100644
index 0000000..55f6758
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T15631.hs
@@ -0,0 +1,11 @@
+{-# Language PartialTypeSignatures, RankNTypes #-}
+
+module Foo where
+
+f xs = let ys = reverse xs
+       in ys `seq`
+          let w = length xs
+          in w + length (reverse (case ys of { a:as -> as; [] -> [] }))
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T15631.stdout b/testsuite/tests/simplCore/should_compile/T15631.stdout
new file mode 100644
index 0000000..5a096f2
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T15631.stdout
@@ -0,0 +1,7 @@
+      case GHC.List.$wlenAcc
+      case GHC.List.$wlenAcc @ a w 0# of ww2 { __DEFAULT ->
+      case GHC.List.reverse1 @ a w (GHC.Types.[] @ a) of {
+        [] -> case Foo.f1 @ a of { GHC.Types.I# v1 -> GHC.Prim.+# ww2 v1 };
+          case GHC.List.$wlenAcc
+                 case Foo.$wf @ a w of ww [Occ=Once] { __DEFAULT ->
+      case Foo.$wf @ a w of ww { __DEFAULT -> GHC.Types.I# ww }
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 1284b7c..d572d04 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -322,4 +322,7 @@ test('T15517', normal, compile, ['-O0'])
 test('T15517a', normal, compile, ['-O0'])
 test('T15453', normal, compile, ['-dcore-lint -O1'])
 test('T15445', normal, multimod_compile, ['T15445', '-v0 -O -ddump-rule-firings'])
-
+test('T15631',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory T15631'])

More information about the ghc-commits mailing list