[commit: ghc] cardinality: more careful treatment of single-shot lambdas (f2777c1)

[Ilya Sergey]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : cardinality

http://hackage.haskell.org/trac/ghc/changeset/f2777c1e00b5168ad53b6f2ca3dc5be80684b833

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

commit f2777c1e00b5168ad53b6f2ca3dc5be80684b833
Author: Ilya Sergey <ilya.sergey at gmail.com>
Date:   Fri Feb 22 19:45:53 2013 +0100

    more careful treatment of single-shot lambdas

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

 compiler/basicTypes/Demand.lhs |    2 +-
 compiler/stranal/DmdAnal.lhs   |   14 +++++++++-----
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 490efb3..e0dc654 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -555,7 +555,7 @@ vanillaCall 0 = onceEvalDmd
 -- generate C^n (U)  
 vanillaCall n =
   let strComp = (iterate strCall strStr) !! n
-      absComp = (iterate (absCall Many) absTop) !! n
+      absComp = (iterate (absCall One) absTop) !! n
    in mkJointDmd strComp absComp
 
 -- cardinality stuff
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 4162ee7..5643439 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -183,9 +183,14 @@ dmdAnal dflags sigs dmd (App fun (Coercion co))
 -- beautiful, compositional, application rule :-)
 dmdAnal dflags env dmd (App fun arg)	-- Non-type arguments
   = let				-- [Type arg handled above]
-	(fun_ty, fun') 	  = dmdAnal dflags env (mkCallDmd dmd) fun
-	(arg_ty, arg') 	  = dmdAnal dflags env arg_dmd arg
+        call_dmd          = mkCallDmd dmd
+	(fun_ty, fun') 	  = dmdAnal dflags env call_dmd fun
 	(arg_dmd, res_ty) = splitDmdTy fun_ty
+        (arg_ty, arg') 	  = dmdAnal dflags env arg_dmd arg
+
+	-- annotate components with single-shotness explicitly a-posteriori
+        arg''             = annotate_rhs_lambdas (absd arg_dmd) arg'
+        fun''             = annotate_rhs_lambdas (absd call_dmd) fun'
     in
 --    pprTrace "dmdAnal:app" (vcat
 --         [ text "dmd =" <+> ppr dmd
@@ -195,7 +200,7 @@ dmdAnal dflags env dmd (App fun arg)	-- Non-type arguments
 --         , text "arg dmd_ty =" <+> ppr arg_ty
 --         , text "res dmd_ty =" <+> ppr res_ty
 --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
-    (res_ty `bothDmdType` arg_ty, App fun' arg')
+    (res_ty `bothDmdType` arg_ty, App fun'' arg'')
 
 dmdAnal dflags env dmd (Lam var body)
   | isTyVar var
@@ -210,8 +215,7 @@ dmdAnal dflags env dmd (Lam var body)
   = let	
         env'		 = extendSigsWithLam env var
 	(body_ty, body') = dmdAnal dflags env' body_dmd body
-        armed_var        = setOneShotLambda var 
-	(lam_ty, var')   = annotateLamIdBndr dflags env body_ty armed_var
+	(lam_ty, var')   = annotateLamIdBndr dflags env body_ty var
     in
     (lam_ty, Lam var' body')