From: simonpj <unknown>
Date: Tue, 6 Nov 2001 14:19:24 +0000 (+0000)
Subject: [project @ 2001-11-06 14:19:24 by simonpj]
X-Git-Tag: Approximately_9120_patches~630
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=52b6297710cf4ff561585541a88a1d8e437614c2;p=ghc-hetmet.git

[project @ 2001-11-06 14:19:24 by simonpj]
---------------------------------------
	Fix YET ANOTHER lub/both bug in DmdAnal
	---------------------------------------

	MERGE TO 5.02 branch (it's a real bug)

Two bugs actually.  One showed up in a program by
Jeremy Manson, and led to an "entered absent arg"
error.  The problem was

	Err `lub` U(L,A)  /=  U(L,A)

which is what we had.  It should be

	Err `lub` U(L,A) = U(Err `lub` L, Err `lub` A)
			 = U(LL)

The second bug was found by Peter Sestoft while
staring at the code.

	V `lub` Defer(ds) /= U(L)

It should be Lazy on the RHS.

Very large sigh.
---

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 714d8ed..8648cb6 100644
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -255,7 +255,13 @@ dmdAnal sigs dmd (Let (NonRec id rhs) body)
 	(body_ty1, id2)    	      = annotateBndr body_ty id1
 	body_ty2		      = addLazyFVs body_ty1 lazy_fv
     in
---    pprTrace "dmdLet" (ppr id <+> ppr (sig,rhs_env))
+    (let vanilla_dmd = vanillaCall (idArity id)
+	 actual_dmd  = idNewDemandInfo id2
+     in
+     if not (vanilla_dmd `betterDemand` actual_dmd) then
+	pprTrace "dmdLet: better demand" (ppr id <+> vcat [text "vanilla" <+> ppr vanilla_dmd,
+							   text "actual" <+> ppr actual_dmd])
+     else \x -> x)
     (body_ty2, Let (NonRec id2 rhs') body')    
 
 dmdAnal sigs dmd (Let (Rec pairs) body) 
@@ -870,9 +876,16 @@ lub :: Demand -> Demand -> Demand
 
 lub Bot d = d
 
-lub Err Bot = Err 
-lub Err Abs = Lazy	-- E.g. f x = if ... then True else error x
-lub Err d   = d 
+lub Err Bot        = Err 
+lub Err Abs        = Lazy	-- E.g. f x = if ... then True else error x
+lub Err (Seq k ds) 
+  | null ds	   = Seq (case k of { Drop -> Keep; other -> k }) []
+			-- Yuk
+  | not (null ds)  = Seq k [Err `lub` d | d <- ds]
+			-- E.g. f x = if ... then fst x else error x
+			-- We *cannot* use the (lub Err d = d) case,
+			-- else we'd get U(VA) for x's demand!!
+lub Err d   	   = d 
 
 lub Lazy d = Lazy
 
@@ -880,9 +893,10 @@ lub Abs  d = defer d
 
 lub Eval Abs		   	       = Lazy
 lub Eval Lazy		   	       = Lazy
+lub Eval (Seq Defer ds)		       = Lazy	-- Essential!
 lub Eval (Seq Drop ds) | not (null ds) = Seq Drop [Lazy | d <- ds]
 lub Eval d   		   	       = Eval
-	-- For the Seq case, consier
+	-- For the Seq Drop case, consider
 	--	f n []     = n
 	--	f n (x:xs) = f (n+x) xs
 	-- Here we want to do better than just V for n.  It's
@@ -935,9 +949,15 @@ defer d	   	    = Lazy
 ---------------
 both :: Demand -> Demand -> Demand
 
-both Bot Bot = Bot
-both Bot Abs = Bot
-both Bot d   = Err
+both Bot Bot 	    = Bot
+both Bot Abs	    = Bot
+both Bot (Seq k ds) 
+  | not (null ds)   = Seq (case k of { Defer -> Drop; other -> k })
+			  [both Bot d | d <- ds]
+	-- E.g. f x = if ... then error (fst x) else fst x
+	-- This equation helps results slightly, 
+	-- but is not necessary for soundness
+both Bot d   	    = Err
 
 both Err d = Err