From 71c7067b7cc2b06265c97190e6a09c272ad7a175 Mon Sep 17 00:00:00 2001
From: Simon PJ <simonpj@microsoft.com>
Date: Mon, 3 May 2010 15:16:30 +0000
Subject: [PATCH] Make the demand analyser take account of lambda-bound
 unfoldings

This is a long-standing lurking bug. See Note [Lamba-bound unfoldings]
in DmdAnal.

I'm still not really happy with this lambda-bound-unfolding stuff.
---
 compiler/simplCore/Simplify.lhs |   12 +++++++++++-
 compiler/stranal/DmdAnal.lhs    |   32 ++++++++++++++++++++++++++------
 2 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index eec4521..d2f3d96 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -2082,12 +2082,22 @@ An alternative plan is this:
 but that is bad if 'c' is *not* later scrutinised.  
 
 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
-that it's really I# c#, thus
+(an InlineRule) that it's really I# c#, thus
    
    $j = \c# -> \c[=I# c#] -> ...c....
 
 Absence analysis may later discard 'c'.
 
+NB: take great care when doing strictness analysis; 
+    see Note [Lamba-bound unfoldings] in DmdAnal.
+
+Also note that we can still end up passing stuff that isn't used.  Before
+strictness analysis we have
+   let $j x y c{=(x,y)} = (h c, ...)
+   in ...
+After strictness analysis we see that h is strict, we end up with
+   let $j x y c{=(x,y)} = ($wh x y, ...)
+and c is unused.
    
 Note [Duplicated env]
 ~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 4660aad..e8aa22c 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -32,7 +32,7 @@ import TyCon		( isProductTyCon, isRecursiveTyCon )
 import Id		( Id, idType, idInlineActivation,
 			  isDataConWorkId, isGlobalId, idArity,
 			  idStrictness, idStrictness_maybe,
-			  setIdStrictness, idDemandInfo,
+			  setIdStrictness, idDemandInfo, idUnfolding,
 			  idDemandInfo_maybe,
 			  setIdDemandInfo
 			)
@@ -205,14 +205,14 @@ dmdAnal sigs dmd (Lam var body)
   = let	
 	sigs'		 = extendSigsWithLam sigs var
 	(body_ty, body') = dmdAnal sigs' body_dmd body
-	(lam_ty, var')   = annotateLamIdBndr body_ty var
+	(lam_ty, var')   = annotateLamIdBndr sigs body_ty var
     in
     (lam_ty, Lam var' body')
 
   | otherwise	-- Not enough demand on the lambda; but do the body
   = let		-- anyway to annotate it and gather free var info
 	(body_ty, body') = dmdAnal sigs evalDmd body
-	(lam_ty, var')   = annotateLamIdBndr body_ty var
+	(lam_ty, var')   = annotateLamIdBndr sigs body_ty var
     in
     (deferType lam_ty, Lam var' body')
 
@@ -728,17 +728,27 @@ annotateBndr dmd_ty@(DmdType fv ds res) var
 
 annotateBndrs = mapAccumR annotateBndr
 
-annotateLamIdBndr :: DmdType 	-- Demand type of body
+annotateLamIdBndr :: SigEnv
+                  -> DmdType 	-- Demand type of body
 		  -> Id 	-- Lambda binder
 		  -> (DmdType, 	-- Demand type of lambda
 		      Id)	-- and binder annotated with demand	
 
-annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
+annotateLamIdBndr sigs dmd_ty@(DmdType fv ds res) id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
-    (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd)
+    (final_ty, setIdDemandInfo id hacked_dmd)
   where
+      -- Watch out!  See note [Lambda-bound unfoldings]
+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
+                 Nothing  -> main_ty
+                 Just unf -> main_ty `bothType` unf_ty
+                          where
+                             (unf_ty, _) = dmdAnal sigs dmd unf
+    
+    main_ty = DmdType fv' (hacked_dmd:ds) res
+
     (fv', dmd) = removeFV fv id res
     hacked_dmd = argDemand dmd
 	-- This call to argDemand is vital, because otherwise we label
@@ -764,6 +774,16 @@ zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
 		   | otherwise			= dmd
 \end{code}
 
+Note [Lamba-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}
-- 
1.7.10.4