2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Demand]{@Demand@: the amount of demand on a value}
9 topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
10 isTop, isAbsent, seqDemand,
12 DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
13 dmdTypeDepth, seqDmdType,
15 DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
17 Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
19 StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
22 pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
25 #include "HsVersions.h"
27 import CmdLineOpts ( opt_CprOff )
28 import BasicTypes ( Arity )
29 import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
30 import UniqFM ( ufmToList )
31 import Util ( listLengthCmp, zipWithEqual )
36 %************************************************************************
40 %************************************************************************
44 = Top -- T; used for unlifted types too, so that
50 | Eval Demands -- U(ds)
52 | Defer Demands -- D(ds)
58 -- Equality needed for fixpoints in DmdAnal
60 data Demands = Poly Demand -- Polymorphic case
61 | Prod [Demand] -- Product case
64 allTop (Poly d) = isTop d
65 allTop (Prod ds) = all isTop ds
73 mapDmds :: (Demand -> Demand) -> Demands -> Demands
74 mapDmds f (Poly d) = Poly (f d)
75 mapDmds f (Prod ds) = Prod (map f ds)
77 zipWithDmds :: (Demand -> Demand -> Demand)
78 -> Demands -> Demands -> Demands
79 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
80 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
81 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
82 zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
84 topDmd, lazyDmd, seqDmd :: Demand
85 topDmd = Top -- The most uninformative demand
87 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
88 evalDmd = Box seqDmd -- Evaluate and return
89 errDmd = Box Bot -- This used to be called X
91 isStrictDmd :: Demand -> Bool
92 isStrictDmd Bot = True
93 isStrictDmd (Eval _) = True
94 isStrictDmd (Call _) = True
95 isStrictDmd (Box d) = isStrictDmd d
96 isStrictDmd other = False
98 seqDemand :: Demand -> ()
99 seqDemand (Call d) = seqDemand d
100 seqDemand (Eval ds) = seqDemands ds
101 seqDemand (Defer ds) = seqDemands ds
102 seqDemand (Box d) = seqDemand d
105 seqDemands :: Demands -> ()
106 seqDemands (Poly d) = seqDemand d
107 seqDemands (Prod ds) = seqDemandList ds
109 seqDemandList :: [Demand] -> ()
110 seqDemandList [] = ()
111 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
113 instance Outputable Demand where
118 ppr (Defer ds) = char 'D' <> ppr ds
119 ppr (Eval ds) = char 'U' <> ppr ds
121 ppr (Box (Eval ds)) = char 'S' <> ppr ds
122 ppr (Box Abs) = char 'L'
123 ppr (Box Bot) = char 'X'
125 ppr (Call d) = char 'C' <> parens (ppr d)
128 instance Outputable Demands where
129 ppr (Poly Abs) = empty
130 ppr (Poly d) = parens (ppr d <> char '*')
131 ppr (Prod ds) = parens (hcat (map ppr ds))
132 -- At one time I printed U(AAA) as U, but that
133 -- confuses (Poly Abs) with (Prod AAA), and the
134 -- worker/wrapper generation differs slightly for these two
135 -- [Reason: in the latter case we can avoid passing the arg;
136 -- see notes with WwLib.mkWWstr_one.]
140 %************************************************************************
142 \subsection{Demand types}
144 %************************************************************************
147 data DmdType = DmdType
148 DmdEnv -- Demand on explicitly-mentioned
150 [Demand] -- Demand on arguments
151 DmdResult -- Nature of result
153 -- IMPORTANT INVARIANT
154 -- The default demand on free variables not in the DmdEnv is:
155 -- DmdResult = BotRes <=> Bot
156 -- DmdResult = TopRes/ResCPR <=> Abs
158 -- ANOTHER IMPORTANT INVARIANT
159 -- The Demands in the argument list are never
161 -- Handwavey reason: these don't correspond to calling conventions
162 -- See DmdAnal.funArgDemand for details
165 -- This guy lets us switch off CPR analysis
166 -- by making sure that everything uses TopRes instead of RetCPR
167 -- Assuming, of course, that they don't mention RetCPR by name.
168 -- They should onlyu use retCPR
169 retCPR | opt_CprOff = TopRes
172 seqDmdType (DmdType env ds res) =
173 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
175 type DmdEnv = VarEnv Demand
177 data DmdResult = TopRes -- Nothing known
178 | RetCPR -- Returns a constructed product
179 | BotRes -- Diverges or errors
181 -- Equality for fixpoints
182 -- Show needed for Show in Lex.Token (sigh)
184 -- Equality needed for fixpoints in DmdAnal
185 instance Eq DmdType where
186 (==) (DmdType fv1 ds1 res1)
187 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
188 && ds1 == ds2 && res1 == res2
190 instance Outputable DmdType where
191 ppr (DmdType fv ds res)
192 = hsep [text "DmdType",
193 hcat (map ppr ds) <> ppr res,
194 if null fv_elts then empty
195 else braces (fsep (map pp_elt fv_elts))]
197 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
198 fv_elts = ufmToList fv
200 instance Outputable DmdResult where
201 ppr TopRes = empty -- Keep these distinct from Demand letters
202 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
203 ppr BotRes = char 'b' -- dddr
206 emptyDmdEnv = emptyVarEnv
208 topDmdType = DmdType emptyDmdEnv [] TopRes
209 botDmdType = DmdType emptyDmdEnv [] BotRes
210 cprDmdType = DmdType emptyVarEnv [] retCPR
212 isTopDmdType :: DmdType -> Bool
213 -- Only used on top-level types, hence the assert
214 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
215 isTopDmdType other = False
217 isBotRes :: DmdResult -> Bool
218 isBotRes BotRes = True
219 isBotRes other = False
221 resTypeArgDmd :: DmdResult -> Demand
222 -- TopRes and BotRes are polymorphic, so that
223 -- BotRes = Bot -> BotRes
224 -- TopRes = Top -> TopRes
225 -- This function makes that concrete
226 -- We can get a RetCPR, because of the way in which we are (now)
227 -- giving CPR info to strict arguments. On the first pass, when
228 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
229 resTypeArgDmd TopRes = Top
230 resTypeArgDmd RetCPR = Top
231 resTypeArgDmd BotRes = Bot
233 returnsCPR :: DmdResult -> Bool
234 returnsCPR RetCPR = True
235 returnsCPR other = False
237 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
238 mkDmdType fv ds res = DmdType fv ds res
240 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
241 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
243 dmdTypeDepth :: DmdType -> Arity
244 dmdTypeDepth (DmdType _ ds _) = length ds
248 %************************************************************************
250 \subsection{Strictness signature
252 %************************************************************************
254 In a let-bound Id we record its strictness info.
255 In principle, this strictness info is a demand transformer, mapping
256 a demand on the Id into a DmdType, which gives
257 a) the free vars of the Id's value
258 b) the Id's arguments
259 c) an indication of the result of applying
260 the Id to its arguments
262 However, in fact we store in the Id an extremely emascuated demand transfomer,
265 (Nevertheless we dignify StrictSig as a distinct type.)
267 This DmdType gives the demands unleashed by the Id when it is applied
268 to as many arguments as are given in by the arg demands in the DmdType.
270 For example, the demand transformer described by the DmdType
271 DmdType {x -> U(LL)} [V,A] Top
272 says that when the function is applied to two arguments, it
273 unleashes demand U(LL) on the free var x, V on the first arg,
276 If this same function is applied to one arg, all we can say is
277 that it uses x with U*(LL), and its arg with demand L.
280 newtype StrictSig = StrictSig DmdType
283 instance Outputable StrictSig where
284 ppr (StrictSig ty) = ppr ty
286 instance Show StrictSig where
287 show (StrictSig ty) = showSDoc (ppr ty)
289 mkStrictSig :: DmdType -> StrictSig
290 mkStrictSig dmd_ty = StrictSig dmd_ty
292 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
293 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
295 isTopSig (StrictSig ty) = isTopDmdType ty
297 topSig, botSig, cprSig :: StrictSig
298 topSig = StrictSig topDmdType
299 botSig = StrictSig botDmdType
300 cprSig = StrictSig cprDmdType
303 -- appIsBottom returns true if an application to n args would diverge
304 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
305 appIsBottom _ _ = False
307 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
308 isBottomingSig _ = False
310 seqStrictSig (StrictSig ty) = seqDmdType ty
312 pprIfaceStrictSig :: StrictSig -> SDoc
313 -- Used for printing top-level strictness pragmas in interface files
314 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
315 = hcat (map ppr dmds) <> ppr res