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 #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 (Poly d) = isTop d
66 allTop (Prod ds) = all isTop ds
74 mapDmds :: (Demand -> Demand) -> Demands -> Demands
75 mapDmds f (Poly d) = Poly (f d)
76 mapDmds f (Prod ds) = Prod (map f ds)
78 zipWithDmds :: (Demand -> Demand -> Demand)
79 -> Demands -> Demands -> Demands
80 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
81 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
82 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
83 zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
85 topDmd, lazyDmd, seqDmd :: Demand
86 topDmd = Top -- The most uninformative demand
88 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
89 evalDmd = Box seqDmd -- Evaluate and return
90 errDmd = Box Bot -- This used to be called X
92 isStrictDmd :: Demand -> Bool
93 isStrictDmd Bot = True
94 isStrictDmd (Eval _) = True
95 isStrictDmd (Call _) = True
96 isStrictDmd (Box d) = isStrictDmd d
97 isStrictDmd other = False
99 seqDemand :: Demand -> ()
100 seqDemand (Call d) = seqDemand d
101 seqDemand (Eval ds) = seqDemands ds
102 seqDemand (Defer ds) = seqDemands ds
103 seqDemand (Box d) = seqDemand d
106 seqDemands :: Demands -> ()
107 seqDemands (Poly d) = seqDemand d
108 seqDemands (Prod ds) = seqDemandList ds
110 seqDemandList :: [Demand] -> ()
111 seqDemandList [] = ()
112 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
114 instance Outputable Demand where
119 ppr (Defer ds) = char 'D' <> ppr ds
120 ppr (Eval ds) = char 'U' <> ppr ds
122 ppr (Box (Eval ds)) = char 'S' <> ppr ds
123 ppr (Box Abs) = char 'L'
124 ppr (Box Bot) = char 'X'
126 ppr (Call d) = char 'C' <> parens (ppr d)
129 instance Outputable Demands where
130 ppr (Poly Abs) = empty
131 ppr (Poly d) = parens (ppr d <> char '*')
132 ppr (Prod ds) = parens (hcat (map ppr ds))
133 -- At one time I printed U(AAA) as U, but that
134 -- confuses (Poly Abs) with (Prod AAA), and the
135 -- worker/wrapper generation differs slightly for these two
136 -- [Reason: in the latter case we can avoid passing the arg;
137 -- see notes with WwLib.mkWWstr_one.]
141 %************************************************************************
143 \subsection{Demand types}
145 %************************************************************************
148 data DmdType = DmdType
149 DmdEnv -- Demand on explicitly-mentioned
151 [Demand] -- Demand on arguments
152 DmdResult -- Nature of result
154 -- IMPORTANT INVARIANT
155 -- The default demand on free variables not in the DmdEnv is:
156 -- DmdResult = BotRes <=> Bot
157 -- DmdResult = TopRes/ResCPR <=> Abs
159 -- ANOTHER IMPORTANT INVARIANT
160 -- The Demands in the argument list are never
162 -- Handwavey reason: these don't correspond to calling conventions
163 -- See DmdAnal.funArgDemand for details
166 -- This guy lets us switch off CPR analysis
167 -- by making sure that everything uses TopRes instead of RetCPR
168 -- Assuming, of course, that they don't mention RetCPR by name.
169 -- They should onlyu use retCPR
170 retCPR | opt_CprOff = TopRes
173 seqDmdType (DmdType env ds res) =
174 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
176 type DmdEnv = VarEnv Demand
178 data DmdResult = TopRes -- Nothing known
179 | RetCPR -- Returns a constructed product
180 | BotRes -- Diverges or errors
182 -- Equality for fixpoints
183 -- Show needed for Show in Lex.Token (sigh)
185 -- Equality needed for fixpoints in DmdAnal
186 instance Eq DmdType where
187 (==) (DmdType fv1 ds1 res1)
188 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
189 && ds1 == ds2 && res1 == res2
191 instance Outputable DmdType where
192 ppr (DmdType fv ds res)
193 = hsep [text "DmdType",
194 hcat (map ppr ds) <> ppr res,
195 if null fv_elts then empty
196 else braces (fsep (map pp_elt fv_elts))]
198 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
199 fv_elts = ufmToList fv
201 instance Outputable DmdResult where
202 ppr TopRes = empty -- Keep these distinct from Demand letters
203 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
204 ppr BotRes = char 'b' -- dddr
207 emptyDmdEnv = emptyVarEnv
209 topDmdType = DmdType emptyDmdEnv [] TopRes
210 botDmdType = DmdType emptyDmdEnv [] BotRes
211 cprDmdType = DmdType emptyVarEnv [] retCPR
213 isTopDmdType :: DmdType -> Bool
214 -- Only used on top-level types, hence the assert
215 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
216 isTopDmdType other = False
218 isBotRes :: DmdResult -> Bool
219 isBotRes BotRes = True
220 isBotRes other = False
222 resTypeArgDmd :: DmdResult -> Demand
223 -- TopRes and BotRes are polymorphic, so that
224 -- BotRes = Bot -> BotRes
225 -- TopRes = Top -> TopRes
226 -- This function makes that concrete
227 -- We can get a RetCPR, because of the way in which we are (now)
228 -- giving CPR info to strict arguments. On the first pass, when
229 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
230 resTypeArgDmd TopRes = Top
231 resTypeArgDmd RetCPR = Top
232 resTypeArgDmd BotRes = Bot
234 returnsCPR :: DmdResult -> Bool
235 returnsCPR RetCPR = True
236 returnsCPR other = False
238 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
239 mkDmdType fv ds res = DmdType fv ds res
241 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
242 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
244 dmdTypeDepth :: DmdType -> Arity
245 dmdTypeDepth (DmdType _ ds _) = length ds
249 %************************************************************************
251 \subsection{Strictness signature
253 %************************************************************************
255 In a let-bound Id we record its strictness info.
256 In principle, this strictness info is a demand transformer, mapping
257 a demand on the Id into a DmdType, which gives
258 a) the free vars of the Id's value
259 b) the Id's arguments
260 c) an indication of the result of applying
261 the Id to its arguments
263 However, in fact we store in the Id an extremely emascuated demand transfomer,
266 (Nevertheless we dignify StrictSig as a distinct type.)
268 This DmdType gives the demands unleashed by the Id when it is applied
269 to as many arguments as are given in by the arg demands in the DmdType.
271 For example, the demand transformer described by the DmdType
272 DmdType {x -> U(LL)} [V,A] Top
273 says that when the function is applied to two arguments, it
274 unleashes demand U(LL) on the free var x, V on the first arg,
277 If this same function is applied to one arg, all we can say is
278 that it uses x with U*(LL), and its arg with demand L.
281 newtype StrictSig = StrictSig DmdType
284 instance Outputable StrictSig where
285 ppr (StrictSig ty) = ppr ty
287 instance Show StrictSig where
288 show (StrictSig ty) = showSDoc (ppr ty)
290 mkStrictSig :: DmdType -> StrictSig
291 mkStrictSig dmd_ty = StrictSig dmd_ty
293 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
294 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
296 isTopSig (StrictSig ty) = isTopDmdType ty
298 topSig, botSig, cprSig :: StrictSig
299 topSig = StrictSig topDmdType
300 botSig = StrictSig botDmdType
301 cprSig = StrictSig cprDmdType
304 -- appIsBottom returns true if an application to n args would diverge
305 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
306 appIsBottom _ _ = False
308 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
309 isBottomingSig _ = False
311 seqStrictSig (StrictSig ty) = seqDmdType ty
313 pprIfaceStrictSig :: StrictSig -> SDoc
314 -- Used for printing top-level strictness pragmas in interface files
315 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
316 = hcat (map ppr dmds) <> ppr res