X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FDemand.lhs;h=8e8f24ff3ef586aa8fbe42f2bfd59806b194103b;hb=b749b2c7fd7fb9cdd464c213672ded760f498dc9;hp=56eaebf835d1b4243c96ffb73c0a34a15333380a;hpb=e2d1686f58cbc92d8656f30bd0bee45b94b71c3e;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 56eaebf..8e8f24f 100644
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -1,24 +1,29 @@
 %
-% (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,
+	wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, 
+	isStrict, isLazy, isPrim,
+
+	pprDemands, seqDemand, seqDemands,
+
+	StrictnessInfo(..),	
+	mkStrictnessInfo,
+	noStrictnessInfo,
+	ppStrictnessInfo, seqStrictnessInfo,
+	isBottomingStrictness, appIsBottom,
 
-	showDemands
      ) where
 
-import BasicTypes	( NewOrData(..) )
+#include "HsVersions.h"
+
 import Outputable
-import Pretty		( Doc, text )
-import Util		( panic )
+import Util ( listLengthCmp )
 \end{code}
 
 
@@ -41,7 +46,6 @@ data Demand
 			-- calling-convention magic)
 
   | WwUnpack		-- Argument is strict & a single-constructor type
-	NewOrData
 	Bool		-- True <=> wrapper unpacks it; False <=> doesn't
 	[Demand]	-- Its constituent parts (whose StrictInfos
 			-- are in the list) should be passed
@@ -61,10 +65,17 @@ type MaybeAbsent = Bool -- True <=> not even used
 -- versions that don't worry about Absence:
 wwLazy	    = WwLazy 	  False
 wwStrict    = WwStrict
-wwUnpackData xs = WwUnpack DataType False xs
-wwUnpackNew  x  = WwUnpack NewType  False [x]
+wwUnpack xs = WwUnpack False xs
 wwPrim	    = WwPrim
 wwEnum	    = WwEnum
+
+seqDemand :: Demand -> ()
+seqDemand (WwLazy a)      = a `seq` ()
+seqDemand (WwUnpack b ds) = b `seq` seqDemands ds
+seqDemand other		  = ()
+
+seqDemands [] = ()
+seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
 \end{code}
 
 
@@ -75,14 +86,16 @@ wwEnum	    = WwEnum
 %************************************************************************
 
 \begin{code}
+isLazy :: Demand -> Bool
+isLazy (WwLazy _) = True
+isLazy _	  = False
+
 isStrict :: Demand -> Bool
+isStrict d = not (isLazy d)
 
-isStrict WwStrict	= True
-isStrict (WwUnpack DataType _ _) = True
-isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
-isStrict WwPrim		= True
-isStrict WwEnum		= True
-isStrict _		= False
+isPrim :: Demand -> Bool
+isPrim WwPrim = True
+isPrim other  = False
 \end{code}
 
 
@@ -92,62 +105,100 @@ isStrict _		= False
 %*									*
 %************************************************************************
 
-\begin{code}
-showDemands :: [Demand] -> String
-showDemands wrap_args = show_demands wrap_args ""
 
+\begin{code}
+pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
+		       where
+			 pp_bot | bot       = ptext SLIT("B")
+				| otherwise = empty
+
+
+pprDemand (WwLazy False)  	 = char 'L'
+pprDemand (WwLazy True)   	 = char 'A'
+pprDemand WwStrict	      	 = char 'S'
+pprDemand WwPrim	      	 = char 'P'
+pprDemand WwEnum	      	 = char 'E'
+pprDemand (WwUnpack wu args)     = char ch <> parens (hcat (map pprDemand args))
+				      where
+					ch = if wu then 'U' else 'u'
 
-#ifdef REALLY_HASKELL_1_3
+instance Outputable Demand where
+    ppr (WwLazy False) = empty
+    ppr other_demand   = ptext SLIT("__D") <+> pprDemand other_demand
 
-instance Read Demand where
-    readList str = read_em [] str
 instance Show Demand where
-    showList wrap_args rest = show_demands wrap_args rest
-
-#else
-
-instance Text Demand where
-    readList str = read_em [] str
-    showList wrap_args rest = show_demands wrap_args rest
-
-#endif
-
-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 new_or_data wrapper_unpacks stuff : acc) rest
-	      _ -> panic ("Demand.do_unpack:"++show acc++"::"++xs)
-
-show_demands wrap_args rest
-  = foldr show1 rest wrap_args
+    showsPrec p d = showsPrecSDoc p (ppr d)
+
+-- Reading demands is done in Lex.lhs
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[strictness-IdInfo]{Strictness info about an @Id@}
+%*									*
+%************************************************************************
+
+We specify the strictness of a function by giving information about
+each of the ``wrapper's'' arguments (see the description about
+worker/wrapper-style transformations in the PJ/Launchbury paper on
+unboxed types).
+
+The list of @Demands@ specifies: (a)~the strictness properties of a
+function's arguments; and (b)~the type signature of that worker (if it
+exists); i.e. its calling convention.
+
+Note that the existence of a worker function is now denoted by the Id's
+workerInfo field.
+
+\begin{code}
+data StrictnessInfo
+  = NoStrictnessInfo
+
+  | StrictnessInfo [Demand] 	-- Demands on the arguments.
+
+		   Bool		-- True <=> the function diverges regardless of its arguments
+				-- Useful for "error" and other disguised variants thereof.  
+				-- BUT NB: f = \x y. error "urk"
+				-- 	   will have info  SI [SS] True
+				-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
+  deriving( Eq )
+
+	-- NOTA BENE: if the arg demands are, say, [S,L], this means that
+	-- 	(f bot) is not necy bot, only (f bot x) is bot
+	-- We simply cannot express accurately the strictness of a function
+	-- like		f = \x -> case x of (a,b) -> \y -> ...
+	-- The up-side is that we don't need to restrict the strictness info
+	-- to the visible arity of the function.
+
+seqStrictnessInfo :: StrictnessInfo -> ()
+seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds
+seqStrictnessInfo other		        = ()
+\end{code}
+
+\begin{code}
+mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo
+
+mkStrictnessInfo (xs, is_bot)
+  | all totally_boring xs && not is_bot	= NoStrictnessInfo		-- Uninteresting
+  | otherwise		    	        = StrictnessInfo xs is_bot
   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 nd wu args) rest = ch ++ "(" ++ showList args (')' : rest)
-				      where
-					ch = case nd of
-						DataType | wu        -> "U"
-							 | otherwise -> "u"
-						NewType  | wu        -> "N"
-							 | otherwise -> "n"
+    totally_boring (WwLazy False) = True
+    totally_boring other	  = False
 
-instance Outputable Demand where
-    ppr sty si = text (showList [si] "")
+noStrictnessInfo = NoStrictnessInfo
+
+isBottomingStrictness (StrictnessInfo _ bot) = bot
+isBottomingStrictness NoStrictnessInfo       = False
+
+-- appIsBottom returns true if an application to n args would diverge
+appIsBottom (StrictnessInfo ds bot)   n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'.
+appIsBottom  NoStrictnessInfo	      n	= False
+
+ppStrictnessInfo NoStrictnessInfo		   = empty
+ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
 \end{code}
 
 
 
+