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}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
18 isTop, isAbsent, seqDemand,
20 DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
21 dmdTypeDepth, seqDmdType,
23 DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
25 Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
27 StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
30 pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
33 #include "HsVersions.h"
44 %************************************************************************
48 %************************************************************************
52 = Top -- T; used for unlifted types too, so that
58 | Eval Demands -- U(ds)
60 | Defer Demands -- D(ds)
66 -- Equality needed for fixpoints in DmdAnal
68 data Demands = Poly Demand -- Polymorphic case
69 | Prod [Demand] -- Product case
72 allTop (Poly d) = isTop d
73 allTop (Prod ds) = all isTop ds
81 mapDmds :: (Demand -> Demand) -> Demands -> Demands
82 mapDmds f (Poly d) = Poly (f d)
83 mapDmds f (Prod ds) = Prod (map f ds)
85 zipWithDmds :: (Demand -> Demand -> Demand)
86 -> Demands -> Demands -> Demands
87 zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2)
88 zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1]
89 zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
90 zipWithDmds f (Prod ds1) (Prod ds2)
91 | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
92 | otherwise = Poly topDmd
93 -- This really can happen with polymorphism
94 -- \f. case f x of (a,b) -> ...
95 -- case f y of (a,b,c) -> ...
96 -- Here the two demands on f are C(LL) and C(LLL)!
98 topDmd, lazyDmd, seqDmd :: Demand
99 topDmd = Top -- The most uninformative demand
101 seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
102 evalDmd = Box seqDmd -- Evaluate and return
103 errDmd = Box Bot -- This used to be called X
105 isStrictDmd :: Demand -> Bool
106 isStrictDmd Bot = True
107 isStrictDmd (Eval _) = True
108 isStrictDmd (Call _) = True
109 isStrictDmd (Box d) = isStrictDmd d
110 isStrictDmd other = False
112 seqDemand :: Demand -> ()
113 seqDemand (Call d) = seqDemand d
114 seqDemand (Eval ds) = seqDemands ds
115 seqDemand (Defer ds) = seqDemands ds
116 seqDemand (Box d) = seqDemand d
119 seqDemands :: Demands -> ()
120 seqDemands (Poly d) = seqDemand d
121 seqDemands (Prod ds) = seqDemandList ds
123 seqDemandList :: [Demand] -> ()
124 seqDemandList [] = ()
125 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
127 instance Outputable Demand where
132 ppr (Defer ds) = char 'D' <> ppr ds
133 ppr (Eval ds) = char 'U' <> ppr ds
135 ppr (Box (Eval ds)) = char 'S' <> ppr ds
136 ppr (Box Abs) = char 'L'
137 ppr (Box Bot) = char 'X'
139 ppr (Call d) = char 'C' <> parens (ppr d)
142 instance Outputable Demands where
143 ppr (Poly Abs) = empty
144 ppr (Poly d) = parens (ppr d <> char '*')
145 ppr (Prod ds) = parens (hcat (map ppr ds))
146 -- At one time I printed U(AAA) as U, but that
147 -- confuses (Poly Abs) with (Prod AAA), and the
148 -- worker/wrapper generation differs slightly for these two
149 -- [Reason: in the latter case we can avoid passing the arg;
150 -- see notes with WwLib.mkWWstr_one.]
154 %************************************************************************
156 \subsection{Demand types}
158 %************************************************************************
161 data DmdType = DmdType
162 DmdEnv -- Demand on explicitly-mentioned
164 [Demand] -- Demand on arguments
165 DmdResult -- Nature of result
167 -- IMPORTANT INVARIANT
168 -- The default demand on free variables not in the DmdEnv is:
169 -- DmdResult = BotRes <=> Bot
170 -- DmdResult = TopRes/ResCPR <=> Abs
172 -- ANOTHER IMPORTANT INVARIANT
173 -- The Demands in the argument list are never
175 -- Handwavey reason: these don't correspond to calling conventions
176 -- See DmdAnal.funArgDemand for details
179 -- This guy lets us switch off CPR analysis
180 -- by making sure that everything uses TopRes instead of RetCPR
181 -- Assuming, of course, that they don't mention RetCPR by name.
182 -- They should onlyu use retCPR
183 retCPR | opt_CprOff = TopRes
186 seqDmdType (DmdType env ds res) =
187 {- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
189 type DmdEnv = VarEnv Demand
191 data DmdResult = TopRes -- Nothing known
192 | RetCPR -- Returns a constructed product
193 | BotRes -- Diverges or errors
195 -- Equality for fixpoints
196 -- Show needed for Show in Lex.Token (sigh)
198 -- Equality needed for fixpoints in DmdAnal
199 instance Eq DmdType where
200 (==) (DmdType fv1 ds1 res1)
201 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
202 && ds1 == ds2 && res1 == res2
204 instance Outputable DmdType where
205 ppr (DmdType fv ds res)
206 = hsep [text "DmdType",
207 hcat (map ppr ds) <> ppr res,
208 if null fv_elts then empty
209 else braces (fsep (map pp_elt fv_elts))]
211 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
212 fv_elts = ufmToList fv
214 instance Outputable DmdResult where
215 ppr TopRes = empty -- Keep these distinct from Demand letters
216 ppr RetCPR = char 'm' -- so that we can print strictness sigs as
217 ppr BotRes = char 'b' -- dddr
220 emptyDmdEnv = emptyVarEnv
222 topDmdType = DmdType emptyDmdEnv [] TopRes
223 botDmdType = DmdType emptyDmdEnv [] BotRes
224 cprDmdType = DmdType emptyVarEnv [] retCPR
226 isTopDmdType :: DmdType -> Bool
227 -- Only used on top-level types, hence the assert
228 isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
229 isTopDmdType other = False
231 isBotRes :: DmdResult -> Bool
232 isBotRes BotRes = True
233 isBotRes other = False
235 resTypeArgDmd :: DmdResult -> Demand
236 -- TopRes and BotRes are polymorphic, so that
237 -- BotRes = Bot -> BotRes
238 -- TopRes = Top -> TopRes
239 -- This function makes that concrete
240 -- We can get a RetCPR, because of the way in which we are (now)
241 -- giving CPR info to strict arguments. On the first pass, when
242 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
243 resTypeArgDmd TopRes = Top
244 resTypeArgDmd RetCPR = Top
245 resTypeArgDmd BotRes = Bot
247 returnsCPR :: DmdResult -> Bool
248 returnsCPR RetCPR = True
249 returnsCPR other = False
251 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
252 mkDmdType fv ds res = DmdType fv ds res
254 mkTopDmdType :: [Demand] -> DmdResult -> DmdType
255 mkTopDmdType ds res = DmdType emptyDmdEnv ds res
257 dmdTypeDepth :: DmdType -> Arity
258 dmdTypeDepth (DmdType _ ds _) = length ds
262 %************************************************************************
264 \subsection{Strictness signature
266 %************************************************************************
268 In a let-bound Id we record its strictness info.
269 In principle, this strictness info is a demand transformer, mapping
270 a demand on the Id into a DmdType, which gives
271 a) the free vars of the Id's value
272 b) the Id's arguments
273 c) an indication of the result of applying
274 the Id to its arguments
276 However, in fact we store in the Id an extremely emascuated demand transfomer,
279 (Nevertheless we dignify StrictSig as a distinct type.)
281 This DmdType gives the demands unleashed by the Id when it is applied
282 to as many arguments as are given in by the arg demands in the DmdType.
284 For example, the demand transformer described by the DmdType
285 DmdType {x -> U(LL)} [V,A] Top
286 says that when the function is applied to two arguments, it
287 unleashes demand U(LL) on the free var x, V on the first arg,
290 If this same function is applied to one arg, all we can say is
291 that it uses x with U*(LL), and its arg with demand L.
294 newtype StrictSig = StrictSig DmdType
297 instance Outputable StrictSig where
298 ppr (StrictSig ty) = ppr ty
300 instance Show StrictSig where
301 show (StrictSig ty) = showSDoc (ppr ty)
303 mkStrictSig :: DmdType -> StrictSig
304 mkStrictSig dmd_ty = StrictSig dmd_ty
306 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
307 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
309 isTopSig (StrictSig ty) = isTopDmdType ty
311 topSig, botSig, cprSig :: StrictSig
312 topSig = StrictSig topDmdType
313 botSig = StrictSig botDmdType
314 cprSig = StrictSig cprDmdType
317 -- appIsBottom returns true if an application to n args would diverge
318 appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
319 appIsBottom _ _ = False
321 isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
322 isBottomingSig _ = False
324 seqStrictSig (StrictSig ty) = seqDmdType ty
326 pprIfaceStrictSig :: StrictSig -> SDoc
327 -- Used for printing top-level strictness pragmas in interface files
328 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
329 = hcat (map ppr dmds) <> ppr res