%
-% (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}
-- (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.
| 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}
\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}
\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}
-
-
-
projects / ghc-hetmet.git / blobdiff