[commit: ghc] wip/T12370: Implement LetUp rule (#12370) (04ded5e)

[git at git.haskell.org]

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

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

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

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

    Implement LetUp rule (#12370)


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

04ded5e3c0bcc359f4b46958b5942b8230af1b28
 compiler/stranal/DmdAnal.hs | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~