X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FNewDemand.lhs;h=ea314d58ae4aefb6caa3e37190079a21560d418a;hb=cbc282b70e6c23df738cb11cc35652623c9aed00;hp=2c83d957df1f40ae8470ec308d4a4224625f8c84;hpb=a1b59a18845ddaa5e752c9fbc0ad8b947642b50d;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs
index 2c83d95..ea314d5 100644
--- a/ghc/compiler/basicTypes/NewDemand.lhs
+++ b/ghc/compiler/basicTypes/NewDemand.lhs
@@ -5,30 +5,138 @@
 
 \begin{code}
 module NewDemand(
-	Demand(..), Keepity(..), 
-	mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, defer,
+	Demand(..), 
+	topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, 
+	isTop, isAbsent, seqDemand,
 
 	DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, 
-		dmdTypeDepth, dmdTypeRes,
+		dmdTypeDepth, dmdTypeRes, seqDmdType,
 	DmdEnv, emptyDmdEnv,
-	DmdResult(..), isBotRes, returnsCPR,
+	DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
+	
+	Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
 
 	StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
 	splitStrictSig, strictSigResInfo,
-	pprIfaceStrictSig, appIsBottom, isBottomingSig
+	pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
      ) where
 
 #include "HsVersions.h"
 
 import BasicTypes	( Arity )
-import VarEnv		( VarEnv, emptyVarEnv )
+import VarEnv		( VarEnv, emptyVarEnv, isEmptyVarEnv )
 import UniqFM		( ufmToList )
+import Util             ( listLengthCmp, zipWithEqual )
 import Outputable
 \end{code}
 
 
 %************************************************************************
 %*									*
+\subsection{Demands}
+%*									*
+%************************************************************************
+
+\begin{code}
+data Demand
+  = Top			-- T; used for unlifted types too, so that
+			--	A `lub` T = T
+  | Abs			-- A
+
+  | Call Demand		-- C(d)
+
+  | Eval Demands	-- U(ds)
+
+  | Defer Demands	-- D(ds)
+
+  | Box Demand		-- B(d)
+
+  | Bot			-- B
+  deriving( Eq )
+	-- Equality needed for fixpoints in DmdAnal
+
+data Demands = Poly Demand	-- Polymorphic case
+	     | Prod [Demand]	-- Product case
+	     deriving( Eq )
+
+allTop (Poly d)  = isTop d
+allTop (Prod ds) = all isTop ds
+
+isTop Top = True
+isTop d   = False 
+
+isAbsent Abs = True
+isAbsent d   = False 
+
+mapDmds :: (Demand -> Demand) -> Demands -> Demands
+mapDmds f (Poly d)  = Poly (f d)
+mapDmds f (Prod ds) = Prod (map f ds)
+
+zipWithDmds :: (Demand -> Demand -> Demand)
+	    -> Demands -> Demands -> Demands
+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
+topDmd  = Top			-- The most uninformative demand
+lazyDmd = Box Abs
+seqDmd  = Eval (Poly Abs)	-- Polymorphic seq demand
+evalDmd = Box seqDmd		-- Evaluate and return
+errDmd  = Box Bot		-- This used to be called X
+
+isStrictDmd :: Demand -> Bool
+isStrictDmd Bot      = True
+isStrictDmd (Eval _) = True
+isStrictDmd (Call _) = True
+isStrictDmd (Box d)  = isStrictDmd d
+isStrictDmd other    = False
+
+seqDemand :: Demand -> ()
+seqDemand (Call d)   = seqDemand d
+seqDemand (Eval ds)  = seqDemands ds
+seqDemand (Defer ds) = seqDemands ds
+seqDemand (Box d)    = seqDemand d
+seqDemand _          = ()
+
+seqDemands :: Demands -> ()
+seqDemands (Poly d)  = seqDemand d
+seqDemands (Prod ds) = seqDemandList ds
+
+seqDemandList :: [Demand] -> ()
+seqDemandList [] = ()
+seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
+
+instance Outputable Demand where
+    ppr Top  = char 'T'
+    ppr Abs  = char 'A'
+    ppr Bot  = char 'B'
+
+    ppr (Defer ds)      = char 'D' <> ppr ds
+    ppr (Eval ds)       = char 'U' <> ppr ds
+				      
+    ppr (Box (Eval ds)) = char 'S' <> ppr ds
+    ppr (Box Abs)	= char 'L'
+    ppr (Box Bot)	= char 'X'
+
+    ppr (Call d)	= char 'C' <> parens (ppr d)
+
+
+instance Outputable Demands where
+    ppr (Poly Abs) = empty
+    ppr (Poly d)   = parens (ppr d <> char '*')
+    ppr (Prod ds)  = parens (hcat (map ppr ds))
+	-- At one time I printed U(AAA) as U, but that
+	-- confuses (Poly Abs) with (Prod AAA), and the
+	-- worker/wrapper generation differs slightly for these two
+	-- [Reason: in the latter case we can avoid passing the arg;
+	--  see notes with WwLib.mkWWstr_one.]
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Demand types}
 %*									*
 %************************************************************************
