X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FDemand.lhs;h=0f25717745d5e99a135caf4ae0e88a6da9cb8e35;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=738ea2fb383c4f2e54d0be1989fae036d291f2c3;hpb=fa44695e06cf83d8bcef2c826cb6b39d6ffc49c0;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 738ea2f..0f25717 100644
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -1,17 +1,22 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[Demand]{@Demand@: the amount of demand on a value}
 
 \begin{code}
-#include "HsVersions.h"
+module Demand(
+	Demand(..),
+
+	wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, 
+	isStrict, isLazy, 
 
-module Demand where
+	pprDemands
+     ) where
 
-import PprStyle		( PprStyle )
+#include "HsVersions.h"
+
+import BasicTypes	( NewOrData(..) )
 import Outputable
-import Pretty		( SYN_IE(Pretty), PrettyRep, ppStr )
-import Util		( panic )
 \end{code}
 
 
@@ -33,9 +38,10 @@ data Demand
 			-- (does not imply worker's existence or any
 			-- calling-convention magic)
 
-  | WwUnpack		-- Argument is strict & a single-constructor
+  | WwUnpack		-- Argument is strict & a single-constructor type
+	NewOrData
 	Bool		-- True <=> wrapper unpacks it; False <=> doesn't
-	[Demand]	-- type; its constituent parts (whose StrictInfos
+	[Demand]	-- Its constituent parts (whose StrictInfos
 			-- are in the list) should be passed
 			-- as arguments to the worker.
 
@@ -46,15 +52,15 @@ data Demand
   | WwEnum		-- Argument is strict & an enumeration type;
 			-- an Int# representing the tag (start counting
 			-- at zero) should be passed to the worker.
-  deriving (Eq, Ord)
-      -- we need Eq/Ord to cross-chk update infos in interfaces
+  deriving( Eq )
 
 type MaybeAbsent = Bool -- True <=> not even used
 
 -- versions that don't worry about Absence:
 wwLazy	    = WwLazy 	  False
 wwStrict    = WwStrict
-wwUnpack xs = WwUnpack False xs
+wwUnpackData xs = WwUnpack DataType False xs
+wwUnpackNew  x  = WwUnpack NewType  False [x]
 wwPrim	    = WwPrim
 wwEnum	    = WwEnum
 \end{code}
@@ -68,12 +74,20 @@ wwEnum	    = WwEnum
 
 \begin{code}
 isStrict :: Demand -> Bool
+isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
+isStrict (WwUnpack other _ _)    = True
+isStrict WwStrict = True
+isStrict WwEnum	  = True
+isStrict WwPrim	  = False	-- NB: we treat only lifted types as strict.
+				-- Why is this important?  Mostly it doesn't matter
+				-- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr
+isStrict _	  = False
+\end{code}
 
-isStrict WwStrict	= True
-isStrict (WwUnpack _ _)	= True
-isStrict WwPrim		= True
-isStrict WwEnum		= True
-isStrict _		= False
+\begin{code}
+isLazy :: Demand -> Bool
+isLazy (WwLazy False) = True	-- NB "Absent" args do *not* count!
+isLazy _	      = False	-- (as they imply a worker)
 \end{code}
 
 
@@ -85,47 +99,54 @@ isStrict _		= False
 
 \begin{code}
 #ifdef REALLY_HASKELL_1_3
+
 instance Read Demand where
+    readList str = read_em [] str
+
+instance Show Demand where
+    showsPrec p d = showsPrecSDoc p (ppr d)
+
 #else
+
 instance Text Demand where
+    readList str  = read_em [] str
+    showsPrec p d = showsPrecSDoc p (ppr d)
 #endif
-    readList str = read_em [{-acc-}] str
-      where
-	read_em acc ('L' : xs)	= read_em (WwLazy   False : acc) xs
-	read_em acc ('A' : xs)	= read_em (WwLazy   True  : acc) xs
-	read_em acc ('S' : xs)	= read_em (WwStrict : acc) xs
-	read_em acc ('P' : xs)	= read_em (WwPrim : acc) xs
-	read_em acc ('E' : xs)	= read_em (WwEnum : acc) xs
-
-	read_em acc (')' : xs)	= [(reverse acc, xs)]
-	read_em acc ( 'U'  : '(' : xs) = do_unpack True  acc xs
-	read_em acc ( 'u'  : '(' : xs) = do_unpack False acc xs
-
-	read_em acc rest	= [(reverse acc, rest)]
 
-	do_unpack wrapper_unpacks acc xs
+read_em acc ('L' : xs)	= read_em (WwLazy   False : acc) xs
+read_em acc ('A' : xs)	= read_em (WwLazy   True  : acc) xs
+read_em acc ('S' : xs)	= read_em (WwStrict : acc) xs
+read_em acc ('P' : xs)	= read_em (WwPrim : acc) xs
+read_em acc ('E' : xs)	= read_em (WwEnum : acc) xs
+read_em acc (')' : xs)	= [(reverse acc, xs)]
+read_em acc ( 'U'  : '(' : xs) = do_unpack DataType True  acc xs
+read_em acc ( 'u'  : '(' : xs) = do_unpack DataType False acc xs
+read_em acc ( 'N'  : '(' : xs) = do_unpack NewType  True  acc xs
+read_em acc ( 'n'  : '(' : xs) = do_unpack NewType  False acc xs
+read_em acc rest	= [(reverse acc, rest)]
+
+do_unpack new_or_data wrapper_unpacks acc xs
 	  = case (read_em [] xs) of
-	      [(stuff, rest)] -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest
-	      _ -> panic ("Text.Demand:"++str++"::"++xs)
+	      [(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
+	      _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs))
 
 
-#ifdef REALLY_HASKELL_1_3
-instance Show Demand where
-#endif
-    showList wrap_args rest = foldr show1 rest wrap_args
-      where
-	show1 (WwLazy False)  	 rest = 'L' : rest
-	show1 (WwLazy True)   	 rest = 'A' : rest
-	show1 WwStrict	      	 rest = 'S' : rest
-	show1 WwPrim	      	 rest = 'P' : rest
-	show1 WwEnum	      	 rest = 'E' : rest
-	show1 (WwUnpack wu args) rest = ch ++ "(" ++ showList args (')' : rest)
+pprDemands demands = hcat (map pprDemand demands)
+
+pprDemand (WwLazy False)  	 = char 'L'
+pprDemand (WwLazy True)   	 = char 'A'
+pprDemand WwStrict	      	 = char 'S'
+pprDemand WwPrim	      	 = char 'P'
+pprDemand WwEnum	      	 = char 'E'
+pprDemand (WwUnpack nd wu args)  = char ch <> parens (pprDemands args)
 				      where
-					ch = if wu then "U" else "u"
+					ch = case nd of
+						DataType | wu        -> 'U'
+							 | otherwise -> 'u'
+						NewType  | wu        -> 'N'
+							 | otherwise -> 'n'
 
 instance Outputable Demand where
-    ppr sty si = ppStr (showList [si] "")
+    ppr (WwLazy False) = empty
+    ppr other_demand   = ptext SLIT("__D") <+> pprDemand other_demand
 \end{code}
-
-
-