Be a bit more aggressive about let-to-case
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 12 Sep 2018 12:06:53 +0000 (13:06 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 12 Sep 2018 12:11:06 +0000 (13:11 +0100)
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.

compiler/simplCore/Simplify.hs
testsuite/tests/simplCore/should_compile/Makefile
testsuite/tests/simplCore/should_compile/T15631.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/T15631.stdout [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index c8870c9..e359c43 100644 (file)
@@ -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
index 1233b8c..277a5a6 100644 (file)
@@ -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 (file)
index 0000000..55f6758
--- /dev/null
@@ -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 (file)
index 0000000..5a096f2
--- /dev/null
@@ -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 }
index 1284b7c..d572d04 100644 (file)
@@ -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'])