@@ -45,6 +153,15 @@ data DmdType = DmdType
 	-- DmdResult = BotRes        <=>  Bot
 	-- DmdResult = TopRes/ResCPR <=>  Abs
 
+	-- 		ANOTHER IMPORTANT INVARIANT
+	-- The Demands in the argument list are never
+	--	Bot, Defer d
+	-- Handwavey reason: these don't correspond to calling conventions
+	-- See DmdAnal.funArgDemand for details
+
+seqDmdType (DmdType env ds res) = 
+  {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
+
 type DmdEnv = VarEnv Demand
 
 data DmdResult = TopRes	-- Nothing known	
@@ -82,13 +199,22 @@ botDmdType = DmdType emptyDmdEnv [] BotRes
 
 isTopDmdType :: DmdType -> Bool
 -- Only used on top-level types, hence the assert
-isTopDmdType (DmdType _ [] TopRes) = ASSERT( isEmptyVarEnv env) True	
-isTopDmdType other		   = False
+isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True	
+isTopDmdType other		     = False
 
 isBotRes :: DmdResult -> Bool
 isBotRes BotRes = True
 isBotRes other  = False
 
+resTypeArgDmd :: DmdResult -> Demand
+-- TopRes and BotRes are polymorphic, so that
+--	BotRes = Bot -> BotRes
+--	TopRes = Top -> TopRes
+-- This function makes that concrete
+resTypeArgDmd TopRes = Top
+resTypeArgDmd BotRes = Bot
+resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
+
 returnsCPR :: DmdResult -> Bool
 returnsCPR RetCPR = True
 returnsCPR other  = False
@@ -163,12 +289,14 @@ topSig = StrictSig topDmdType
 botSig = StrictSig botDmdType
 
 -- appIsBottom returns true if an application to n args would diverge
-appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
+appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
 appIsBottom _				      _ = False
 
 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
 isBottomingSig _				= False
 
+seqStrictSig (StrictSig ty) = seqDmdType ty
+
 pprIfaceStrictSig :: StrictSig -> SDoc
 -- Used for printing top-level strictness pragmas in interface files
 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
@@ -176,81 +304,3 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
 \end{code}
     
 
-%************************************************************************
-%*									*
-\subsection{Demands}
-%*									*
-%************************************************************************
-
-\begin{code}
-data Demand
-  = Lazy		-- L; used for unlifted types too, so that
-			--	A `lub` L = L
-  | Abs			-- A
-
-  | Call Demand		-- C(d)
-  | Eval 		-- V
-  | Seq Keepity		-- S/U/D(ds)
-	[Demand]	-- 	S(ds) = L `both` U(ds)
-			-- 	D(ds) = A `lub`  U(ds)
-			-- *** Invariant: these demands are never Bot or Abs
-			-- *** Invariant: if all demands are Abs, get []
-
-  | Err			-- X
-  | Bot			-- B
-  deriving( Eq )
-	-- Equality needed for fixpoints in DmdAnal
-
-data Keepity = Keep | Drop | Defer
-	     deriving( Eq )
-
-mkSeq :: Keepity -> [Demand] -> Demand
-mkSeq k ds | all is_absent ds = Seq k []
-	   | otherwise	      = Seq k ds
-	   where
- 	     is_absent Abs = True
-	     is_absent d   = False
-
-defer :: Demand -> Demand
--- Computes (Abs `lub` d)
--- For the Bot case consider
---	f x y = if ... then x else error x
---   Then for y we get Abs `lub` Bot, and we really
---   want Abs overall
-defer Bot	    = Abs
-defer Abs	    = Abs
-defer (Seq Keep ds) = Lazy
-defer (Seq _    ds) = Seq Defer ds
-defer d	   	    = Lazy
-
-topDmd, lazyDmd, seqDmd :: Demand
-topDmd  = Lazy		-- The most uninformative demand
-lazyDmd = Lazy
-seqDmd  = Seq Keep []	-- Polymorphic seq demand
-evalDmd = Eval
-
-isStrictDmd :: Demand -> Bool
-isStrictDmd Bot       	 = True
-isStrictDmd Err	      	 = True    	   
-isStrictDmd (Seq Drop _) = True	-- But not Defer!
-isStrictDmd (Seq Keep _) = True
-isStrictDmd Eval      	 = True
-isStrictDmd (Call _)  	 = True
-isStrictDmd other     	 = False
-
-instance Outputable Demand where
-    ppr Lazy 	   = char 'L'
-    ppr Abs	   = char 'A'
-    ppr Eval       = char 'V'
-    ppr Err        = char 'X'
-    ppr Bot        = char 'B'
-    ppr (Call d)   = char 'C' <> parens (ppr d)
-    ppr (Seq k []) = ppr k
-    ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
-
-instance Outputable Keepity where
-  ppr Keep  = char 'S'
-  ppr Drop  = char 'U'
-  ppr Defer = char 'D'
-\end{code}
-