Simplify and improve CSE

Trac #13156 showed a lost opportunity for CSE. I found that it was
easy to fix, and it had the nice side effect of rendering a previous
nasty case, described in Note [Corner case for case expressions],
unnecessary.

Simpler code, does more.  Great.

compiler/simplCore/CSE.hs

@@ -15,9 +15,9 @@ import Var              ( Var )
 import Id               ( Id, idType, idUnfolding, idInlineActivation
                         , zapIdOccInfo, zapIdUsageInfo )
 import CoreUtils        ( mkAltExpr
-                        , exprIsTrivial, exprOkForSpeculation
                         , stripTicksE, stripTicksT, mkTicks )
-import Type             ( tyConAppArgs, isUnliftedType )
+import Literal          ( litIsTrivial )
+import Type             ( tyConAppArgs )
 import CoreSyn
 import Outputable
 import BasicTypes       ( isAlwaysActive )
@@ -62,9 +62,10 @@ We can simply add clones to the substitution already described.
 
 Note [CSE for bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~
-Let-bindings have two cases, implemnted by addBinding.
+Let-bindings have two cases, implemented by addBinding.
+
+* SUBSTITUTE: applies when the RHS is a variable or literal
 
-* Trivial RHS:
      let x = y in ...(h x)....
 
   Here we want to extend the /substitution/ with x -> y, so that the
@@ -72,7 +73,7 @@ Let-bindings have two cases, implemnted by addBinding.
   NB: the substitution maps InIds, so we extend the substitution with
       a biding for the original InId 'x'
 
-  How can we have a trivial RHS? Doens't the simplifier inline them?
+  How can we have a variable on the RHS? Doesn't the simplifier inline them?
 
     - First, the original RHS might have been (g z) which has CSE'd
       with an enclosing (let y = g z in ...).  This is super-important.
@@ -87,17 +88,29 @@ Let-bindings have two cases, implemnted by addBinding.
     - Second, we use cseRHS for case expression scrutinees too;
       see Note [CSE for case expressions]
 
-* Non-trivial RHS
+* EXTEND THE REVERSE MAPPING: applies in all other cases
+
      let x = h y in ...(h y)...
 
   Here we want to extend the /reverse mapping (cs_map)/ so that
   we CSE the (h y) call to x.
 
+  Note that we use EXTEND even for a trivial expression, provided it
+  is not a variable or literal. In particular this /includes/ type
+  applications. This can be important (Trac #13156); e.g.
+     case f @ Int of { r1 ->
+     case f @ Int of { r2 -> ...
+  Here we want to common-up the two uses of (f @ Int) so we can
+  remove one of the case expressions.
+
+  See also Note [Corner case for case expressions] for another
+  reason not to use SUBSTITUTE for all trivial expressions.
+
 Notice that
-  - The trivial-RHS situation extends the substitution (cs_subst)
-  - The non-trivial-RHS situation extends the reverse mapping (cs_map)
+  - The SUBSTITUTE situation extends the substitution (cs_subst)
+  - The EXTEND situation extends the reverse mapping (cs_map)
 
-Notice also that in the trivial-RHS case we leave behind a binding
+Notice also that in the SUBSTITUTE case we leave behind a binding
   x = y
 even though we /also/ carry a substitution x -> y.  Can we just drop
 the binding instead?  Well, not at top level! See SimplUtils
@@ -217,24 +230,19 @@ modules might see that.  So it seems dodgy and we don't do it.
 
 Note [Corner case for case expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consdider
+Here is another reason that we do not use SUBSTITUTE for
+all trivial expressions. Consider
    case x |> co of (y::Array# Int) { ... }
 
-Is it ok to extend the substutition with (y -> x |> co)?
-Because y is of unlifted type, this is only OK if (x |> co) is
-ok-for-speculation, else we'll destroy the let/app invariant.
-But surely it is ok-for-speculation, becasue it's a trivial
-expression, and x's type is also unlifted, presumably.
+We do not want to extend the substitution with (y -> x |> co); since y
+is of unlifted type, this would desroy the let/app invariant if (x |>
+co) was not ok-for-speculation.
 
-Well, maybe not if you are using unsafe casts.  I actually found
-a case where we had
+But surely (x |> co) is ok-for-speculation, becasue it's a trivial
+expression, and x's type is also unlifted, presumably.  Well, maybe
+not if you are using unsafe casts.  I actually found a case where we
+had
    (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
-This is a vanishingly strange corner case, but we still have
-to check.
-
-We do the check in addBinding, but it can't fire when addBinding is called
-from a let-binding, because they are always ok-for-speculation.  Never
-mind!
 
 
 ************************************************************************
@@ -275,9 +283,9 @@ addBinding :: CSEnv                      -- Includes InId->OutId cloning
 -- Extend the CSE env with a mapping [rhs -> out-id]
 -- unless we can instead just substitute [in-id -> rhs]
 addBinding env in_id out_id rhs'
-  | no_cse      = (env,                              out_id)
-  | ok_to_subst = (extendCSSubst env in_id rhs',     out_id)
-  | otherwise   = (extendCSEnv env rhs' id_expr', zapped_id)
+  | no_cse    = (env,                              out_id)
+  | use_subst = (extendCSSubst env in_id rhs',     out_id)
+  | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)
   where
     id_expr'  = varToCoreExpr out_id
     zapped_id = zapIdUsageInfo out_id
@@ -296,15 +304,15 @@ addBinding env in_id out_id rhs'
           || isStableUnfolding (idUnfolding out_id)
              -- See Note [CSE for stable unfoldings]
 
+    -- Should we use SUBSTITUTE or EXTEND?
     -- See Note [CSE for bindings]
-    ok_to_subst = exprIsTrivial rhs'
-               && (not (isUnliftedType (idType out_id))
-                   || exprOkForSpeculation rhs')
-               -- See Note [Corner case for case expressions]
+    use_subst = case rhs' of
+                   Var {} -> True
+                   Lit l  -> litIsTrivial l
+                   _      -> False
 
 tryForCSE :: CSEnv -> InExpr -> OutExpr
 tryForCSE env expr
-  | exprIsTrivial expr'              = expr'       -- No point
   | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
   | otherwise                        = expr'
     -- The varToCoreExpr is needed if we have

testsuite/tests/simplCore/should_compile/Makefile

@@ -118,6 +118,11 @@ T13155:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T13155.hs -O -ddump-prep | grep -c "plusAddr#"
         # There should be only one plusAddr#!
 
+T13156:
+	$(RM) -f T13156.hi T13156.o
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T13156.hs -O -ddump-prep -dsuppress-uniques | grep "case"
+        # There should be a single 'case case'
+
 .PHONY: T4138
 T4138:
 	$(RM) -f T4138.hi   T4138.o

testsuite/tests/simplCore/should_compile/T13156.hs

+module T13156 where
+
+f g x = let r :: [a] -> [a]
+            r = case g x of True -> reverse . reverse
+                            False -> reverse
+        in
+        r `seq` r `seq` True
+
+
+{- Expected -ddump-prep looks like this.
+   (Room for improvement on the case (case ..) line.)
+
+-- RHS size: {terms: 9, types: 9, coercions: 0}
+T13156.f1 :: forall a. [a] -> [a]
+[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>, Unf=OtherCon []]
+T13156.f1 =
+  \ (@ a_aC4) (x_sNG [Occ=Once] :: [a]) ->
+    case GHC.List.reverse @ a x_sNG of sat_sNH { __DEFAULT ->
+    GHC.List.reverse1 @ a sat_sNH (GHC.Types.[] @ a)
+    }
+
+-- RHS size: {terms: 13, types: 20, coercions: 0}
+T13156.f :: forall p. (p -> GHC.Types.Bool) -> p -> GHC.Types.Bool
+[GblId,
+ Arity=2,
+ Caf=NoCafRefs,
+ Str=<C(S),1*C1(U)><L,U>,
+ Unf=OtherCon []]
+T13156.f =
+  \ (@ p_aBS)
+    (g_sNI [Occ=Once!] :: p -> GHC.Types.Bool)
+    (x_sNJ [Occ=Once] :: p) ->
+    case case g_sNI x_sNJ of {
+           GHC.Types.False -> GHC.List.reverse @ GHC.Types.Any;
+           GHC.Types.True -> T13156.f1 @ GHC.Types.Any
+         }
+    of
+    { __DEFAULT ->
+    GHC.Types.True
+    }
+
+-}

testsuite/tests/simplCore/should_compile/T13156.stdout

+    case GHC.List.reverse @ a x of sat { __DEFAULT ->
+    case case g x of {

testsuite/tests/simplCore/should_compile/all.T

@@ -261,4 +261,4 @@ test('T13025',
      normal,
      run_command,
      ['$MAKE -s --no-print-directory T13025'])
-
+test('T13156', normal, run_command, ['$MAKE -s --no-print-directory T13156'])