Do not add unfoldings to lambda-binderswip/T17530

For reasons described in GHC.Core.Opt.Simplify Historical Note [Case binders and join points], we used to keep a Core unfolding in one of the lambda-binders for a join point. But this was always a gross hack -- it's very odd to have an unfolding in a lambda binder, that refers to earlier lambda binders. The hack bit us in various ways: * Most seriously, it is incompatible with linear types in Core. * It complicated demand analysis, and could worsen results * It required extra care in the simplifier (simplLamBinder) * It complicated !5641 (look for "join binder unfoldings") So this patch just removes the hack. Happily, doind so turned out to have no effect on performance.
author: Simon Peyton Jones <simonpj@microsoft.com> 2021-06-02 00:35:22 +0100
committer: Simon Peyton Jones <simonpj@microsoft.com> 2021-06-09 00:23:25 +0100
commit: 145916b1f37297d79581e5f188e5f707895bcd1c (patch)
tree: e7c3d5f8a654894f32b5627261733e05d9a04700
parent: 378c0bba7d132a89dd9c35374b7b4bb5a4730bf7 (diff)
download: haskell-wip/T17530.tar.gz
5 files changed, 23 insertions, 88 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index fdef694cec..f8dbce7652 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2650,11 +2650,9 @@ we behave as follows (#15057, #T15664):
 
 Note [Linting linearity]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-There are two known optimisations that have not yet been updated
+There is one known optimisations that have not yet been updated
 to work with Linear Lint:
 
-* Lambda-bound variables with unfoldings
-  (see Note [Case binders and join points] and ticket #17530)
 * Optimisations can create a letrec which uses a variable linearly, e.g.
     letrec f True = f False
            f False = x
@@ -2663,7 +2661,7 @@ to work with Linear Lint:
   Plan: make let-bound variables remember the usage environment.
   See ticket #18694.
 
-We plan to fix both of the issues in the very near future.
+We plan to fix this issue in the very near future.
 For now, -dcore-lint enables only linting output of the desugarer,
 and full Linear Lint has to be enabled separately with -dlinear-core-lint.
 Ticket #19165 concerns enabling Linear Lint with -dcore-lint.
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 14ee7419bf..bad3234ca9 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -1295,16 +1295,9 @@ annotateLamIdBndr env dmd_ty id
 -- Only called for Ids
   = assert (isId id) $
     -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
-    WithDmdType final_ty new_id
+    WithDmdType main_ty new_id
   where
-    new_id = setIdDemandInfo id dmd
-      -- Watch out!  See note [Lambda-bound unfoldings]
-    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
-                 Nothing  -> main_ty
-                 Just unf -> main_ty `plusDmdType` unf_ty
-                          where
-                             (unf_ty, _) = dmdAnalStar env dmd unf
-
+    new_id  = setIdDemandInfo id dmd
     main_ty = addDemand dmd dmd_ty'
     WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id
 
@@ -1376,16 +1369,6 @@ mentioned in the (unsound) strictness signature, conservatively approximate the
 demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
 
 
-Note [Lambda-bound unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We allow a lambda-bound variable to carry an unfolding, a facility that is used
-exclusively for join points; see Note [Case binders and join points].  If so,
-we must be careful to demand-analyse the RHS of the unfolding!  Example
-   \x. \y{=Just x}. <body>
-Then if <body> uses 'y', then transitively it uses 'x', and we must not
-forget that fact, otherwise we might make 'x' absent when it isn't.
-
-
 ************************************************************************
 *                                                                      *
 \subsection{Strictness signatures}
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 19705f5541..b799c1df59 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -15,7 +15,6 @@ import GHC.Prelude
 import GHC.Platform
 import GHC.Driver.Session
 import GHC.Driver.Ppr
-import GHC.Driver.Config
 import GHC.Core.Opt.Simplify.Monad
 import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
 import GHC.Core.Opt.Simplify.Env
@@ -50,7 +49,7 @@ import GHC.Core.Unfold.Make
 import GHC.Core.Utils
 import GHC.Core.Opt.Arity ( ArityType(..)
                           , pushCoTyArg, pushCoValArg
-                          , idArityType, etaExpandAT )
+                          , etaExpandAT )
 import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
 import GHC.Core.FVs     ( mkRuleInfo )
 import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )
@@ -1520,17 +1519,13 @@ simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
   | isSimplified dup  -- Don't re-simplify if we've simplified it once
                       -- See Note [Avoiding exponential behaviour]
   = do  { tick (BetaReduction bndr)
-        ; (floats1, env') <- simplNonRecX env zapped_bndr arg
+        ; (floats1, env') <- simplNonRecX env bndr arg
         ; (floats2, expr') <- simplLam env' bndrs body cont
         ; return (floats1 `addFloats` floats2, expr') }
 
   | otherwise
   = do  { tick (BetaReduction bndr)
-        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }
-  where
-    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]
-      | isId bndr = zapStableUnfolding bndr
-      | otherwise = bndr
+        ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
 
       -- Discard a non-counting tick on a lambda.  This may change the
       -- cost attribution slightly (moving the allocation of the
@@ -1549,26 +1544,11 @@ simplLam env bndrs body cont
 
 -------------
 simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
--- Used for lambda binders.  These sometimes have unfoldings added by
--- the worker/wrapper pass that must be preserved, because they can't
--- be reconstructed from context.  For example:
---      f x = case x of StrictPair a b -> fw a b x
---      fw a{=OtherCon[]} b{=OtherCon[]} x{=(StrictPair a b)} = ...
--- The "{=(StrictPair a b)}" is an unfolding we can't reconstruct otherwise.
--- Since simplBinder already retains OtherCon bindings we only have to special
--- case core unfoldings like the one for `x`.
-simplLamBndr env bndr
-  | isId bndr && hasCoreUnfolding old_unf   -- Special case
-  = do { (env1, bndr1) <- simplBinder env bndr
-       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr
-                                      (idType bndr1) (idArityType bndr1) old_unf
-       ; let bndr2 = bndr1 `setIdUnfolding` unf'
-       ; return (modifyInScope env1 bndr2, bndr2) }
-
-  | otherwise
-  = simplBinder env bndr                -- Normal case
-  where
-    old_unf = idUnfolding bndr
+-- Historically this had a special case for when a lambda-binder
+-- could have a stable unfolding;
+-- see Historical Note [Case binders and join points]
+-- But now it is much simpler!
+simplLamBndr env bndr = simplBinder env bndr
 
 simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
@@ -1693,19 +1673,6 @@ simplify BIG True; maybe good things happen.  That is why
       (see Note [Trying rewrite rules])
 
 
-Note [Zap unfolding when beta-reducing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Lambda-bound variables can have stable unfoldings, such as
-   $j = \x. \b{Unf=Just x}. e
-See Note [Case binders and join points] below; the unfolding for lets
-us optimise e better.  However when we beta-reduce it we want to
-revert to using the actual value, otherwise we can end up in the
-stupid situation of
-          let x = blah in
-          let b{Unf=Just x} = y
-          in ...b...
-Here it'd be far better to drop the unfolding and use the actual RHS.
-
 ************************************************************************
 *                                                                      *
                      Join points
@@ -3508,27 +3475,11 @@ mkDupableAlt platform case_bndr jfloats (Alt con bndrs' rhs')
   = return (jfloats, Alt con bndrs' rhs')
 
   | otherwise
-  = do  { simpl_opts <- initSimpleOpts <$> getDynFlags
-        ; let rhs_ty'  = exprType rhs'
-              scrut_ty = idType case_bndr
-              case_bndr_w_unf
-                = case con of
-                      DEFAULT    -> case_bndr
-                      DataAlt dc -> setIdUnfolding case_bndr unf
-                          where
-                                 -- See Note [Case binders and join points]
-                             unf = mkInlineUnfolding simpl_opts rhs
-                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
-
-                      LitAlt {} -> warnPprTrace True
-                                    (text "mkDupableAlt" <+> ppr case_bndr <+> ppr con)
-                                    case_bndr
-                           -- The case binder is alive but trivial, so why has
-                           -- it not been substituted away?
+  = do  { let rhs_ty'  = exprType rhs'
 
               final_bndrs'
                 | isDeadBinder case_bndr = filter abstract_over bndrs'
-                | otherwise              = bndrs' ++ [case_bndr_w_unf]
+                | otherwise              = bndrs' ++ [case_bndr]
 
               abstract_over bndr
                   | isTyVar bndr = True -- Abstract over all type variables just in case
@@ -3587,8 +3538,12 @@ the case rn cancels with.
 
 See #4957 a fuller example.
 
-Note [Case binders and join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Historical Note [Case binders and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: this entire Note is now irrelevant.  In Jun 21 we stopped
+adding unfoldings to lambda binders (#17530).  It was always a
+hack and bit us in multiple small and not-so-small ways
+
 Consider this
    case (case .. ) of c {
      I# c# -> ....c....
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 839c2ccd68..8416718c99 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -1001,10 +1001,7 @@ unbox_one_arg opts arg cs
              arg_ids'  = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs
              unbox_fn  = mkUnpackCase (Var arg) co (idMult arg)
                                       dc (ex_tvs' ++ arg_ids')
-             arg_no_unf = zapStableUnfolding arg
-                          -- See Note [Zap unfolding when beta-reducing]
-                          -- in GHC.Core.Opt.Simplify; and see #13890
-             rebox_fn   = Let (NonRec arg_no_unf con_app)
+             rebox_fn   = Let (NonRec arg con_app)
              con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co
        ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids')
        ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 5849b8c283..027c162198 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -670,6 +670,8 @@ zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })
     new_unf = zapFragileUnfolding unf
 
 zapFragileUnfolding :: Unfolding -> Unfolding
+-- ^ Zaps any core unfolding, but /preserves/ evaluated-ness,
+-- i.e. an unfolding of OtherCon
 zapFragileUnfolding unf
  | hasCoreUnfolding unf = noUnfolding
  | otherwise            = unf
author	Simon Peyton Jones <simonpj@microsoft.com>	2021-06-02 00:35:22 +0100
committer	Simon Peyton Jones <simonpj@microsoft.com>	2021-06-09 00:23:25 +0100
commit	145916b1f37297d79581e5f188e5f707895bcd1c (patch)
tree	e7c3d5f8a654894f32b5627261733e05d9a04700
parent	378c0bba7d132a89dd9c35374b7b4bb5a4730bf7 (diff)
download	haskell-wip/T17530.tar.gz