X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FNewDemand.lhs;h=668a35e9c20a639669fa5fff02acb5ad4a6fcf6a;hp=8e68fd87d23cd00495ee25ff460358cd903a8031;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs
index 8e68fd8..668a35e 100644
--- a/compiler/basicTypes/NewDemand.lhs
+++ b/compiler/basicTypes/NewDemand.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[Demand]{@Demand@: the amount of demand on a value}
@@ -24,11 +25,11 @@ module NewDemand(
 
 #include "HsVersions.h"
 
-import StaticFlags	( opt_CprOff )
-import BasicTypes	( Arity )
-import VarEnv		( VarEnv, emptyVarEnv, isEmptyVarEnv )
-import UniqFM		( ufmToList )
-import Util             ( listLengthCmp, zipWithEqual )
+import StaticFlags
+import BasicTypes
+import VarEnv
+import UniqFM
+import Util
 import Outputable
 \end{code}
 
@@ -61,14 +62,17 @@ data Demands = Poly Demand	-- Polymorphic case
 	     | Prod [Demand]	-- Product case
 	     deriving( Eq )
 
+allTop :: Demands -> Bool
 allTop (Poly d)  = isTop d
 allTop (Prod ds) = all isTop ds
 
+isTop :: Demand -> Bool
 isTop Top = True
-isTop d   = False 
+isTop _   = False 
 
+isAbsent :: Demand -> Bool
 isAbsent Abs = True
-isAbsent d   = False 
+isAbsent _   = False 
 
 mapDmds :: (Demand -> Demand) -> Demands -> Demands
 mapDmds f (Poly d)  = Poly (f d)
@@ -79,9 +83,15 @@ zipWithDmds :: (Demand -> Demand -> Demand)
 zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
 zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
 zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
-zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
-
-topDmd, lazyDmd, seqDmd :: Demand
+zipWithDmds f (Prod ds1) (Prod ds2) 
+  | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
+  | otherwise		     = Poly topDmd
+	-- This really can happen with polymorphism
+	-- \f. case f x of (a,b) -> ...
+	--     case f y of (a,b,c) -> ...
+	-- Here the two demands on f are C(LL) and C(LLL)!
+
+topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
 topDmd  = Top			-- The most uninformative demand
 lazyDmd = Box Abs
 seqDmd  = Eval (Poly Abs)	-- Polymorphic seq demand
@@ -93,7 +103,7 @@ isStrictDmd Bot      = True
 isStrictDmd (Eval _) = True
 isStrictDmd (Call _) = True
 isStrictDmd (Box d)  = isStrictDmd d
-isStrictDmd other    = False
+isStrictDmd _        = False
 
 seqDemand :: Demand -> ()
 seqDemand (Call d)   = seqDemand d
@@ -121,6 +131,7 @@ instance Outputable Demand where
     ppr (Box (Eval ds)) = char 'S' <> ppr ds
     ppr (Box Abs)	= char 'L'
     ppr (Box Bot)	= char 'X'
+    ppr d@(Box _)	= pprPanic "ppr: Bad boxed demand" (ppr d)
 
     ppr (Call d)	= char 'C' <> parens (ppr d)
 
@@ -166,10 +177,12 @@ data DmdType = DmdType
 -- by making sure that everything uses TopRes instead of RetCPR
 -- Assuming, of course, that they don't mention RetCPR by name.
 -- They should onlyu use retCPR
+retCPR :: DmdResult
 retCPR | opt_CprOff = TopRes
        | otherwise  = RetCPR
 
-seqDmdType (DmdType env ds res) = 
+seqDmdType :: DmdType -> ()
+seqDmdType (DmdType _env ds res) = 
   {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
 
 type DmdEnv = VarEnv Demand
@@ -203,8 +216,10 @@ instance Outputable DmdResult where
   ppr BotRes = char 'b'   --    dddr
 			  -- without ambiguity
 
+emptyDmdEnv :: VarEnv Demand
 emptyDmdEnv = emptyVarEnv
 
+topDmdType, botDmdType, cprDmdType :: DmdType
 topDmdType = DmdType emptyDmdEnv [] TopRes
 botDmdType = DmdType emptyDmdEnv [] BotRes
 cprDmdType = DmdType emptyVarEnv [] retCPR
@@ -212,11 +227,11 @@ cprDmdType = DmdType emptyVarEnv [] retCPR
 isTopDmdType :: DmdType -> Bool
 -- Only used on top-level types, hence the assert
 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True	
-isTopDmdType other		     = False
+isTopDmdType _                       = False
 
 isBotRes :: DmdResult -> Bool
 isBotRes BotRes = True
-isBotRes other  = False
+isBotRes _      = False
 
 resTypeArgDmd :: DmdResult -> Demand
 -- TopRes and BotRes are polymorphic, so that
@@ -232,7 +247,7 @@ resTypeArgDmd BotRes = Bot
 
 returnsCPR :: DmdResult -> Bool
 returnsCPR RetCPR = True
-returnsCPR other  = False
+returnsCPR _      = False
 
 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
 mkDmdType fv ds res = DmdType fv ds res
@@ -292,6 +307,7 @@ mkStrictSig dmd_ty = StrictSig dmd_ty
 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 
+isTopSig :: StrictSig -> Bool
 isTopSig (StrictSig ty) = isTopDmdType ty
 
 topSig, botSig, cprSig :: StrictSig
@@ -301,12 +317,15 @@ cprSig = StrictSig cprDmdType
 	
 
 -- appIsBottom returns true if an application to n args would diverge
+appIsBottom :: StrictSig -> Int -> Bool
 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 appIsBottom _				      _ = False
 
+isBottomingSig :: StrictSig -> Bool
 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 isBottomingSig _				= False
 
+seqStrictSig :: StrictSig -> ()
 seqStrictSig (StrictSig ty) = seqDmdType ty
 
 pprIfaceStrictSig :: StrictSig -> SDoc