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,
22 splitStrictSig, increaseStrictSigArity,
23 pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
26 #include "HsVersions.h"
37 %************************************************************************
41 %************************************************************************
45 = Top -- T; used for unlifted types too, so that
51 | Eval Demands -- U(ds)
53 | Defer Demands -- D(ds)
59 -- Equality needed for fixpoints in DmdAnal
61 data Demands = Poly Demand -- Polymorphic case
62 | Prod [Demand] -- Product case
65 allTop :: Demands -> Bool
66 allTop (Poly d) = isTop d
67 allTop (Prod ds) = all isTop ds
69 isTop :: Demand -> Bool
73 isAbsent :: Demand -> Bool
77 mapDmds :: (Demand -> Demand) -> Demands -> Demands
78 mapDmds f (Poly d) = Poly (f d)
79 mapDmds f (Prod ds) = Prod (map f ds)
81 zipWithDmds :: (Demand -> Demand -> Demand)
82 -> Demands -> Demands -> Demands
83 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
84 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
85 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
86 zipWithDmds f (Prod ds1) (Prod ds2)
87 | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
88 | otherwise = Poly topDmd
89 -- This really can happen with polymorphism
90 -- \f. case f x of (a,b) -> ...
91 -- case f y of (a,b,c) -> ...
92 -- Here the two demands on f are C(LL) and C(LLL)!
94 topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
95 topDmd = Top -- The most uninformative demand
97 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
98 evalDmd = Box seqDmd -- Evaluate and return
99 errDmd = Box Bot -- This used to be called X
101 isStrictDmd :: Demand -> Bool
102 isStrictDmd Bot = True
103 isStrictDmd (Eval _) = True
104 isStrictDmd (Call _) = True
105 isStrictDmd (Box d) = isStrictDmd d
106 isStrictDmd _ = False
108 seqDemand :: Demand -> ()
109 seqDemand (Call d) = seqDemand d
110 seqDemand (Eval ds) = seqDemands ds
111 seqDemand (Defer ds) = seqDemands ds
112 seqDemand (Box d) = seqDemand d
115 seqDemands :: Demands -> ()
116 seqDemands (Poly d) = seqDemand d
117 seqDemands (Prod ds) = seqDemandList ds
119 seqDemandList :: [Demand] -> ()
120 seqDemandList [] = ()
121 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
123 instance Outputable Demand where
128 ppr (Defer ds) = char 'D' <> ppr ds
129 ppr (Eval ds) = char 'U' <> ppr ds
131 ppr (Box (Eval ds)) = char 'S' <> ppr ds
132 ppr (Box Abs) = char 'L'
133 ppr (Box Bot) = char 'X'
134 ppr d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d)
136 ppr (Call d) = char 'C' <> parens (ppr d)
139 instance Outputable Demands where
140 ppr (Poly Abs) = empty
141 ppr (Poly d) = parens (ppr d <> char '*')
142 ppr (Prod ds) = parens (hcat (map ppr ds))
143 -- At one time I printed U(AAA) as U, but that
144 -- confuses (Poly Abs) with (Prod AAA), and the
145 -- worker/wrapper generation differs slightly for these two
146 -- [Reason: in the latter case we can avoid passing the arg;
147 -- see notes with WwLib.mkWWstr_one.]
151 %************************************************************************
153 \subsection{Demand types}
155 %************************************************************************
158 data DmdType = DmdType
159 DmdEnv -- Demand on explicitly-mentioned
161 [Demand] -- Demand on arguments
162 DmdResult -- Nature of result
164 -- IMPORTANT INVARIANT
165 -- The default demand on free variables not in the DmdEnv is:
166 -- DmdResult = BotRes <=> Bot
167 -- DmdResult = TopRes/ResCPR <=> Abs
169 -- ANOTHER IMPORTANT INVARIANT
170 -- The Demands in the argument list are never
172 -- Handwavey reason: these don't correspond to calling conventions
173 -- See DmdAnal.funArgDemand for details
176 -- This guy lets us switch off CPR analysis
177 -- by making sure that everything uses TopRes instead of RetCPR
178 -- Assuming, of course, that they don't mention RetCPR by name.
179 -- They should onlyu use retCPR
181 retCPR | opt_CprOff = TopRes
184 seqDmdType :: DmdType -> ()
185 seqDmdType (DmdType _env ds res) =
186 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
188 type DmdEnv = VarEnv Demand
190 data DmdResult = TopRes -- Nothing known
191 | RetCPR -- Returns a constructed product
192 | BotRes -- Diverges or errors
194 -- Equality for fixpoints
195 -- Show needed for Show in Lex.Token (sigh)
197 -- Equality needed for fixpoints in DmdAnal
198 instance Eq DmdType where
199 (==) (DmdType fv1 ds1 res1)
200 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
201 && ds1 == ds2 && res1 == res2
203 instance Outputable DmdType where
204 ppr (DmdType fv ds res)
205 = hsep [text "DmdType",
206 hcat (map ppr ds) <> ppr res,
207 if null fv_elts then empty
208 else braces (fsep (map pp_elt fv_elts))]
210 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
211 fv_elts = ufmToList fv
213 instance Outputable DmdResult where
214 ppr TopRes = empty -- Keep these distinct from Demand letters
215 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
216 ppr BotRes = char 'b' -- dddr
219 emptyDmdEnv :: VarEnv Demand
220 emptyDmdEnv = emptyVarEnv
222 topDmdType, botDmdType, cprDmdType :: DmdType
223 topDmdType = DmdType emptyDmdEnv [] TopRes
224 botDmdType = DmdType emptyDmdEnv [] BotRes
225 cprDmdType = DmdType emptyVarEnv [] retCPR
227 isTopDmdType :: DmdType -> Bool
228 -- Only used on top-level types, hence the assert
229 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
230 isTopDmdType _ = False
232 isBotRes :: DmdResult -> Bool
233 isBotRes BotRes = True
236 resTypeArgDmd :: DmdResult -> Demand
237 -- TopRes and BotRes are polymorphic, so that
238 -- BotRes = Bot -> BotRes
239 -- TopRes = Top -> TopRes
240 -- This function makes that concrete
241 -- We can get a RetCPR, because of the way in which we are (now)
242 -- giving CPR info to strict arguments. On the first pass, when
243 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
244 resTypeArgDmd TopRes = Top
245 resTypeArgDmd RetCPR = Top
246 resTypeArgDmd BotRes = Bot
248 returnsCPR :: DmdResult -> Bool
249 returnsCPR RetCPR = True
252 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
253 mkDmdType fv ds res = DmdType fv ds res
255 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
256 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
258 dmdTypeDepth :: DmdType -> Arity
259 dmdTypeDepth (DmdType _ ds _) = length ds
263 %************************************************************************
265 \subsection{Strictness signature
267 %************************************************************************
269 In a let-bound Id we record its strictness info.
270 In principle, this strictness info is a demand transformer, mapping
271 a demand on the Id into a DmdType, which gives
272 a) the free vars of the Id's value
273 b) the Id's arguments
274 c) an indication of the result of applying
275 the Id to its arguments
277 However, in fact we store in the Id an extremely emascuated demand transfomer,
280 (Nevertheless we dignify StrictSig as a distinct type.)
282 This DmdType gives the demands unleashed by the Id when it is applied
283 to as many arguments as are given in by the arg demands in the DmdType.
285 For example, the demand transformer described by the DmdType
286 DmdType {x -> U(LL)} [V,A] Top
287 says that when the function is applied to two arguments, it
288 unleashes demand U(LL) on the free var x, V on the first arg,
291 If this same function is applied to one arg, all we can say is
292 that it uses x with U*(LL), and its arg with demand L.
295 newtype StrictSig = StrictSig DmdType
298 instance Outputable StrictSig where
299 ppr (StrictSig ty) = ppr ty
301 instance Show StrictSig where
302 show (StrictSig ty) = showSDoc (ppr ty)
304 mkStrictSig :: DmdType -> StrictSig
305 mkStrictSig dmd_ty = StrictSig dmd_ty
307 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
308 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
310 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
311 -- Add extra arguments to a strictness signature
312 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
313 = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
315 isTopSig :: StrictSig -> Bool
316 isTopSig (StrictSig ty) = isTopDmdType ty
318 topSig, botSig, cprSig :: StrictSig
319 topSig = StrictSig topDmdType
320 botSig = StrictSig botDmdType
321 cprSig = StrictSig cprDmdType
324 -- appIsBottom returns true if an application to n args would diverge
325 appIsBottom :: StrictSig -> Int -> Bool
326 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
327 appIsBottom _ _ = False
329 isBottomingSig :: StrictSig -> Bool
330 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
331 isBottomingSig _ = False
333 seqStrictSig :: StrictSig -> ()
334 seqStrictSig (StrictSig ty) = seqDmdType ty
336 pprIfaceStrictSig :: StrictSig -> SDoc
337 -- Used for printing top-level strictness pragmas in interface files
338 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
339 = hcat (map ppr dmds) <> ppr res