Demand analyser: Implement LetUp rule (#12370)wip/T12370

This makes the implementation match the description in the paper more
closely: There, a let binding that is not a function has first its body
analised, and then the binding’s RHS. This way, the demand on the bound
variable by the body can be fed into the RHS, yielding more precise
results.

Performance measurements do unfortunately not show significant
improvements or regessions.

Differential Revision: https://phabricator.haskell.org/D2395

3 files changed, 62 insertions, 22 deletions

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index a6f8f82ec8..9ddad9cea1 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -32,6 +32,7 @@ module CoreSyn (
         -- ** Simple 'Expr' access functions and predicates
         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
         collectBinders, collectTyBinders, collectTyAndValBinders,
+        isLam,
         collectArgs, collectArgsTicks, flattenBinds,
 
         exprToType, exprToCoercion_maybe,
@@ -1656,6 +1657,13 @@ collectTyAndValBinders expr
     (tvs, body1) = collectTyBinders expr
     (ids, body)  = collectValBinders body1
 
+-- | Is this a lambda (not hidden inside a cast or so)?
+-- This relates to 'collectBinders':
+-- > isLam e /= null (fst (collectBinders e))
+isLam :: CoreExpr -> Bool
+isLam (Lam _ _) = True
+isLam _         = False
+
 -- | Takes a nested application expression and returns the the function
 -- being applied and the arguments to which it is applied
 collectArgs :: Expr b -> (Expr b, [Arg b])
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 53144fff10..5d70481751 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -64,8 +64,8 @@ dmdAnalTopBind :: AnalEnv
 dmdAnalTopBind sigs (NonRec id rhs)
   = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2)
   where
-    (  _, _, _,   rhs1) = dmdAnalRhs TopLevel Nothing sigs             id rhs
-    (sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1
+    (  _, _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs             id rhs
+    (sig, _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1
         -- Do two passes to improve CPR information
         -- See comments with ignore_cpr_info in mk_sig_ty
         -- and with extendSigsWithLam
@@ -188,7 +188,7 @@ dmdAnal' env dmd (App fun arg)
 --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
     (res_ty `bothDmdType` arg_ty, App fun' arg')
 
--- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@
+-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
 dmdAnal' env dmd (Lam var body)
   | isTyVar var
   = let
@@ -255,10 +255,26 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
 --                                   , text "res_ty" <+> ppr res_ty ]) $
     (res_ty, Case scrut' case_bndr' ty alts')
 
+-- The following case handle the LetUp variant of processing a let binding.
+-- This is used for a non-recursive local let without manifest lambdas.
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  | not (isLam rhs)
+  , Nothing <- unpackTrivial rhs
+      -- dmdAnalRhsLetDown treats trivial right hand sides specially
+      -- so if we have a trival right hand side, fall through to that.
+  = (final_ty, Let (NonRec id' rhs') body')
+  where
+    (body_ty, body')   = dmdAnal env dmd body
+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
+    id'                = setIdDemandInfo id id_dmd
+
+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
+    final_ty           = body_ty' `bothDmdType` rhs_ty
+
 dmdAnal' env dmd (Let (NonRec id rhs) body)
   = (body_ty2, Let (NonRec id2 rhs') body')
   where
-    (sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs
+    (sig, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs
     (body_ty, body')          = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
     (body_ty1, id2)           = annotateBndr env body_ty id1
     body_ty2                  = addLazyFVs body_ty1 lazy_fv
@@ -509,7 +525,7 @@ dmdFix top_lvl env orig_pairs
         my_downRhs (env, lazy_fv) (id,rhs)
           = ((env', lazy_fv'), (id', rhs'))
           where
-            (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
+            (sig, lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs
             lazy_fv'                   = plusVarEnv_C bothDmd lazy_fv lazy_fv1
             env'                       = extendAnalEnv top_lvl env id sig
 
@@ -518,26 +534,42 @@ dmdFix top_lvl env orig_pairs
                         Just (sig,_) -> sig
                         Nothing      -> pprPanic "dmdFix" (ppr var)
 
--- Non-recursive bindings
-dmdAnalRhs :: TopLevelFlag
+
+-- Trivial RHS
+-- See Note [Demand analysis for trivial right-hand sides]
+dmdAnalTrivialRhs ::
+    AnalEnv -> Id -> CoreExpr -> Var ->
+    (StrictSig, VarEnv Demand, Id, CoreExpr)
+dmdAnalTrivialRhs env id rhs fn
+  = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs)
+  where
+    fn_str = getStrictness env fn
+    fn_fv | isLocalId fn = unitVarEnv fn topDmd
+          | otherwise    = emptyDmdEnv
+    -- Note [Remember to demand the function itself]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- fn_fv: don't forget to produce a demand for fn itself
+    -- Lacking this caused Trac #9128
+    -- The demand is very conservative (topDmd), but that doesn't
+    -- matter; trivial bindings are usually inlined, so it only
+    -- kicks in for top-level bindings and NOINLINE bindings
+
+-- This implements the LetDown rule of the analysis:
+--  * assuming a demand of <L,U>
+--  * looking at the definition
+--  * determining a strictness signature
+-- It is used for toplevel definition, recursive definitions and local
+-- non-recursive definitions that have manifest lambdas.
+-- Local non-recursive definitions without a lambda are handled with LetUp.
+dmdAnalRhsLetDown :: TopLevelFlag
            -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
            -> AnalEnv -> Id -> CoreExpr
-           -> (StrictSig,  DmdEnv, Id, CoreExpr)
+           -> (StrictSig, DmdEnv, Id, CoreExpr)
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
-dmdAnalRhs top_lvl rec_flag env id rhs
+dmdAnalRhsLetDown top_lvl rec_flag env id rhs
   | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
-  , let fn_str = getStrictness env fn
-        fn_fv | isLocalId fn = unitVarEnv fn topDmd
-              | otherwise    = emptyDmdEnv
-        -- Note [Remember to demand the function itself]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- fn_fv: don't forget to produce a demand for fn itself
-        -- Lacking this caused Trac #9128
-        -- The demand is very conservative (topDmd), but that doesn't
-        -- matter; trivial bindings are usually inlined, so it only
-        -- kicks in for top-level bindings and NOINLINE bindings
-  = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs)
+  = dmdAnalTrivialRhs env id rhs fn
 
   | otherwise
   = (sig_ty, lazy_fv, id', mkLams bndrs' body')
@@ -659,7 +691,7 @@ addLazyFVs dmd_ty lazy_fvs
         -- demand with the bottom coming up from 'error'
         --
         -- I got a loop in the fixpointer without this, due to an interaction
-        -- with the lazy_fv filtering in dmdAnalRhs.  Roughly, it was
+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
         --      letrec f n x
         --          = letrec g y = x `fatbar`
         --                         letrec h z = z + ...g...
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 64bf015a26..732265a8f6 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -43,7 +43,7 @@ Rec {
 -- RHS size: {terms: 55, types: 9, coercions: 0}
 Roman.foo_$s$wgo [Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
-[GblId, Arity=2, Caf=NoCafRefs, Str=<L,U><S,U>]
+[GblId, Arity=2, Caf=NoCafRefs, Str=<S,U><S,U>]
 Roman.foo_$s$wgo =
   \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
     let {