[commit: ghc] wip/T12370: Demand analyser: Implement LetUp rule (#12370) (aa472d7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12370
Link       : http://ghc.haskell.org/trac/ghc/changeset/aa472d7bf13bbeb390e857c95c8b92d90d6246ae/ghc

>---------------------------------------------------------------

commit aa472d7bf13bbeb390e857c95c8b92d90d6246ae
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Jul 6 15:44:18 2016 +0200

    Demand analyser: Implement LetUp rule (#12370)
    
    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.


>---------------------------------------------------------------

aa472d7bf13bbeb390e857c95c8b92d90d6246ae
 compiler/stranal/DmdAnal.hs                           | 19 +++++++++++++++++++
 .../tests/simplCore/should_compile/spec-inline.stderr |  2 +-
 2 files changed, 20 insertions(+), 1 deletion(-)

diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 53144ff..4ae46a1 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -255,6 +255,20 @@ 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, and is
+-- used for everything that is not a lambda.
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  | not (isLam rhs)
+  , Nothing <- unpackTrivial rhs -- Lets use the existing code path for 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
@@ -587,6 +601,11 @@ unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
 unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
 unpackTrivial _                       = Nothing
 
+-- isLam e /= null (fst (collectBinders e))
+isLam :: CoreExpr -> Bool
+isLam (Lam _ _) = True
+isLam _ = False
+
 {-
 Note [Demand analysis for trivial right-hand sides]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 64bf015..732265a 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 {