Fix over-eager inlining in SimpleOptwip/T19347

In GHC.Core.SimpleOpt, I found that its inlining could duplicate
an arbitary redex inside a lambda!  Consider (\xyz. x+y).  The
occurrence-analysis treats the lamdda as a group, and says that
both x and y occur once, even though the occur under the lambda-z.
See Note [Occurrence analysis for lambda binders] in OccurAnal.

When the lambda is under-applied in a call, the Simplifier is
careful to zap the occ-info on x,y, because they appear under the \z.
(See the call to zapLamBndrs in simplExprF1.)  But SimpleOpt
missed this test, resulting in #19347.

So this patch
* commons up the binder-zapping in GHC.Core.Utils.zapLamBndrs.
* Calls this new function from GHC.Core.Opt.Simplify
* Adds a call to zapLamBndrs to GHC.Core.SimpleOpt.simple_app

This change makes test T12990 regress somewhat, but it was always
very delicate, so I'm going to put up with that.

In this voyage I also discovered a small, rather unrelated infelicity
in the Simplifier:

* In GHC.Core.Opt.Simplify.simplNonRecX we should apply isStrictId
  to the OutId not the InId. See Note [Dark corner with levity polymorphism]

It may never "bite", because SimpleOpt should have inlined all
the levity-polymorphic compulsory inlnings already, but somehow
it bit me at one point and it's generally a more solid thing
to do.

Fixing the main bug increases runtime allocation in test
perf/should_run/T12990, for (acceptable) reasons explained in a
comement on

Metric Increase:
    T12990

1 files changed, 41 insertions, 23 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 4ca8985f8b..e37571d7cf 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -387,8 +387,13 @@ simplNonRecX env bndr new_rhs
 
   | otherwise
   = do  { (env', bndr') <- simplBinder env bndr
-        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
-                -- simplNonRecX is only used for NotTopLevel things
+        ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs }
+          -- NotTopLevel: simplNonRecX is only used for NotTopLevel things
+          --
+          -- isStrictId: use bndr' because in a levity-polymorphic setting
+          -- the InId bndr might have a levity-polymorphic type, which
+          -- which isStrictId doesn't expect
+          -- c.f. Note [Dark corner with levity polymorphism]
 
 --------------------------
 completeNonRecX :: TopLevelFlag -> SimplEnv
@@ -1032,18 +1037,11 @@ simplExprF1 env expr@(Lam {}) cont
         -- occ-info, UNLESS the remaining binders are one-shot
   where
     (bndrs, body) = collectBinders expr
-    zapped_bndrs | need_to_zap = map zap bndrs
-                 | otherwise   = bndrs
-
-    need_to_zap = any zappable_bndr (drop n_args bndrs)
+    zapped_bndrs = zapLamBndrs n_args bndrs
     n_args = countArgs cont
         -- NB: countArgs counts all the args (incl type args)
         -- and likewise drop counts all binders (incl type lambdas)
 
-    zappable_bndr b = isId b && not (isOneShotBndr b)
-    zap b | isTyVar b = b
-          | otherwise = zapLamIdInfo b
-
 simplExprF1 env (Case scrut bndr _ alts) cont
   = {-#SCC "simplExprF1-Case" #-}
     simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
@@ -1573,21 +1571,22 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
        ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
          simplLam env' bndrs body cont }
 
-  -- Deal with strict bindings
-  | isStrictId bndr          -- Includes coercions, and unlifted types
-  , sm_case_case (getMode env)
-  = simplExprF (rhs_se `setInScopeFromE` env) rhs
-               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
-                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })
-
-  -- Deal with lazy bindings
   | otherwise
-  = ASSERT( not (isTyVar bndr) )
-    do { (env1, bndr1) <- simplNonRecBndr env bndr
-       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing
+  = do { (env1, bndr1) <- simplNonRecBndr env bndr
+
+       -- Deal with strict bindings
+       -- See Note [Dark corner with levity polymorphism]
+       ; if isStrictId bndr1 && sm_case_case (getMode env)
+         then simplExprF (rhs_se `setInScopeFromE` env) rhs
+                   (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
+                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+       -- Deal with lazy bindings
+         else do
+       { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing
        ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
        ; (floats2, expr') <- simplLam env3 bndrs body cont
-       ; return (floats1 `addFloats` floats2, expr') }
+       ; return (floats1 `addFloats` floats2, expr') } }
 
 ------------------
 simplRecE :: SimplEnv
@@ -1608,7 +1607,26 @@ simplRecE env pairs body cont
         ; (floats2, expr') <- simplExprF env2 body cont
         ; return (floats1 `addFloats` floats2, expr') }
 
-{- Note [Avoiding exponential behaviour]
+{- Note [Dark corner with levity polymorphism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In `simplNonRecE`, the call to `isStrictId` will fail if the binder
+has a levity-polymorphic type, of kind (TYPE r).  So we are careful to
+call `isStrictId` on the OutId, not the InId, in case we have
+     ((\(r::RuntimeRep) \(x::Type r). blah) Lifted arg)
+That will lead to `simplNonRecE env (x::Type r) arg`, and we can't tell
+if x is lifted or unlifted from that.
+
+We only get such redexes from the compulsory inlining of a wired-in,
+levity-polymorphic function like `rightSection` (see
+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined
+such compulsory inlinings already, but belt and braces does no harm.
+
+Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the
+Simplifier without first calling SimpleOpt, so anything involving
+GHCi or TH and operator sections will fall over if we don't take
+care here.
+
+Note [Avoiding exponential behaviour]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 One way in which we can get exponential behaviour is if we simplify a
 big expression, and the re-simplify it -- and then this happens in a