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)
84 | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
85 | otherwise = Poly topDmd
86 -- This really can happen with polymorphism
87 -- \f. case f x of (a,b) -> ...
88 -- case f y of (a,b,c) -> ...
89 -- Here the two demands on f are C(LL) and C(LLL)!
91 topDmd, lazyDmd, seqDmd :: Demand
92 topDmd = Top -- The most uninformative demand
94 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
95 evalDmd = Box seqDmd -- Evaluate and return
96 errDmd = Box Bot -- This used to be called X
98 isStrictDmd :: Demand -> Bool
99 isStrictDmd Bot = True
100 isStrictDmd (Eval _) = True
101 isStrictDmd (Call _) = True
102 isStrictDmd (Box d) = isStrictDmd d
103 isStrictDmd other = False
105 seqDemand :: Demand -> ()
106 seqDemand (Call d) = seqDemand d
107 seqDemand (Eval ds) = seqDemands ds
108 seqDemand (Defer ds) = seqDemands ds
109 seqDemand (Box d) = seqDemand d
112 seqDemands :: Demands -> ()
113 seqDemands (Poly d) = seqDemand d
114 seqDemands (Prod ds) = seqDemandList ds
116 seqDemandList :: [Demand] -> ()
117 seqDemandList [] = ()
118 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
120 instance Outputable Demand where
125 ppr (Defer ds) = char 'D' <> ppr ds
126 ppr (Eval ds) = char 'U' <> ppr ds
128 ppr (Box (Eval ds)) = char 'S' <> ppr ds
129 ppr (Box Abs) = char 'L'
130 ppr (Box Bot) = char 'X'
132 ppr (Call d) = char 'C' <> parens (ppr d)
135 instance Outputable Demands where
136 ppr (Poly Abs) = empty
137 ppr (Poly d) = parens (ppr d <> char '*')
138 ppr (Prod ds) = parens (hcat (map ppr ds))
139 -- At one time I printed U(AAA) as U, but that
140 -- confuses (Poly Abs) with (Prod AAA), and the
141 -- worker/wrapper generation differs slightly for these two
142 -- [Reason: in the latter case we can avoid passing the arg;
143 -- see notes with WwLib.mkWWstr_one.]
147 %************************************************************************
149 \subsection{Demand types}
151 %************************************************************************
154 data DmdType = DmdType
155 DmdEnv -- Demand on explicitly-mentioned
157 [Demand] -- Demand on arguments
158 DmdResult -- Nature of result
160 -- IMPORTANT INVARIANT
161 -- The default demand on free variables not in the DmdEnv is:
162 -- DmdResult = BotRes <=> Bot
163 -- DmdResult = TopRes/ResCPR <=> Abs
165 -- ANOTHER IMPORTANT INVARIANT
166 -- The Demands in the argument list are never
168 -- Handwavey reason: these don't correspond to calling conventions
169 -- See DmdAnal.funArgDemand for details
172 -- This guy lets us switch off CPR analysis
173 -- by making sure that everything uses TopRes instead of RetCPR
174 -- Assuming, of course, that they don't mention RetCPR by name.
175 -- They should onlyu use retCPR
176 retCPR | opt_CprOff = TopRes
179 seqDmdType (DmdType env ds res) =
180 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
182 type DmdEnv = VarEnv Demand
184 data DmdResult = TopRes -- Nothing known
185 | RetCPR -- Returns a constructed product
186 | BotRes -- Diverges or errors
188 -- Equality for fixpoints
189 -- Show needed for Show in Lex.Token (sigh)
191 -- Equality needed for fixpoints in DmdAnal
192 instance Eq DmdType where
193 (==) (DmdType fv1 ds1 res1)
194 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
195 && ds1 == ds2 && res1 == res2
197 instance Outputable DmdType where
198 ppr (DmdType fv ds res)
199 = hsep [text "DmdType",
200 hcat (map ppr ds) <> ppr res,
201 if null fv_elts then empty
202 else braces (fsep (map pp_elt fv_elts))]
204 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
205 fv_elts = ufmToList fv
207 instance Outputable DmdResult where
208 ppr TopRes = empty -- Keep these distinct from Demand letters
209 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
210 ppr BotRes = char 'b' -- dddr
213 emptyDmdEnv = emptyVarEnv
215 topDmdType = DmdType emptyDmdEnv [] TopRes
216 botDmdType = DmdType emptyDmdEnv [] BotRes
217 cprDmdType = DmdType emptyVarEnv [] retCPR
219 isTopDmdType :: DmdType -> Bool
220 -- Only used on top-level types, hence the assert
221 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
222 isTopDmdType other = False
224 isBotRes :: DmdResult -> Bool
225 isBotRes BotRes = True
226 isBotRes other = False
228 resTypeArgDmd :: DmdResult -> Demand
229 -- TopRes and BotRes are polymorphic, so that
230 -- BotRes = Bot -> BotRes
231 -- TopRes = Top -> TopRes
232 -- This function makes that concrete
233 -- We can get a RetCPR, because of the way in which we are (now)
234 -- giving CPR info to strict arguments. On the first pass, when
235 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
236 resTypeArgDmd TopRes = Top
237 resTypeArgDmd RetCPR = Top
238 resTypeArgDmd BotRes = Bot
240 returnsCPR :: DmdResult -> Bool
241 returnsCPR RetCPR = True
242 returnsCPR other = False
244 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
245 mkDmdType fv ds res = DmdType fv ds res
247 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
248 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
250 dmdTypeDepth :: DmdType -> Arity
251 dmdTypeDepth (DmdType _ ds _) = length ds
255 %************************************************************************
257 \subsection{Strictness signature
259 %************************************************************************
261 In a let-bound Id we record its strictness info.
262 In principle, this strictness info is a demand transformer, mapping
263 a demand on the Id into a DmdType, which gives
264 a) the free vars of the Id's value
265 b) the Id's arguments
266 c) an indication of the result of applying
267 the Id to its arguments
269 However, in fact we store in the Id an extremely emascuated demand transfomer,
272 (Nevertheless we dignify StrictSig as a distinct type.)
274 This DmdType gives the demands unleashed by the Id when it is applied
275 to as many arguments as are given in by the arg demands in the DmdType.
277 For example, the demand transformer described by the DmdType
278 DmdType {x -> U(LL)} [V,A] Top
279 says that when the function is applied to two arguments, it
280 unleashes demand U(LL) on the free var x, V on the first arg,
283 If this same function is applied to one arg, all we can say is
284 that it uses x with U*(LL), and its arg with demand L.
287 newtype StrictSig = StrictSig DmdType
290 instance Outputable StrictSig where
291 ppr (StrictSig ty) = ppr ty
293 instance Show StrictSig where
294 show (StrictSig ty) = showSDoc (ppr ty)
296 mkStrictSig :: DmdType -> StrictSig
297 mkStrictSig dmd_ty = StrictSig dmd_ty
299 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
300 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
302 isTopSig (StrictSig ty) = isTopDmdType ty
304 topSig, botSig, cprSig :: StrictSig
305 topSig = StrictSig topDmdType
306 botSig = StrictSig botDmdType
307 cprSig = StrictSig cprDmdType
310 -- appIsBottom returns true if an application to n args would diverge
311 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
312 appIsBottom _ _ = False
314 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
315 isBottomingSig _ = False
317 seqStrictSig (StrictSig ty) = seqDmdType ty
319 pprIfaceStrictSig :: StrictSig -> SDoc
320 -- Used for printing top-level strictness pragmas in interface files
321 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
322 = hcat (map ppr dmds) <> ppr res