2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[Demand]{@Demand@: the amount of demand on a value}
10 topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
11 isTop, isAbsent, seqDemand,
13 DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
14 dmdTypeDepth, seqDmdType,
16 DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
18 Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
20 StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
23 pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
26 -- XXX This define is a bit of a hack, and should be done more nicely
27 #define FAST_STRING_NOT_NEEDED 1
28 #include "HsVersions.h"
39 %************************************************************************
43 %************************************************************************
47 = Top -- T; used for unlifted types too, so that
53 | Eval Demands -- U(ds)
55 | Defer Demands -- D(ds)
61 -- Equality needed for fixpoints in DmdAnal
63 data Demands = Poly Demand -- Polymorphic case
64 | Prod [Demand] -- Product case
67 allTop :: Demands -> Bool
68 allTop (Poly d) = isTop d
69 allTop (Prod ds) = all isTop ds
71 isTop :: Demand -> Bool
75 isAbsent :: Demand -> Bool
79 mapDmds :: (Demand -> Demand) -> Demands -> Demands
80 mapDmds f (Poly d) = Poly (f d)
81 mapDmds f (Prod ds) = Prod (map f ds)
83 zipWithDmds :: (Demand -> Demand -> Demand)
84 -> Demands -> Demands -> Demands
85 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
86 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
87 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
88 zipWithDmds f (Prod ds1) (Prod ds2)
89 | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
90 | otherwise = Poly topDmd
91 -- This really can happen with polymorphism
92 -- \f. case f x of (a,b) -> ...
93 -- case f y of (a,b,c) -> ...
94 -- Here the two demands on f are C(LL) and C(LLL)!
96 topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
97 topDmd = Top -- The most uninformative demand
99 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
100 evalDmd = Box seqDmd -- Evaluate and return
101 errDmd = Box Bot -- This used to be called X
103 isStrictDmd :: Demand -> Bool
104 isStrictDmd Bot = True
105 isStrictDmd (Eval _) = True
106 isStrictDmd (Call _) = True
107 isStrictDmd (Box d) = isStrictDmd d
108 isStrictDmd _ = False
110 seqDemand :: Demand -> ()
111 seqDemand (Call d) = seqDemand d
112 seqDemand (Eval ds) = seqDemands ds
113 seqDemand (Defer ds) = seqDemands ds
114 seqDemand (Box d) = seqDemand d
117 seqDemands :: Demands -> ()
118 seqDemands (Poly d) = seqDemand d
119 seqDemands (Prod ds) = seqDemandList ds
121 seqDemandList :: [Demand] -> ()
122 seqDemandList [] = ()
123 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
125 instance Outputable Demand where
130 ppr (Defer ds) = char 'D' <> ppr ds
131 ppr (Eval ds) = char 'U' <> ppr ds
133 ppr (Box (Eval ds)) = char 'S' <> ppr ds
134 ppr (Box Abs) = char 'L'
135 ppr (Box Bot) = char 'X'
136 ppr d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d)
138 ppr (Call d) = char 'C' <> parens (ppr d)
141 instance Outputable Demands where
142 ppr (Poly Abs) = empty
143 ppr (Poly d) = parens (ppr d <> char '*')
144 ppr (Prod ds) = parens (hcat (map ppr ds))
145 -- At one time I printed U(AAA) as U, but that
146 -- confuses (Poly Abs) with (Prod AAA), and the
147 -- worker/wrapper generation differs slightly for these two
148 -- [Reason: in the latter case we can avoid passing the arg;
149 -- see notes with WwLib.mkWWstr_one.]
153 %************************************************************************
155 \subsection{Demand types}
157 %************************************************************************
160 data DmdType = DmdType
161 DmdEnv -- Demand on explicitly-mentioned
163 [Demand] -- Demand on arguments
164 DmdResult -- Nature of result
166 -- IMPORTANT INVARIANT
167 -- The default demand on free variables not in the DmdEnv is:
168 -- DmdResult = BotRes <=> Bot
169 -- DmdResult = TopRes/ResCPR <=> Abs
171 -- ANOTHER IMPORTANT INVARIANT
172 -- The Demands in the argument list are never
174 -- Handwavey reason: these don't correspond to calling conventions
175 -- See DmdAnal.funArgDemand for details
178 -- This guy lets us switch off CPR analysis
179 -- by making sure that everything uses TopRes instead of RetCPR
180 -- Assuming, of course, that they don't mention RetCPR by name.
181 -- They should onlyu use retCPR
183 retCPR | opt_CprOff = TopRes
186 seqDmdType :: DmdType -> ()
187 seqDmdType (DmdType _env ds res) =
188 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
190 type DmdEnv = VarEnv Demand
192 data DmdResult = TopRes -- Nothing known
193 | RetCPR -- Returns a constructed product
194 | BotRes -- Diverges or errors
196 -- Equality for fixpoints
197 -- Show needed for Show in Lex.Token (sigh)
199 -- Equality needed for fixpoints in DmdAnal
200 instance Eq DmdType where
201 (==) (DmdType fv1 ds1 res1)
202 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
203 && ds1 == ds2 && res1 == res2
205 instance Outputable DmdType where
206 ppr (DmdType fv ds res)
207 = hsep [text "DmdType",
208 hcat (map ppr ds) <> ppr res,
209 if null fv_elts then empty
210 else braces (fsep (map pp_elt fv_elts))]
212 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
213 fv_elts = ufmToList fv
215 instance Outputable DmdResult where
216 ppr TopRes = empty -- Keep these distinct from Demand letters
217 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
218 ppr BotRes = char 'b' -- dddr
221 emptyDmdEnv :: VarEnv Demand
222 emptyDmdEnv = emptyVarEnv
224 topDmdType, botDmdType, cprDmdType :: DmdType
225 topDmdType = DmdType emptyDmdEnv [] TopRes
226 botDmdType = DmdType emptyDmdEnv [] BotRes
227 cprDmdType = DmdType emptyVarEnv [] retCPR
229 isTopDmdType :: DmdType -> Bool
230 -- Only used on top-level types, hence the assert
231 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
232 isTopDmdType _ = False
234 isBotRes :: DmdResult -> Bool
235 isBotRes BotRes = True
238 resTypeArgDmd :: DmdResult -> Demand
239 -- TopRes and BotRes are polymorphic, so that
240 -- BotRes = Bot -> BotRes
241 -- TopRes = Top -> TopRes
242 -- This function makes that concrete
243 -- We can get a RetCPR, because of the way in which we are (now)
244 -- giving CPR info to strict arguments. On the first pass, when
245 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
246 resTypeArgDmd TopRes = Top
247 resTypeArgDmd RetCPR = Top
248 resTypeArgDmd BotRes = Bot
250 returnsCPR :: DmdResult -> Bool
251 returnsCPR RetCPR = True
254 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
255 mkDmdType fv ds res = DmdType fv ds res
257 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
258 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
260 dmdTypeDepth :: DmdType -> Arity
261 dmdTypeDepth (DmdType _ ds _) = length ds
265 %************************************************************************
267 \subsection{Strictness signature
269 %************************************************************************
271 In a let-bound Id we record its strictness info.
272 In principle, this strictness info is a demand transformer, mapping
273 a demand on the Id into a DmdType, which gives
274 a) the free vars of the Id's value
275 b) the Id's arguments
276 c) an indication of the result of applying
277 the Id to its arguments
279 However, in fact we store in the Id an extremely emascuated demand transfomer,
282 (Nevertheless we dignify StrictSig as a distinct type.)
284 This DmdType gives the demands unleashed by the Id when it is applied
285 to as many arguments as are given in by the arg demands in the DmdType.
287 For example, the demand transformer described by the DmdType
288 DmdType {x -> U(LL)} [V,A] Top
289 says that when the function is applied to two arguments, it
290 unleashes demand U(LL) on the free var x, V on the first arg,
293 If this same function is applied to one arg, all we can say is
294 that it uses x with U*(LL), and its arg with demand L.
297 newtype StrictSig = StrictSig DmdType
300 instance Outputable StrictSig where
301 ppr (StrictSig ty) = ppr ty
303 instance Show StrictSig where
304 show (StrictSig ty) = showSDoc (ppr ty)
306 mkStrictSig :: DmdType -> StrictSig
307 mkStrictSig dmd_ty = StrictSig dmd_ty
309 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
310 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
312 isTopSig :: StrictSig -> Bool
313 isTopSig (StrictSig ty) = isTopDmdType ty
315 topSig, botSig, cprSig :: StrictSig
316 topSig = StrictSig topDmdType
317 botSig = StrictSig botDmdType
318 cprSig = StrictSig cprDmdType
321 -- appIsBottom returns true if an application to n args would diverge
322 appIsBottom :: StrictSig -> Int -> Bool
323 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
324 appIsBottom _ _ = False
326 isBottomingSig :: StrictSig -> Bool
327 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
328 isBottomingSig _ = False
330 seqStrictSig :: StrictSig -> ()
331 seqStrictSig (StrictSig ty) = seqDmdType ty
333 pprIfaceStrictSig :: StrictSig -> SDoc
334 -- Used for printing top-level strictness pragmas in interface files
335 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
336 = hcat (map ppr dmds) <> ppr res