From: simonpj <unknown>
Date: Tue, 24 Jul 2001 16:42:11 +0000 (+0000)
Subject: [project @ 2001-07-24 16:42:11 by simonpj]
X-Git-Tag: Approximately_9120_patches~1423
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7c03fd3bee98604426f7d879f53878d40f08d1a5;p=ghc-hetmet.git

[project @ 2001-07-24 16:42:11 by simonpj]
A major demand-analyser fix, which made it say something was
absent when it wasn't at all.  Here's the comment from the
Case equation of dmdAnal.

	-- Figure out whether the case binder is used, and use
	-- that to set the keepity of the demand.  This is utterly essential.
	-- Consider	f x = case x of y { (a,b) -> k y a }
	-- If we just take scrut_demand = U(L,A), then we won't pass x to the
	-- worker, so the worker will rebuild
	--	x = (a, absent-error)
	-- and that'll crash.
---

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index 0dcb69a..291cf07 100644
--- a/ghc/compiler/basicTypes/NewDemand.lhs
+++ b/ghc/compiler/basicTypes/NewDemand.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module NewDemand(
 	Demand(..), Keepity(..), Deferredness(..), 
-	topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd,
+	topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, isAbsentDmd,
 
 	DmdType(..), topDmdType, mkDmdType, mkTopDmdType, 
 		dmdTypeDepth, dmdTypeRes,
@@ -212,6 +212,12 @@ isStrictDmd Eval	  = True
 isStrictDmd (Call _)	  = True
 isStrictDmd other	  = False
 
+isAbsentDmd :: Demand -> Bool
+isAbsentDmd Bot	  = True
+isAbsentDmd Err	  = True
+isAbsentDmd Abs	  = True
+isAbsentDmd other = False
+
 instance Outputable Demand where
     ppr Lazy 	     = char 'L'
     ppr Abs	     = char 'A'
diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 4d4861f..d6bdd0e 100644
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -173,12 +173,24 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
     isProductTyCon tycon,
     not (isRecursiveTyCon tycon)
   = let
-	bndr_ids		= filter isId bndrs
-	(alt_ty, alt')		= dmdAnalAlt sigs dmd alt
-	(alt_ty1, case_bndr')   = annotateBndr alt_ty case_bndr
-	(_, bndrs', _)		= alt'
-        scrut_dmd 		= Seq Drop Now [idNewDemandInfo b | b <- bndrs', isId b]
-	(scrut_ty, scrut')      = dmdAnal sigs scrut_dmd scrut
+	bndr_ids		 = filter isId bndrs
+	(alt_ty, alt')		 = dmdAnalAlt sigs dmd alt
+	(alt_ty1, case_bndr')    = annotateBndr alt_ty case_bndr
+	(_, bndrs', _)		 = alt'
+
+	-- Figure out whether the case binder is used, and use
+	-- that to set the keepity of the demand.  This is utterly essential.
+	-- Consider	f x = case x of y { (a,b) -> k y a }
+	-- If we just take scrut_demand = U(L,A), then we won't pass x to the
+	-- worker, so the worker will rebuild 
+	--	x = (a, absent-error)
+	-- and that'll crash.
+	dead_case_bndr		 = isAbsentDmd (idNewDemandInfo case_bndr')
+	keepity | dead_case_bndr = Drop
+		| otherwise	 = Keep		
+
+        scrut_dmd 		 = Seq keepity Now [idNewDemandInfo b | b <- bndrs', isId b]
+	(scrut_ty, scrut')       = dmdAnal sigs scrut_dmd scrut
     in
     (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])