From ba4b4b51476e2bbeb0de04f3c8f2a70e36a020f4 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 24 Jul 2001 09:55:16 +0000
Subject: [PATCH] [project @ 2001-07-24 09:55:16 by simonpj] Two fixes to the
 demand analyis.

1.  Don't look inside Coerces.  These wrap recursive newtypes,
and we might fail to find a fixpoint if we look inside them.

2.  Polymorphic 'seq' is represented by a (Seq _ _ []) demand,
so lub/both must be prepared to take a Seq with an empty list
of demands without complaint.
---
 ghc/compiler/stranal/DmdAnal.lhs |   34 ++++++++++++++++++++++++----------
 1 file changed, 24 insertions(+), 10 deletions(-)

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 818271a..4d4861f 100644
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -126,7 +126,13 @@ dmdAnal sigs dmd (Var var)
 dmdAnal sigs dmd (Note n e)
   = (dmd_ty, Note n e')
   where
-    (dmd_ty, e') = dmdAnal sigs dmd e	
+    (dmd_ty, e') = dmdAnal sigs dmd' e	
+    dmd' = case n of
+	     Coerce _ _ -> Eval	  -- This coerce usually arises from a recursive
+	     other	-> dmd 	  -- newtype, and we don't want to look inside them
+				  -- for exactly the same reason that we don't look
+				  -- inside recursive products -- we might not reach
+				  -- a fixpoint.  So revert to a vanilla Eval demand
 
 dmdAnal sigs dmd (App fun (Type ty))
   = (fun_ty, App fun' (Type ty))
@@ -609,13 +615,17 @@ lub Eval d    	        = Eval
 
 lub (Call d1) (Call d2) = Call (lub d1 d2)
 
-lub (Seq k1 l1 ds1) (Seq k2 l2 ds2) = Seq (k1 `vee` k2) (l1 `or_defer` l2)
-				          (zipWithEqual "lub" lub ds1 ds2)
+lub (Seq k1 l1 ds1) (Seq k2 l2 ds2) = Seq (k1 `vee` k2) (l1 `or_defer` l2) (lubs ds1 ds2)
 
 -- The last clauses deal with the remaining cases for Call and Seq
 lub d1@(Call _) d2@(Seq _ _ _) = pprPanic "lub" (ppr d1 $$ ppr d2)
 lub d1 d2		       = lub d2 d1
 
+-- A Seq can have an empty list of demands, in the polymorphic case.
+lubs [] ds2 = ds2
+lubs ds1 [] = ds1
+lubs ds1 ds2 = ASSERT( length ds1 == length ds2 ) zipWith lub ds1 ds2
+
 or_defer Now Now = Now
 or_defer _   _   = Defer
 
@@ -674,13 +684,11 @@ both Eval (Seq k l ds) = Seq Keep Now ds
 both Eval (Call d)     = Call d
 both Eval d   	       = Eval
 
-both (Seq k1 Defer ds1) (Seq k2 Defer ds2) = Seq (k1 `vee` k2) Defer
-					         (zipWithEqual "both" both ds1 ds2)
-both (Seq k1 l1 ds1) (Seq k2 l2 ds2) = Seq (k1 `vee` k2) Now
-					   (zipWithEqual "both" both ds1' ds2')
-				     where
-					ds1' = case l1 of { Now -> ds1; Defer -> map defer ds1 }
-					ds2' = case l2 of { Now -> ds2; Defer -> map defer ds2 }
+both (Seq k1 Defer ds1) (Seq k2 Defer ds2) = Seq (k1 `vee` k2) Defer (boths ds1  ds2)
+both (Seq k1 l1 ds1)    (Seq k2 l2 ds2)    = Seq (k1 `vee` k2) Now   (boths ds1' ds2')
+					   where
+					     ds1' = case l1 of { Now -> ds1; Defer -> map defer ds1 }
+					     ds2' = case l2 of { Now -> ds2; Defer -> map defer ds2 }
 
 both (Call d1) (Call d2) = Call (d1 `both` d2)
 
@@ -689,6 +697,12 @@ both d1@(Call _) d2@(Seq _ _ _) = pprPanic "both" (ppr d1 $$ ppr d2)
 both d1 d2		        = both d2 d1
 
 -----------------------------------
+-- A Seq can have an empty list of demands, in the polymorphic case.
+boths [] ds2  = ds2
+boths ds1 []  = ds1
+boths ds1 ds2 = ASSERT( length ds1 == length ds2 ) zipWith both ds1 ds2
+
+-----------------------------------
 bothRes :: DmdResult -> DmdResult -> DmdResult
 -- Left-biased for CPR info
 bothRes BotRes _ = BotRes
-- 
1.7.10.4