Add a missing check for -fcpr-off
[ghc.git] / compiler / basicTypes / Demand.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[Demand]{@Demand@: A decoupled implementation of a demand domain}
6 -}
7
8 {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
9
10 module Demand (
11 StrDmd, UseDmd(..), Count(..),
12 countOnce, countMany, -- cardinality
13
14 Demand, CleanDemand,
15 mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
16 getUsage, toCleanDmd,
17 absDmd, topDmd, botDmd, seqDmd,
18 lubDmd, bothDmd,
19 lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,
20 isTopDmd, isBotDmd, isAbsDmd, isSeqDmd,
21 peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
22 addCaseBndrDmd,
23
24 DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
25 nopDmdType, botDmdType, mkDmdType,
26 addDemand, removeDmdTyArgs,
27 BothDmdArg, mkBothDmdArg, toBothDmdArg,
28
29 DmdEnv, emptyDmdEnv,
30 peelFV, findIdDemand,
31
32 DmdResult, CPRResult,
33 isBotRes, isTopRes,
34 topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
35 appIsBottom, isBottomingSig, pprIfaceStrictSig,
36 trimCPRInfo, returnsCPR_maybe,
37 StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
38 isNopSig, splitStrictSig, increaseStrictSigArity,
39
40 seqDemand, seqDemandList, seqDmdType, seqStrictSig,
41
42 evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
43 splitDmdTy, splitFVs,
44 deferAfterIO,
45 postProcessUnsat, postProcessDmdTypeM,
46
47 splitProdDmd_maybe, peelCallDmd, mkCallDmd,
48 dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
49 argOneShots, argsOneShots,
50 trimToType, TypeShape(..),
51
52 isSingleUsed, reuseEnv,
53 killUsageDemand, killUsageSig, zapUsageDemand,
54 strictifyDictDmd
55
56 ) where
57
58 #include "HsVersions.h"
59
60 import StaticFlags
61 import DynFlags
62 import Outputable
63 import Var ( Var )
64 import VarEnv
65 import UniqFM
66 import Util
67 import BasicTypes
68 import Binary
69 import Maybes ( orElse )
70
71 import Type ( Type, isUnLiftedType )
72 import TyCon ( isNewTyCon, isClassTyCon )
73 import DataCon ( splitDataProductType_maybe )
74 import FastString
75
76 {-
77 ************************************************************************
78 * *
79 \subsection{Strictness domain}
80 * *
81 ************************************************************************
82
83 Lazy
84 |
85 HeadStr
86 / \
87 SCall SProd
88 \ /
89 HyperStr
90 -}
91
92 -- Vanilla strictness domain
93 data StrDmd
94 = HyperStr -- Hyper-strict
95 -- Bottom of the lattice
96 -- Note [HyperStr and Use demands]
97
98 | SCall StrDmd -- Call demand
99 -- Used only for values of function type
100
101 | SProd [MaybeStr] -- Product
102 -- Used only for values of product type
103 -- Invariant: not all components are HyperStr (use HyperStr)
104 -- not all components are Lazy (use HeadStr)
105
106 | HeadStr -- Head-Strict
107 -- A polymorphic demand: used for values of all types,
108 -- including a type variable
109
110 deriving ( Eq, Show )
111
112 data MaybeStr = Lazy -- Lazy
113 -- Top of the lattice
114 | Str StrDmd
115 deriving ( Eq, Show )
116
117 -- Well-formedness preserving constructors for the Strictness domain
118 strBot, strTop :: MaybeStr
119 strBot = Str HyperStr
120 strTop = Lazy
121
122 mkSCall :: StrDmd -> StrDmd
123 mkSCall HyperStr = HyperStr
124 mkSCall s = SCall s
125
126 mkSProd :: [MaybeStr] -> StrDmd
127 mkSProd sx
128 | any isHyperStr sx = HyperStr
129 | all isLazy sx = HeadStr
130 | otherwise = SProd sx
131
132 isLazy :: MaybeStr -> Bool
133 isLazy Lazy = True
134 isLazy (Str _) = False
135
136 isHyperStr :: MaybeStr -> Bool
137 isHyperStr (Str HyperStr) = True
138 isHyperStr _ = False
139
140 -- Pretty-printing
141 instance Outputable StrDmd where
142 ppr HyperStr = char 'B'
143 ppr (SCall s) = char 'C' <> parens (ppr s)
144 ppr HeadStr = char 'S'
145 ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx))
146
147 instance Outputable MaybeStr where
148 ppr (Str s) = ppr s
149 ppr Lazy = char 'L'
150
151 lubMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr
152 lubMaybeStr Lazy _ = Lazy
153 lubMaybeStr _ Lazy = Lazy
154 lubMaybeStr (Str s1) (Str s2) = Str (s1 `lubStr` s2)
155
156 lubStr :: StrDmd -> StrDmd -> StrDmd
157 lubStr HyperStr s = s
158 lubStr (SCall s1) HyperStr = SCall s1
159 lubStr (SCall _) HeadStr = HeadStr
160 lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2)
161 lubStr (SCall _) (SProd _) = HeadStr
162 lubStr (SProd sx) HyperStr = SProd sx
163 lubStr (SProd _) HeadStr = HeadStr
164 lubStr (SProd s1) (SProd s2)
165 | length s1 == length s2 = mkSProd (zipWith lubMaybeStr s1 s2)
166 | otherwise = HeadStr
167 lubStr (SProd _) (SCall _) = HeadStr
168 lubStr HeadStr _ = HeadStr
169
170 bothMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr
171 bothMaybeStr Lazy s = s
172 bothMaybeStr s Lazy = s
173 bothMaybeStr (Str s1) (Str s2) = Str (s1 `bothStr` s2)
174
175 bothStr :: StrDmd -> StrDmd -> StrDmd
176 bothStr HyperStr _ = HyperStr
177 bothStr HeadStr s = s
178 bothStr (SCall _) HyperStr = HyperStr
179 bothStr (SCall s1) HeadStr = SCall s1
180 bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2)
181 bothStr (SCall _) (SProd _) = HyperStr -- Weird
182
183 bothStr (SProd _) HyperStr = HyperStr
184 bothStr (SProd s1) HeadStr = SProd s1
185 bothStr (SProd s1) (SProd s2)
186 | length s1 == length s2 = mkSProd (zipWith bothMaybeStr s1 s2)
187 | otherwise = HyperStr -- Weird
188 bothStr (SProd _) (SCall _) = HyperStr
189
190 -- utility functions to deal with memory leaks
191 seqStrDmd :: StrDmd -> ()
192 seqStrDmd (SProd ds) = seqStrDmdList ds
193 seqStrDmd (SCall s) = s `seq` ()
194 seqStrDmd _ = ()
195
196 seqStrDmdList :: [MaybeStr] -> ()
197 seqStrDmdList [] = ()
198 seqStrDmdList (d:ds) = seqMaybeStr d `seq` seqStrDmdList ds
199
200 seqMaybeStr :: MaybeStr -> ()
201 seqMaybeStr Lazy = ()
202 seqMaybeStr (Str s) = seqStrDmd s
203
204 -- Splitting polymorphic demands
205 splitMaybeStrProdDmd :: Int -> MaybeStr -> Maybe [MaybeStr]
206 splitMaybeStrProdDmd n Lazy = Just (replicate n Lazy)
207 splitMaybeStrProdDmd n (Str s) = splitStrProdDmd n s
208
209 splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr]
210 splitStrProdDmd n HyperStr = Just (replicate n strBot)
211 splitStrProdDmd n HeadStr = Just (replicate n strTop)
212 splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds
213 splitStrProdDmd _ (SCall {}) = Nothing
214 -- This can happen when the programmer uses unsafeCoerce,
215 -- and we don't then want to crash the compiler (Trac #9208)
216
217 {-
218 ************************************************************************
219 * *
220 \subsection{Absence domain}
221 * *
222 ************************************************************************
223
224 Used
225 / \
226 UCall UProd
227 \ /
228 UHead
229 |
230 Abs
231 -}
232
233 -- Domain for genuine usage
234 data UseDmd
235 = UCall Count UseDmd -- Call demand for absence
236 -- Used only for values of function type
237
238 | UProd [MaybeUsed] -- Product
239 -- Used only for values of product type
240 -- See Note [Don't optimise UProd(Used) to Used]
241 -- [Invariant] Not all components are Abs
242 -- (in that case, use UHead)
243
244 | UHead -- May be used; but its sub-components are
245 -- definitely *not* used. Roughly U(AAA)
246 -- Eg the usage of x in x `seq` e
247 -- A polymorphic demand: used for values of all types,
248 -- including a type variable
249 -- Since (UCall _ Abs) is ill-typed, UHead doesn't
250 -- make sense for lambdas
251
252 | Used -- May be used; and its sub-components may be used
253 -- Top of the lattice
254 deriving ( Eq, Show )
255
256 -- Extended usage demand for absence and counting
257 data MaybeUsed
258 = Abs -- Definitely unused
259 -- Bottom of the lattice
260
261 | Use Count UseDmd -- May be used with some cardinality
262 deriving ( Eq, Show )
263
264 -- Abstract counting of usages
265 data Count = One | Many
266 deriving ( Eq, Show )
267
268 -- Pretty-printing
269 instance Outputable MaybeUsed where
270 ppr Abs = char 'A'
271 ppr (Use Many a) = ppr a
272 ppr (Use One a) = char '1' <> char '*' <> ppr a
273
274 instance Outputable UseDmd where
275 ppr Used = char 'U'
276 ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a)
277 ppr UHead = char 'H'
278 ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))
279
280 instance Outputable Count where
281 ppr One = char '1'
282 ppr Many = text ""
283
284 -- Well-formedness preserving constructors for the Absence domain
285 countOnce, countMany :: Count
286 countOnce = One
287 countMany = Many
288
289 useBot, useTop :: MaybeUsed
290 useBot = Abs
291 useTop = Use Many Used
292
293 mkUCall :: Count -> UseDmd -> UseDmd
294 --mkUCall c Used = Used c
295 mkUCall c a = UCall c a
296
297 mkUProd :: [MaybeUsed] -> UseDmd
298 mkUProd ux
299 | all (== Abs) ux = UHead
300 | otherwise = UProd ux
301
302 lubCount :: Count -> Count -> Count
303 lubCount _ Many = Many
304 lubCount Many _ = Many
305 lubCount x _ = x
306
307 lubMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed
308 lubMaybeUsed Abs x = x
309 lubMaybeUsed x Abs = x
310 lubMaybeUsed (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)
311
312 lubUse :: UseDmd -> UseDmd -> UseDmd
313 lubUse UHead u = u
314 lubUse (UCall c u) UHead = UCall c u
315 lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)
316 lubUse (UCall _ _) _ = Used
317 lubUse (UProd ux) UHead = UProd ux
318 lubUse (UProd ux1) (UProd ux2)
319 | length ux1 == length ux2 = UProd $ zipWith lubMaybeUsed ux1 ux2
320 | otherwise = Used
321 lubUse (UProd {}) (UCall {}) = Used
322 -- lubUse (UProd {}) Used = Used
323 lubUse (UProd ux) Used = UProd (map (`lubMaybeUsed` useTop) ux)
324 lubUse Used (UProd ux) = UProd (map (`lubMaybeUsed` useTop) ux)
325 lubUse Used _ = Used -- Note [Used should win]
326
327 -- `both` is different from `lub` in its treatment of counting; if
328 -- `both` is computed for two used, the result always has
329 -- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
330 -- Also, x `bothUse` x /= x (for anything but Abs).
331
332 bothMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed
333 bothMaybeUsed Abs x = x
334 bothMaybeUsed x Abs = x
335 bothMaybeUsed (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2)
336
337
338 bothUse :: UseDmd -> UseDmd -> UseDmd
339 bothUse UHead u = u
340 bothUse (UCall c u) UHead = UCall c u
341
342 -- Exciting special treatment of inner demand for call demands:
343 -- use `lubUse` instead of `bothUse`!
344 bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2)
345
346 bothUse (UCall {}) _ = Used
347 bothUse (UProd ux) UHead = UProd ux
348 bothUse (UProd ux1) (UProd ux2)
349 | length ux1 == length ux2 = UProd $ zipWith bothMaybeUsed ux1 ux2
350 | otherwise = Used
351 bothUse (UProd {}) (UCall {}) = Used
352 -- bothUse (UProd {}) Used = Used -- Note [Used should win]
353 bothUse Used (UProd ux) = UProd (map (`bothMaybeUsed` useTop) ux)
354 bothUse (UProd ux) Used = UProd (map (`bothMaybeUsed` useTop) ux)
355 bothUse Used _ = Used -- Note [Used should win]
356
357 peelUseCall :: UseDmd -> Maybe (Count, UseDmd)
358 peelUseCall (UCall c u) = Just (c,u)
359 peelUseCall _ = Nothing
360
361 addCaseBndrDmd :: Demand -- On the case binder
362 -> [Demand] -- On the components of the constructor
363 -> [Demand] -- Final demands for the components of the constructor
364 -- See Note [Demand on case-alternative binders]
365 addCaseBndrDmd (JD { strd = ms, absd = mu }) alt_dmds
366 = case mu of
367 Abs -> alt_dmds
368 Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
369 where
370 Just ss = splitMaybeStrProdDmd arity ms -- Guaranteed not to be a call
371 Just us = splitUseProdDmd arity u -- Ditto
372 where
373 arity = length alt_dmds
374
375 {- Note [Demand on case-alternative binders]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 The demand on a binder in a case alternative comes
378 (a) From the demand on the binder itself
379 (b) From the demand on the case binder
380 Forgetting (b) led directly to Trac #10148.
381
382 Example. Source code:
383 f x@(p,_) = if p then foo x else True
384
385 foo (p,True) = True
386 foo (p,q) = foo (q,p)
387
388 After strictness analysis:
389 f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->
390 case x_an1
391 of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]
392 { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->
393 case p_an2 of _ {
394 False -> GHC.Types.True;
395 True -> foo wild_X7 }
396
397 It's true that ds_dnz is *itself* absent, but the use of wild_X7 means
398 that it is very much alive and demanded. See Trac #10148 for how the
399 consequences play out.
400
401 This is needed even for non-product types, in case the case-binder
402 is used but the components of the case alternative are not.
403
404 Note [Don't optimise UProd(Used) to Used]
405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
406 These two UseDmds:
407 UProd [Used, Used] and Used
408 are semantically equivalent, but we do not turn the former into
409 the latter, for a regrettable-subtle reason. Suppose we did.
410 then
411 f (x,y) = (y,x)
412 would get
413 StrDmd = Str = SProd [Lazy, Lazy]
414 UseDmd = Used = UProd [Used, Used]
415 But with the joint demand of <Str, Used> doesn't convey any clue
416 that there is a product involved, and so the worthSplittingFun
417 will not fire. (We'd need to use the type as well to make it fire.)
418 Moreover, consider
419 g h p@(_,_) = h p
420 This too would get <Str, Used>, but this time there really isn't any
421 point in w/w since the components of the pair are not used at all.
422
423 So the solution is: don't aggressively collapse UProd [Used,Used] to
424 Used; intead leave it as-is. In effect we are using the UseDmd to do a
425 little bit of boxity analysis. Not very nice.
426
427 Note [Used should win]
428 ~~~~~~~~~~~~~~~~~~~~~~
429 Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.
430 Why? Because Used carries the implication the whole thing is used,
431 box and all, so we don't want to w/w it. If we use it both boxed and
432 unboxed, then we are definitely using the box, and so we are quite
433 likely to pay a reboxing cost. So we make Used win here.
434
435 Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer
436
437 Baseline: (A) Not making Used win (UProd wins)
438 Compare with: (B) making Used win for lub and both
439
440 Min -0.3% -5.6% -10.7% -11.0% -33.3%
441 Max +0.3% +45.6% +11.5% +11.5% +6.9%
442 Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8%
443
444 Baseline: (B) Making Used win for both lub and both
445 Compare with: (C) making Used win for both, but UProd win for lub
446
447 Min -0.1% -0.3% -7.9% -8.0% -6.5%
448 Max +0.1% +1.0% +21.0% +21.0% +0.5%
449 Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1%
450 -}
451
452 -- If a demand is used multiple times (i.e. reused), than any use-once
453 -- mentioned there, that is not protected by a UCall, can happen many times.
454 markReusedDmd :: MaybeUsed -> MaybeUsed
455 markReusedDmd Abs = Abs
456 markReusedDmd (Use _ a) = Use Many (markReused a)
457
458 markReused :: UseDmd -> UseDmd
459 markReused (UCall _ u) = UCall Many u -- No need to recurse here
460 markReused (UProd ux) = UProd (map markReusedDmd ux)
461 markReused u = u
462
463 isUsedMU :: MaybeUsed -> Bool
464 -- True <=> markReusedDmd d = d
465 isUsedMU Abs = True
466 isUsedMU (Use One _) = False
467 isUsedMU (Use Many u) = isUsedU u
468
469 isUsedU :: UseDmd -> Bool
470 -- True <=> markReused d = d
471 isUsedU Used = True
472 isUsedU UHead = True
473 isUsedU (UProd us) = all isUsedMU us
474 isUsedU (UCall One _) = False
475 isUsedU (UCall Many _) = True -- No need to recurse
476
477 -- Squashing usage demand demands
478 seqUseDmd :: UseDmd -> ()
479 seqUseDmd (UProd ds) = seqMaybeUsedList ds
480 seqUseDmd (UCall c d) = c `seq` seqUseDmd d
481 seqUseDmd _ = ()
482
483 seqMaybeUsedList :: [MaybeUsed] -> ()
484 seqMaybeUsedList [] = ()
485 seqMaybeUsedList (d:ds) = seqMaybeUsed d `seq` seqMaybeUsedList ds
486
487 seqMaybeUsed :: MaybeUsed -> ()
488 seqMaybeUsed (Use c u) = c `seq` seqUseDmd u
489 seqMaybeUsed _ = ()
490
491 -- Splitting polymorphic Maybe-Used demands
492 splitUseProdDmd :: Int -> UseDmd -> Maybe [MaybeUsed]
493 splitUseProdDmd n Used = Just (replicate n useTop)
494 splitUseProdDmd n UHead = Just (replicate n Abs)
495 splitUseProdDmd n (UProd ds) = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
496 Just ds
497 splitUseProdDmd _ (UCall _ _) = Nothing
498 -- This can happen when the programmer uses unsafeCoerce,
499 -- and we don't then want to crash the compiler (Trac #9208)
500
501 {-
502 ************************************************************************
503 * *
504 \subsection{Joint domain for Strictness and Absence}
505 * *
506 ************************************************************************
507 -}
508
509 data JointDmd = JD { strd :: MaybeStr, absd :: MaybeUsed }
510 deriving ( Eq, Show )
511
512 -- Pretty-printing
513 instance Outputable JointDmd where
514 ppr (JD {strd = s, absd = a}) = angleBrackets (ppr s <> char ',' <> ppr a)
515
516 -- Well-formedness preserving constructors for the joint domain
517 mkJointDmd :: MaybeStr -> MaybeUsed -> JointDmd
518 mkJointDmd s a = JD { strd = s, absd = a }
519
520 mkJointDmds :: [MaybeStr] -> [MaybeUsed] -> [JointDmd]
521 mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as
522
523 absDmd :: JointDmd
524 absDmd = mkJointDmd Lazy Abs
525
526 lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand
527 -- C1(U), C1(C1(U)) respectively
528 strictApply1Dmd = JD { strd = Str (SCall HeadStr), absd = Use Many (UCall One Used) }
529 lazyApply1Dmd = JD { strd = Lazy, absd = Use Many (UCall One Used) }
530 lazyApply2Dmd = JD { strd = Lazy, absd = Use Many (UCall One (UCall One Used)) }
531
532 topDmd :: JointDmd
533 topDmd = mkJointDmd Lazy useTop
534
535 seqDmd :: JointDmd
536 seqDmd = mkJointDmd (Str HeadStr) (Use One UHead)
537
538 botDmd :: JointDmd
539 botDmd = mkJointDmd strBot useBot
540
541 lubDmd :: JointDmd -> JointDmd -> JointDmd
542 lubDmd (JD {strd = s1, absd = a1})
543 (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `lubMaybeStr` s2) (a1 `lubMaybeUsed` a2)
544
545 bothDmd :: JointDmd -> JointDmd -> JointDmd
546 bothDmd (JD {strd = s1, absd = a1})
547 (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `bothMaybeStr` s2) (a1 `bothMaybeUsed` a2)
548
549 isTopDmd :: JointDmd -> Bool
550 isTopDmd (JD {strd = Lazy, absd = Use Many Used}) = True
551 isTopDmd _ = False
552
553 isBotDmd :: JointDmd -> Bool
554 isBotDmd (JD {strd = Str HyperStr, absd = Abs}) = True
555 isBotDmd _ = False
556
557 isAbsDmd :: JointDmd -> Bool
558 isAbsDmd (JD {absd = Abs}) = True -- The strictness part can be HyperStr
559 isAbsDmd _ = False -- for a bottom demand
560
561 isSeqDmd :: JointDmd -> Bool
562 isSeqDmd (JD {strd=Str HeadStr, absd=Use _ UHead}) = True
563 isSeqDmd _ = False
564
565 -- More utility functions for strictness
566 seqDemand :: JointDmd -> ()
567 seqDemand (JD {strd = x, absd = y}) = seqMaybeStr x `seq` seqMaybeUsed y `seq` ()
568
569 seqDemandList :: [JointDmd] -> ()
570 seqDemandList [] = ()
571 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
572
573 isStrictDmd :: Demand -> Bool
574 -- See Note [Strict demands]
575 isStrictDmd (JD {absd = Abs}) = False
576 isStrictDmd (JD {strd = Lazy}) = False
577 isStrictDmd _ = True
578
579 isWeakDmd :: Demand -> Bool
580 isWeakDmd (JD {strd = s, absd = a}) = isLazy s && isUsedMU a
581
582 cleanUseDmd_maybe :: JointDmd -> Maybe UseDmd
583 cleanUseDmd_maybe (JD { absd = Use _ ud }) = Just ud
584 cleanUseDmd_maybe _ = Nothing
585
586 splitFVs :: Bool -- Thunk
587 -> DmdEnv -> (DmdEnv, DmdEnv)
588 splitFVs is_thunk rhs_fvs
589 | is_thunk = foldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
590 | otherwise = partitionVarEnv isWeakDmd rhs_fvs
591 where
592 add uniq dmd@(JD { strd = s, absd = u }) (lazy_fv, sig_fv)
593 | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)
594 | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { strd = Lazy, absd = u })
595 , addToUFM_Directly sig_fv uniq (JD { strd = s, absd = Abs }) )
596
597 {-
598 ************************************************************************
599 * *
600 \subsection{Clean demand for Strictness and Usage}
601 * *
602 ************************************************************************
603
604 This domain differst from JointDemand in the sence that pure absence
605 is taken away, i.e., we deal *only* with non-absent demands.
606
607 Note [Strict demands]
608 ~~~~~~~~~~~~~~~~~~~~~
609 isStrictDmd returns true only of demands that are
610 both strict
611 and used
612 In particular, it is False for <HyperStr, Abs>, which can and does
613 arise in, say (Trac #7319)
614 f x = raise# <some exception>
615 Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .
616 Now the w/w generates
617 fx = let x <HyperStr,Abs> = absentError "unused"
618 in raise <some exception>
619 At this point we really don't want to convert to
620 fx = case absentError "unused" of x -> raise <some exception>
621 Since the program is going to diverge, this swaps one error for another,
622 but it's really a bad idea to *ever* evaluate an absent argument.
623 In Trac #7319 we get
624 T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]
625
626 Note [Dealing with call demands]
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628 Call demands are constructed and deconstructed coherently for
629 strictness and absence. For instance, the strictness signature for the
630 following function
631
632 f :: (Int -> (Int, Int)) -> (Int, Bool)
633 f g = (snd (g 3), True)
634
635 should be: <L,C(U(AU))>m
636 -}
637
638 data CleanDemand -- A demand that is at least head-strict
639 = CD { sd :: StrDmd, ud :: UseDmd }
640 deriving ( Eq, Show )
641
642 instance Outputable CleanDemand where
643 ppr (CD {sd = s, ud = a}) = angleBrackets (ppr s <> comma <> ppr a)
644
645 mkCleanDmd :: StrDmd -> UseDmd -> CleanDemand
646 mkCleanDmd s a = CD { sd = s, ud = a }
647
648 bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
649 bothCleanDmd (CD { sd = s1, ud = a1}) (CD { sd = s2, ud = a2})
650 = CD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
651
652 mkHeadStrict :: CleanDemand -> CleanDemand
653 mkHeadStrict (CD { ud = a }) = mkCleanDmd HeadStr a
654
655 oneifyDmd :: JointDmd -> JointDmd
656 oneifyDmd (JD { strd = s, absd = Use _ a }) = JD { strd = s, absd = Use One a }
657 oneifyDmd jd = jd
658
659 mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> JointDmd
660 mkOnceUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use One a)
661 mkManyUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use Many a)
662
663 getUsage :: CleanDemand -> UseDmd
664 getUsage = ud
665
666 evalDmd :: JointDmd
667 -- Evaluated strictly, and used arbitrarily deeply
668 evalDmd = mkJointDmd (Str HeadStr) useTop
669
670 mkProdDmd :: [JointDmd] -> CleanDemand
671 mkProdDmd dx
672 = mkCleanDmd sp up
673 where
674 sp = mkSProd $ map strd dx
675 up = mkUProd $ map absd dx
676
677 mkCallDmd :: CleanDemand -> CleanDemand
678 mkCallDmd (CD {sd = d, ud = u})
679 = mkCleanDmd (mkSCall d) (mkUCall One u)
680
681 cleanEvalDmd :: CleanDemand
682 cleanEvalDmd = mkCleanDmd HeadStr Used
683
684 cleanEvalProdDmd :: Arity -> CleanDemand
685 cleanEvalProdDmd n = mkCleanDmd HeadStr (UProd (replicate n useTop))
686
687 isSingleUsed :: JointDmd -> Bool
688 isSingleUsed (JD {absd=a}) = is_used_once a
689 where
690 is_used_once Abs = True
691 is_used_once (Use One _) = True
692 is_used_once _ = False
693
694
695 data TypeShape = TsFun TypeShape
696 | TsProd [TypeShape]
697 | TsUnk
698
699 instance Outputable TypeShape where
700 ppr TsUnk = ptext (sLit "TsUnk")
701 ppr (TsFun ts) = ptext (sLit "TsFun") <> parens (ppr ts)
702 ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
703
704 trimToType :: JointDmd -> TypeShape -> JointDmd
705 -- See Note [Trimming a demand to a type]
706 trimToType (JD ms mu) ts
707 = JD (go_ms ms ts) (go_mu mu ts)
708 where
709 go_ms :: MaybeStr -> TypeShape -> MaybeStr
710 go_ms Lazy _ = Lazy
711 go_ms (Str s) ts = Str (go_s s ts)
712
713 go_s :: StrDmd -> TypeShape -> StrDmd
714 go_s HyperStr _ = HyperStr
715 go_s (SCall s) (TsFun ts) = SCall (go_s s ts)
716 go_s (SProd mss) (TsProd tss)
717 | equalLength mss tss = SProd (zipWith go_ms mss tss)
718 go_s _ _ = HeadStr
719
720 go_mu :: MaybeUsed -> TypeShape -> MaybeUsed
721 go_mu Abs _ = Abs
722 go_mu (Use c u) ts = Use c (go_u u ts)
723
724 go_u :: UseDmd -> TypeShape -> UseDmd
725 go_u UHead _ = UHead
726 go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)
727 go_u (UProd mus) (TsProd tss)
728 | equalLength mus tss = UProd (zipWith go_mu mus tss)
729 go_u _ _ = Used
730
731 {-
732 Note [Trimming a demand to a type]
733 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
734 Consider this:
735
736 f :: a -> Bool
737 f x = case ... of
738 A g1 -> case (x |> g1) of (p,q) -> ...
739 B -> error "urk"
740
741 where A,B are the constructors of a GADT. We'll get a U(U,U) demand
742 on x from the A branch, but that's a stupid demand for x itself, which
743 has type 'a'. Indeed we get ASSERTs going off (notably in
744 splitUseProdDmd, Trac #8569).
745
746 Bottom line: we really don't want to have a binder whose demand is more
747 deeply-nested than its type. There are various ways to tackle this.
748 When processing (x |> g1), we could "trim" the incoming demand U(U,U)
749 to match x's type. But I'm currently doing so just at the moment when
750 we pin a demand on a binder, in DmdAnal.findBndrDmd.
751
752
753 Note [Threshold demands]
754 ~~~~~~~~~~~~~~~~~~~~~~~~
755 Threshold usage demand is generated to figure out if
756 cardinality-instrumented demands of a binding's free variables should
757 be unleashed. See also [Aggregated demand for cardinality].
758
759 Note [Replicating polymorphic demands]
760 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
761 Some demands can be considered as polymorphic. Generally, it is
762 applicable to such beasts as tops, bottoms as well as Head-Used adn
763 Head-stricts demands. For instance,
764
765 S ~ S(L, ..., L)
766
767 Also, when top or bottom is occurred as a result demand, it in fact
768 can be expanded to saturate a callee's arity.
769 -}
770
771 splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd]
772 -- Split a product into its components, iff there is any
773 -- useful information to be extracted thereby
774 -- The demand is not necessarily strict!
775 splitProdDmd_maybe (JD {strd = s, absd = u})
776 = case (s,u) of
777 (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
778 -> Just (mkJointDmds sx ux)
779 (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
780 -> Just (mkJointDmds sx ux)
781 (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
782 _ -> Nothing
783
784 {-
785 ************************************************************************
786 * *
787 Demand results
788 * *
789 ************************************************************************
790
791
792 DmdResult: Dunno CPRResult
793 /
794 Diverges
795
796
797 CPRResult: NoCPR
798 / \
799 RetProd RetSum ConTag
800
801
802 Product contructors return (Dunno (RetProd rs))
803 In a fixpoint iteration, start from Diverges
804 We have lubs, but not glbs; but that is ok.
805 -}
806
807 ------------------------------------------------------------------------
808 -- Constructed Product Result
809 ------------------------------------------------------------------------
810
811 data Termination r = Diverges -- Definitely diverges
812 | Dunno r -- Might diverge or converge
813 deriving( Eq, Show )
814
815 type DmdResult = Termination CPRResult
816
817 data CPRResult = NoCPR -- Top of the lattice
818 | RetProd -- Returns a constructor from a product type
819 | RetSum ConTag -- Returns a constructor from a data type
820 deriving( Eq, Show )
821
822 lubCPR :: CPRResult -> CPRResult -> CPRResult
823 lubCPR (RetSum t1) (RetSum t2)
824 | t1 == t2 = RetSum t1
825 lubCPR RetProd RetProd = RetProd
826 lubCPR _ _ = NoCPR
827
828 lubDmdResult :: DmdResult -> DmdResult -> DmdResult
829 lubDmdResult Diverges r = r
830 lubDmdResult (Dunno c1) Diverges = Dunno c1
831 lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
832 -- This needs to commute with defaultDmd, i.e.
833 -- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
834 -- (See Note [Default demand on free variables] for why)
835
836 bothDmdResult :: DmdResult -> Termination () -> DmdResult
837 -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
838 bothDmdResult _ Diverges = Diverges
839 bothDmdResult r _ = r
840 -- This needs to commute with defaultDmd, i.e.
841 -- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
842 -- (See Note [Default demand on free variables] for why)
843
844 instance Outputable r => Outputable (Termination r) where
845 ppr Diverges = char 'b'
846 ppr (Dunno c) = ppr c
847
848 instance Outputable CPRResult where
849 ppr NoCPR = empty
850 ppr (RetSum n) = char 'm' <> int n
851 ppr RetProd = char 'm'
852
853 seqDmdResult :: DmdResult -> ()
854 seqDmdResult Diverges = ()
855 seqDmdResult (Dunno c) = seqCPRResult c
856
857 seqCPRResult :: CPRResult -> ()
858 seqCPRResult NoCPR = ()
859 seqCPRResult (RetSum n) = n `seq` ()
860 seqCPRResult RetProd = ()
861
862
863 ------------------------------------------------------------------------
864 -- Combined demand result --
865 ------------------------------------------------------------------------
866
867 -- [cprRes] lets us switch off CPR analysis
868 -- by making sure that everything uses TopRes
869 topRes, botRes :: DmdResult
870 topRes = Dunno NoCPR
871 botRes = Diverges
872
873 cprSumRes :: ConTag -> DmdResult
874 cprSumRes tag | opt_CprOff = topRes
875 | otherwise = Dunno $ RetSum tag
876
877 cprProdRes :: [DmdType] -> DmdResult
878 cprProdRes _arg_tys
879 | opt_CprOff = topRes
880 | otherwise = Dunno $ RetProd
881
882 vanillaCprProdRes :: Arity -> DmdResult
883 vanillaCprProdRes _arity
884 | opt_CprOff = topRes
885 | otherwise = Dunno $ RetProd
886
887 isTopRes :: DmdResult -> Bool
888 isTopRes (Dunno NoCPR) = True
889 isTopRes _ = False
890
891 isBotRes :: DmdResult -> Bool
892 isBotRes Diverges = True
893 isBotRes _ = False
894
895 trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
896 trimCPRInfo trim_all trim_sums res
897 = trimR res
898 where
899 trimR (Dunno c) = Dunno (trimC c)
900 trimR Diverges = Diverges
901
902 trimC (RetSum n) | trim_all || trim_sums = NoCPR
903 | otherwise = RetSum n
904 trimC RetProd | trim_all = NoCPR
905 | otherwise = RetProd
906 trimC NoCPR = NoCPR
907
908 returnsCPR_maybe :: DmdResult -> Maybe ConTag
909 returnsCPR_maybe (Dunno c) = retCPR_maybe c
910 returnsCPR_maybe Diverges = Nothing
911
912 retCPR_maybe :: CPRResult -> Maybe ConTag
913 retCPR_maybe (RetSum t) = Just t
914 retCPR_maybe RetProd = Just fIRST_TAG
915 retCPR_maybe NoCPR = Nothing
916
917 -- See Notes [Default demand on free variables]
918 -- and [defaultDmd vs. resTypeArgDmd]
919 defaultDmd :: Termination r -> JointDmd
920 defaultDmd Diverges = botDmd
921 defaultDmd _ = absDmd
922
923 resTypeArgDmd :: DmdResult -> JointDmd
924 -- TopRes and BotRes are polymorphic, so that
925 -- BotRes === Bot -> BotRes === ...
926 -- TopRes === Top -> TopRes === ...
927 -- This function makes that concrete
928 -- Also see Note [defaultDmd vs. resTypeArgDmd]
929 resTypeArgDmd r | isBotRes r = botDmd
930 resTypeArgDmd _ = topDmd
931
932 {-
933 Note [defaultDmd and resTypeArgDmd]
934 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
935
936 These functions are similar: They express the demand on something not
937 explicitly mentioned in the environment resp. the argument list. Yet they are
938 different:
939 * Variables not mentioned in the free variables environment are definitely
940 unused, so we can use absDmd there.
941 * Further arguments *can* be used, of course. Hence topDmd is used.
942
943 Note [Worthy functions for Worker-Wrapper split]
944 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
945 For non-bottoming functions a worker-wrapper transformation takes into
946 account several possibilities to decide if the function is worthy for
947 splitting:
948
949 1. The result is of product type and the function is strict in some
950 (or even all) of its arguments. The check that the argument is used is
951 more of sanity nature, since strictness implies usage. Example:
952
953 f :: (Int, Int) -> Int
954 f p = (case p of (a,b) -> a) + 1
955
956 should be splitted to
957
958 f :: (Int, Int) -> Int
959 f p = case p of (a,b) -> $wf a
960
961 $wf :: Int -> Int
962 $wf a = a + 1
963
964 2. Sometimes it also makes sense to perform a WW split if the
965 strictness analysis cannot say for sure if the function is strict in
966 components of its argument. Then we reason according to the inferred
967 usage information: if the function uses its product argument's
968 components, the WW split can be beneficial. Example:
969
970 g :: Bool -> (Int, Int) -> Int
971 g c p = case p of (a,b) ->
972 if c then a else b
973
974 The function g is strict in is argument p and lazy in its
975 components. However, both components are used in the RHS. The idea is
976 since some of the components (both in this case) are used in the
977 right-hand side, the product must presumable be taken apart.
978
979 Therefore, the WW transform splits the function g to
980
981 g :: Bool -> (Int, Int) -> Int
982 g c p = case p of (a,b) -> $wg c a b
983
984 $wg :: Bool -> Int -> Int -> Int
985 $wg c a b = if c then a else b
986
987 3. If an argument is absent, it would be silly to pass it to a
988 function, hence the worker with reduced arity is generated.
989
990
991 Note [Worker-wrapper for bottoming functions]
992 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
993 We used not to split if the result is bottom.
994 [Justification: there's no efficiency to be gained.]
995
996 But it's sometimes bad not to make a wrapper. Consider
997 fw = \x# -> let x = I# x# in case e of
998 p1 -> error_fn x
999 p2 -> error_fn x
1000 p3 -> the real stuff
1001 The re-boxing code won't go away unless error_fn gets a wrapper too.
1002 [We don't do reboxing now, but in general it's better to pass an
1003 unboxed thing to f, and have it reboxed in the error cases....]
1004
1005 However we *don't* want to do this when the argument is not actually
1006 taken apart in the function at all. Otherwise we risk decomposing a
1007 masssive tuple which is barely used. Example:
1008
1009 f :: ((Int,Int) -> String) -> (Int,Int) -> a
1010 f g pr = error (g pr)
1011
1012 main = print (f fst (1, error "no"))
1013
1014 Here, f does not take 'pr' apart, and it's stupid to do so.
1015 Imagine that it had millions of fields. This actually happened
1016 in GHC itself where the tuple was DynFlags
1017
1018
1019 ************************************************************************
1020 * *
1021 \subsection{Demand environments and types}
1022 * *
1023 ************************************************************************
1024 -}
1025
1026 type Demand = JointDmd
1027
1028 type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables]
1029
1030 data DmdType = DmdType
1031 DmdEnv -- Demand on explicitly-mentioned
1032 -- free variables
1033 [Demand] -- Demand on arguments
1034 DmdResult -- See [Nature of result demand]
1035
1036 {-
1037 Note [Nature of result demand]
1038 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1039 A DmdResult contains information about termination (currently distinguishing
1040 definite divergence and no information; it is possible to include definite
1041 convergence here), and CPR information about the result.
1042
1043 The semantics of this depends on whether we are looking at a DmdType, i.e. the
1044 demand put on by an expression _under a specific incoming demand_ on its
1045 environment, or at a StrictSig describing a demand transformer.
1046
1047 For a
1048 * DmdType, the termination information is true given the demand it was
1049 generated with, while for
1050 * a StrictSig it is olds after applying enough arguments.
1051
1052 The CPR information, though, is valid after the number of arguments mentioned
1053 in the type is given. Therefore, when forgetting the demand on arguments, as in
1054 dmdAnalRhs, this needs to be considere (via removeDmdTyArgs).
1055
1056 Consider
1057 b2 x y = x `seq` y `seq` error (show x)
1058 this has a strictness signature of
1059 <S><S>b
1060 meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but
1061 for "b2 1 2 `seq` ()" we get definite divergence.
1062
1063 For comparison,
1064 b1 x = x `seq` error (show x)
1065 has a strictness signature of
1066 <S>b
1067 and "b1 1 `seq` ()" is known to terminate.
1068
1069 Now consider a function h with signature "<C(S)>", and the expression
1070 e1 = h b1
1071 now h puts a demand of <C(S)> onto its argument, and the demand transformer
1072 turns it into
1073 <S>b
1074 Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not
1075 diverge, and we do not anything being passed to b.
1076
1077 Note [Asymmetry of 'both' for DmdType and DmdResult]
1078 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1079 'both' for DmdTypes is *assymetrical*, because there is only one
1080 result! For example, given (e1 e2), we get a DmdType dt1 for e1, use
1081 its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).
1082 Similarly with
1083 case e of { p -> rhs }
1084 we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
1085 compute (dt_rhs `bothType` dt_scrut).
1086
1087 We
1088 1. combine the information on the free variables,
1089 2. take the demand on arguments from the first argument
1090 3. combine the termination results, but
1091 4. take CPR info from the first argument.
1092
1093 3 and 4 are implementd in bothDmdResult.
1094 -}
1095
1096 -- Equality needed for fixpoints in DmdAnal
1097 instance Eq DmdType where
1098 (==) (DmdType fv1 ds1 res1)
1099 (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
1100 && ds1 == ds2 && res1 == res2
1101
1102 lubDmdType :: DmdType -> DmdType -> DmdType
1103 lubDmdType d1 d2
1104 = DmdType lub_fv lub_ds lub_res
1105 where
1106 n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
1107 (DmdType fv1 ds1 r1) = ensureArgs n d1
1108 (DmdType fv2 ds2 r2) = ensureArgs n d2
1109
1110 lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
1111 lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2
1112 lub_res = lubDmdResult r1 r2
1113
1114 {-
1115 Note [The need for BothDmdArg]
1116 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1117 Previously, the right argument to bothDmdType, as well as the return value of
1118 dmdAnalStar via postProcessDmdTypeM, was a DmdType. But bothDmdType only needs
1119 to know about the free variables and termination information, but nothing about
1120 the demand put on arguments, nor cpr information. So we make that explicit by
1121 only passing the relevant information.
1122 -}
1123
1124 type BothDmdArg = (DmdEnv, Termination ())
1125
1126 mkBothDmdArg :: DmdEnv -> BothDmdArg
1127 mkBothDmdArg env = (env, Dunno ())
1128
1129 toBothDmdArg :: DmdType -> BothDmdArg
1130 toBothDmdArg (DmdType fv _ r) = (fv, go r)
1131 where
1132 go (Dunno {}) = Dunno ()
1133 go Diverges = Diverges
1134
1135 bothDmdType :: DmdType -> BothDmdArg -> DmdType
1136 bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
1137 -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
1138 -- 'both' takes the argument/result info from its *first* arg,
1139 -- using its second arg just for its free-var info.
1140 = DmdType both_fv ds1 (r1 `bothDmdResult` t2)
1141 where both_fv = plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)
1142
1143 instance Outputable DmdType where
1144 ppr (DmdType fv ds res)
1145 = hsep [text "DmdType",
1146 hcat (map ppr ds) <> ppr res,
1147 if null fv_elts then empty
1148 else braces (fsep (map pp_elt fv_elts))]
1149 where
1150 pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
1151 fv_elts = ufmToList fv
1152
1153 emptyDmdEnv :: VarEnv Demand
1154 emptyDmdEnv = emptyVarEnv
1155
1156 -- nopDmdType is the demand of doing nothing
1157 -- (lazy, absent, no CPR information, no termination information).
1158 -- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
1159 -- so it is (no longer) called topDmd
1160 nopDmdType, botDmdType :: DmdType
1161 nopDmdType = DmdType emptyDmdEnv [] topRes
1162 botDmdType = DmdType emptyDmdEnv [] botRes
1163
1164 cprProdDmdType :: Arity -> DmdType
1165 cprProdDmdType arity
1166 = DmdType emptyDmdEnv [] (vanillaCprProdRes arity)
1167
1168 isNopDmdType :: DmdType -> Bool
1169 isNopDmdType (DmdType env [] res)
1170 | isTopRes res && isEmptyVarEnv env = True
1171 isNopDmdType _ = False
1172
1173 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
1174 mkDmdType fv ds res = DmdType fv ds res
1175
1176 dmdTypeDepth :: DmdType -> Arity
1177 dmdTypeDepth (DmdType _ ds _) = length ds
1178
1179 -- Remove any demand on arguments. This is used in dmdAnalRhs on the body
1180 removeDmdTyArgs :: DmdType -> DmdType
1181 removeDmdTyArgs = ensureArgs 0
1182
1183 -- This makes sure we can use the demand type with n arguments,
1184 -- It extends the argument list with the correct resTypeArgDmd
1185 -- It also adjusts the DmdResult: Divergence survives additional arguments,
1186 -- CPR information does not (and definite converge also would not).
1187 ensureArgs :: Arity -> DmdType -> DmdType
1188 ensureArgs n d | n == depth = d
1189 | otherwise = DmdType fv ds' r'
1190 where depth = dmdTypeDepth d
1191 DmdType fv ds r = d
1192
1193 ds' = take n (ds ++ repeat (resTypeArgDmd r))
1194 r' | Diverges <- r = r
1195 | otherwise = topRes
1196 -- See [Nature of result demand]
1197
1198 seqDmdType :: DmdType -> ()
1199 seqDmdType (DmdType env ds res) =
1200 seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` ()
1201
1202 seqDmdEnv :: DmdEnv -> ()
1203 seqDmdEnv env = seqDemandList (varEnvElts env)
1204
1205
1206 splitDmdTy :: DmdType -> (Demand, DmdType)
1207 -- Split off one function argument
1208 -- We already have a suitable demand on all
1209 -- free vars, so no need to add more!
1210 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
1211 splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty)
1212
1213 -- When e is evaluated after executing an IO action, and d is e's demand, then
1214 -- what of this demand should we consider, given that the IO action can cleanly
1215 -- exit?
1216 -- * We have to kill all strictness demands (i.e. lub with a lazy demand)
1217 -- * We can keep demand information (i.e. lub with an absent deman)
1218 -- * We have to kill definite divergence
1219 -- * We can keep CPR information.
1220 -- See Note [IO hack in the demand analyser]
1221 deferAfterIO :: DmdType -> DmdType
1222 deferAfterIO d@(DmdType _ _ res) =
1223 case d `lubDmdType` nopDmdType of
1224 DmdType fv ds _ -> DmdType fv ds (defer_res res)
1225 where
1226 defer_res Diverges = topRes
1227 defer_res r = r
1228
1229 strictenDmd :: JointDmd -> CleanDemand
1230 strictenDmd (JD {strd = s, absd = u})
1231 = CD { sd = poke_s s, ud = poke_u u }
1232 where
1233 poke_s Lazy = HeadStr
1234 poke_s (Str s) = s
1235 poke_u Abs = UHead
1236 poke_u (Use _ u) = u
1237
1238 -- Deferring and peeeling
1239
1240 type DeferAndUse -- Describes how to degrade a result type
1241 =( Bool -- Lazify (defer) the type
1242 , Count) -- Many => manify the type
1243
1244 type DeferAndUseM = Maybe DeferAndUse
1245 -- Nothing <=> absent-ify the result type; it will never be used
1246
1247 toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM)
1248 toCleanDmd (JD { strd = s, absd = u }) expr_ty
1249 = case (s,u) of
1250 (Str s', Use c u') -> -- The normal case
1251 (CD { sd = s', ud = u' }, Just (False, c))
1252
1253 (Lazy, Use c u') -> -- See Note [Analyzing with lazy demand and lambdas]
1254 (CD { sd = HeadStr, ud = u' }, Just (True, c))
1255
1256 (_, Abs) -- See Note [Analysing with absent demand]
1257 | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One))
1258 | otherwise -> (CD { sd = HeadStr, ud = Used }, Nothing)
1259
1260 -- This is used in dmdAnalStar when post-processing
1261 -- a function's argument demand. So we only care about what
1262 -- does to free variables, and whether it terminates.
1263 -- see Note [The need for BothDmdArg]
1264 postProcessDmdTypeM :: DeferAndUseM -> DmdType -> BothDmdArg
1265 postProcessDmdTypeM Nothing _ = (emptyDmdEnv, Dunno ())
1266 -- Incoming demand was Absent, so just discard all usage information
1267 -- We only processed the thing at all to analyse the body
1268 -- See Note [Always analyse in virgin pass]
1269 postProcessDmdTypeM (Just du) (DmdType fv _ res_ty)
1270 = (postProcessDmdEnv du fv, postProcessDmdResult du res_ty)
1271
1272 postProcessDmdResult :: DeferAndUse -> DmdResult -> Termination ()
1273 postProcessDmdResult (True,_) _ = Dunno ()
1274 postProcessDmdResult (False,_) (Dunno {}) = Dunno ()
1275 postProcessDmdResult (False,_) Diverges = Diverges
1276
1277 postProcessDmdEnv :: DeferAndUse -> DmdEnv -> DmdEnv
1278 postProcessDmdEnv (True, Many) env = deferReuseEnv env
1279 postProcessDmdEnv (False, Many) env = reuseEnv env
1280 postProcessDmdEnv (True, One) env = deferEnv env
1281 postProcessDmdEnv (False, One) env = env
1282
1283
1284 postProcessUnsat :: DeferAndUse -> DmdType -> DmdType
1285 postProcessUnsat (True, Many) ty = deferReuse ty
1286 postProcessUnsat (False, Many) ty = reuseType ty
1287 postProcessUnsat (True, One) ty = deferType ty
1288 postProcessUnsat (False, One) ty = ty
1289
1290 deferType, reuseType, deferReuse :: DmdType -> DmdType
1291 deferType (DmdType fv ds _) = DmdType (deferEnv fv) (map deferDmd ds) topRes
1292 reuseType (DmdType fv ds res_ty) = DmdType (reuseEnv fv) (map reuseDmd ds) res_ty
1293 deferReuse (DmdType fv ds _) = DmdType (deferReuseEnv fv) (map deferReuseDmd ds) topRes
1294
1295 deferEnv, reuseEnv, deferReuseEnv :: DmdEnv -> DmdEnv
1296 deferEnv fv = mapVarEnv deferDmd fv
1297 reuseEnv fv = mapVarEnv reuseDmd fv
1298 deferReuseEnv fv = mapVarEnv deferReuseDmd fv
1299
1300 deferDmd, reuseDmd, deferReuseDmd :: JointDmd -> JointDmd
1301 deferDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy a
1302 reuseDmd (JD {strd=d, absd=a}) = mkJointDmd d (markReusedDmd a)
1303 deferReuseDmd (JD {strd=_, absd=a}) = mkJointDmd Lazy (markReusedDmd a)
1304
1305 -- Peels one call level from the demand, and also returns
1306 -- whether it was unsaturated (separately for strictness and usage)
1307 peelCallDmd :: CleanDemand -> (CleanDemand, DeferAndUse)
1308 -- Exploiting the fact that
1309 -- on the strictness side C(B) = B
1310 -- and on the usage side C(U) = U
1311 peelCallDmd (CD {sd = s, ud = u})
1312 = case (s, u) of
1313 (SCall s', UCall c u') -> (CD { sd = s', ud = u' }, (False, c))
1314 (SCall s', _) -> (CD { sd = s', ud = Used }, (False, Many))
1315 (HyperStr, UCall c u') -> (CD { sd = HyperStr, ud = u' }, (False, c))
1316 (HyperStr, _) -> (CD { sd = HyperStr, ud = Used }, (False, Many))
1317 (_, UCall c u') -> (CD { sd = HeadStr, ud = u' }, (True, c))
1318 (_, _) -> (CD { sd = HeadStr, ud = Used }, (True, Many))
1319 -- The _ cases for usage includes UHead which seems a bit wrong
1320 -- because the body isn't used at all!
1321 -- c.f. the Abs case in toCleanDmd
1322
1323 -- Peels that multiple nestings of calls clean demand and also returns
1324 -- whether it was unsaturated (separately for strictness and usage
1325 -- see Note [Demands from unsaturated function calls]
1326 peelManyCalls :: Int -> CleanDemand -> DeferAndUse
1327 peelManyCalls n (CD { sd = str, ud = abs })
1328 = (go_str n str, go_abs n abs)
1329 where
1330 go_str :: Int -> StrDmd -> Bool -- True <=> unsaturated, defer
1331 go_str 0 _ = False
1332 go_str _ HyperStr = False -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)
1333 go_str n (SCall d') = go_str (n-1) d'
1334 go_str _ _ = True
1335
1336 go_abs :: Int -> UseDmd -> Count -- Many <=> unsaturated, or at least
1337 go_abs 0 _ = One -- one UCall Many in the demand
1338 go_abs n (UCall One d') = go_abs (n-1) d'
1339 go_abs _ _ = Many
1340
1341 {-
1342 Note [Demands from unsaturated function calls]
1343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1344
1345 Consider a demand transformer d1 -> d2 -> r for f.
1346 If a sufficiently detailed demand is fed into this transformer,
1347 e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context,
1348 then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for
1349 the free variable environment) and furthermore the result information r is the
1350 one we want to use.
1351
1352 An anonymous lambda is also an unsaturated function all (needs one argument,
1353 none given), so this applies to that case as well.
1354
1355 But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases:
1356 * Not enough demand on the strictness side:
1357 - In that case, we need to zap all strictness in the demand on arguments and
1358 free variables.
1359 - Furthermore, we remove CPR information. It could be left, but given the incoming
1360 demand is not enough to evaluate so far we just do not bother.
1361 - And finally termination information: If r says that f diverges for sure,
1362 then this holds when the demand guarantees that two arguments are going to
1363 be passed. If the demand is lower, we may just as well converge.
1364 If we were tracking definite convegence, than that would still hold under
1365 a weaker demand than expected by the demand transformer.
1366 * Not enough demand from the usage side: The missing usage can be expanded
1367 using UCall Many, therefore this is subsumed by the third case:
1368 * At least one of the uses has a cardinality of Many.
1369 - Even if f puts a One demand on any of its argument or free variables, if
1370 we call f multiple times, we may evaluate this argument or free variable
1371 multiple times. So forget about any occurrence of "One" in the demand.
1372
1373 In dmdTransformSig, we call peelManyCalls to find out if we are in any of these
1374 cases, and then call postProcessUnsat to reduce the demand appropriately.
1375
1376 Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use
1377 peelCallDmd, which peels only one level, but also returns the demand put on the
1378 body of the function.
1379 -}
1380
1381 peelFV :: DmdType -> Var -> (DmdType, Demand)
1382 peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
1383 (DmdType fv' ds res, dmd)
1384 where
1385 fv' = fv `delVarEnv` id
1386 -- See Note [Default demand on free variables]
1387 dmd = lookupVarEnv fv id `orElse` defaultDmd res
1388
1389 addDemand :: Demand -> DmdType -> DmdType
1390 addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
1391
1392 findIdDemand :: DmdType -> Var -> Demand
1393 findIdDemand (DmdType fv _ res) id
1394 = lookupVarEnv fv id `orElse` defaultDmd res
1395
1396 {-
1397 Note [Default demand on free variables]
1398 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1399 If the variable is not mentioned in the environment of a demand type,
1400 its demand is taken to be a result demand of the type.
1401 For the stricness component,
1402 if the result demand is a Diverges, then we use HyperStr
1403 else we use Lazy
1404 For the usage component, we use Absent.
1405 So we use either absDmd or botDmd.
1406
1407 Also note the equations for lubDmdResult (resp. bothDmdResult) noted there.
1408
1409 Note [Always analyse in virgin pass]
1410 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1411 Tricky point: make sure that we analyse in the 'virgin' pass. Consider
1412 rec { f acc x True = f (...rec { g y = ...g... }...)
1413 f acc x False = acc }
1414 In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
1415 That might mean that we analyse the sub-expression containing the
1416 E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse*
1417 E, but just retuned botType.
1418
1419 Then in the *next* (non-virgin) iteration for 'f', we might analyse E
1420 in a weaker demand, and that will trigger doing a fixpoint iteration
1421 for g. But *because it's not the virgin pass* we won't start g's
1422 iteration at bottom. Disaster. (This happened in $sfibToList' of
1423 nofib/spectral/fibheaps.)
1424
1425 So in the virgin pass we make sure that we do analyse the expression
1426 at least once, to initialise its signatures.
1427
1428 Note [Analyzing with lazy demand and lambdas]
1429 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1430 The insight for analyzing lambdas follows from the fact that for
1431 strictness S = C(L). This polymorphic expansion is critical for
1432 cardinality analysis of the following example:
1433
1434 {-# NOINLINE build #-}
1435 build g = (g (:) [], g (:) [])
1436
1437 h c z = build (\x ->
1438 let z1 = z ++ z
1439 in if c
1440 then \y -> x (y ++ z1)
1441 else \y -> x (z1 ++ y))
1442
1443 One can see that `build` assigns to `g` demand <L,C(C1(U))>.
1444 Therefore, when analyzing the lambda `(\x -> ...)`, we
1445 expect each lambda \y -> ... to be annotated as "one-shot"
1446 one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a
1447 demand <C(C(..), C(C1(U))>.
1448
1449 This is achieved by, first, converting the lazy demand L into the
1450 strict S by the second clause of the analysis.
1451
1452 Note [Analysing with absent demand]
1453 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1454 Suppose we analyse an expression with demand <L,A>. The "A" means
1455 "absent", so this expression will never be needed. What should happen?
1456 There are several wrinkles:
1457
1458 * We *do* want to analyse the expression regardless.
1459 Reason: Note [Always analyse in virgin pass]
1460
1461 But we can post-process the results to ignore all the usage
1462 demands coming back. This is done by postProcessDmdTypeM.
1463
1464 * But in the case of an *unlifted type* we must be extra careful,
1465 because unlifted values are evaluated even if they are not used.
1466 Example (see Trac #9254):
1467 f :: (() -> (# Int#, () #)) -> ()
1468 -- Strictness signature is
1469 -- <C(S(LS)), 1*C1(U(A,1*U()))>
1470 -- I.e. calls k, but discards first component of result
1471 f k = case k () of (# _, r #) -> r
1472
1473 g :: Int -> ()
1474 g y = f (\n -> (# case y of I# y2 -> y2, n #))
1475
1476 Here f's strictness signature says (correctly) that it calls its
1477 argument function and ignores the first component of its result.
1478 This is correct in the sense that it'd be fine to (say) modify the
1479 function so that always returned 0# in the first component.
1480
1481 But in function g, we *will* evaluate the 'case y of ...', because
1482 it has type Int#. So 'y' will be evaluated. So we must record this
1483 usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
1484 'y' is bound to an aBSENT_ERROR thunk.
1485
1486 An alternative would be to replace the 'case y of ...' with (say) 0#,
1487 but I have not tried that. It's not a common situation, but it is
1488 not theoretical: unsafePerformIO's implementation is very very like
1489 'f' above.
1490
1491
1492 ************************************************************************
1493 * *
1494 Demand signatures
1495 * *
1496 ************************************************************************
1497
1498 In a let-bound Id we record its strictness info.
1499 In principle, this strictness info is a demand transformer, mapping
1500 a demand on the Id into a DmdType, which gives
1501 a) the free vars of the Id's value
1502 b) the Id's arguments
1503 c) an indication of the result of applying
1504 the Id to its arguments
1505
1506 However, in fact we store in the Id an extremely emascuated demand
1507 transfomer, namely
1508
1509 a single DmdType
1510 (Nevertheless we dignify StrictSig as a distinct type.)
1511
1512 This DmdType gives the demands unleashed by the Id when it is applied
1513 to as many arguments as are given in by the arg demands in the DmdType.
1514 Also see Note [Nature of result demand] for the meaning of a DmdResult in a
1515 strictness signature.
1516
1517 If an Id is applied to less arguments than its arity, it means that
1518 the demand on the function at a call site is weaker than the vanilla
1519 call demand, used for signature inference. Therefore we place a top
1520 demand on all arguments. Otherwise, the demand is specified by Id's
1521 signature.
1522
1523 For example, the demand transformer described by the demand signature
1524 StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m)
1525 says that when the function is applied to two arguments, it
1526 unleashes demand <S,1*U> on the free var x, <L,A> on the first arg,
1527 and <L,U(U,U)> on the second, then returning a constructor.
1528
1529 If this same function is applied to one arg, all we can say is that it
1530 uses x with <L,U>, and its arg with demand <L,U>.
1531 -}
1532
1533 newtype StrictSig = StrictSig DmdType
1534 deriving( Eq )
1535
1536 instance Outputable StrictSig where
1537 ppr (StrictSig ty) = ppr ty
1538
1539 -- Used for printing top-level strictness pragmas in interface files
1540 pprIfaceStrictSig :: StrictSig -> SDoc
1541 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
1542 = hcat (map ppr dmds) <> ppr res
1543
1544 mkStrictSig :: DmdType -> StrictSig
1545 mkStrictSig dmd_ty = StrictSig dmd_ty
1546
1547 mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig
1548 mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res)
1549
1550 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
1551 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
1552
1553 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
1554 -- Add extra arguments to a strictness signature
1555 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
1556 = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
1557
1558 isNopSig :: StrictSig -> Bool
1559 isNopSig (StrictSig ty) = isNopDmdType ty
1560
1561 isBottomingSig :: StrictSig -> Bool
1562 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
1563
1564 nopSig, botSig :: StrictSig
1565 nopSig = StrictSig nopDmdType
1566 botSig = StrictSig botDmdType
1567
1568 cprProdSig :: Arity -> StrictSig
1569 cprProdSig arity = StrictSig (cprProdDmdType arity)
1570
1571 seqStrictSig :: StrictSig -> ()
1572 seqStrictSig (StrictSig ty) = seqDmdType ty
1573
1574 dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
1575 -- (dmdTransformSig fun_sig dmd) considers a call to a function whose
1576 -- signature is fun_sig, with demand dmd. We return the demand
1577 -- that the function places on its context (eg its args)
1578 dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd
1579 = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty
1580 -- see Note [Demands from unsaturated function calls]
1581
1582 dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
1583 -- Same as dmdTransformSig but for a data constructor (worker),
1584 -- which has a special kind of demand transformer.
1585 -- If the constructor is saturated, we feed the demand on
1586 -- the result into the constructor arguments.
1587 dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
1588 (CD { sd = str, ud = abs })
1589 | Just str_dmds <- go_str arity str
1590 , Just abs_dmds <- go_abs arity abs
1591 = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res
1592 -- Must remember whether it's a product, hence con_res, not TopRes
1593
1594 | otherwise -- Not saturated
1595 = nopDmdType
1596 where
1597 go_str 0 dmd = splitStrProdDmd arity dmd
1598 go_str n (SCall s') = go_str (n-1) s'
1599 go_str n HyperStr = go_str (n-1) HyperStr
1600 go_str _ _ = Nothing
1601
1602 go_abs 0 dmd = splitUseProdDmd arity dmd
1603 go_abs n (UCall One u') = go_abs (n-1) u'
1604 go_abs _ _ = Nothing
1605
1606 dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
1607 -- Like dmdTransformDataConSig, we have a special demand transformer
1608 -- for dictionary selectors. If the selector is saturated (ie has one
1609 -- argument: the dictionary), we feed the demand on the result into
1610 -- the indicated dictionary component.
1611 dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd
1612 | (cd',defer_use) <- peelCallDmd cd
1613 , Just jds <- splitProdDmd_maybe dict_dmd
1614 = postProcessUnsat defer_use $
1615 DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes
1616 | otherwise
1617 = nopDmdType -- See Note [Demand transformer for a dictionary selector]
1618 where
1619 enhance cd old | isAbsDmd old = old
1620 | otherwise = mkOnceUsedDmd cd -- This is the one!
1621
1622 dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"
1623
1624 {-
1625 Note [Demand transformer for a dictionary selector]
1626 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1627 If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'
1628 into the appropriate field of the dictionary. What *is* the appropriate field?
1629 We just look at the strictness signature of the class op, which will be
1630 something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'.
1631
1632 For single-method classes, which are represented by newtypes the signature
1633 of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.
1634 That's fine: if we are doing strictness analysis we are also doing inling,
1635 so we'll have inlined 'op' into a cast. So we can bale out in a conservative
1636 way, returning nopDmdType.
1637
1638 It is (just.. Trac #8329) possible to be running strictness analysis *without*
1639 having inlined class ops from single-method classes. Suppose you are using
1640 ghc --make; and the first module has a local -O0 flag. So you may load a class
1641 without interface pragmas, ie (currently) without an unfolding for the class
1642 ops. Now if a subsequent module in the --make sweep has a local -O flag
1643 you might do strictness analysis, but there is no inlining for the class op.
1644 This is weird, so I'm not worried about whether this optimises brilliantly; but
1645 it should not fall over.
1646 -}
1647
1648 argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
1649 -- See Note [Computing one-shot info, and ProbOneShot]
1650 argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
1651 = go arg_ds
1652 where
1653 unsaturated_call = arg_ds `lengthExceeds` n_val_args
1654 good_one_shot
1655 | unsaturated_call = ProbOneShot
1656 | otherwise = OneShotLam
1657
1658 go [] = []
1659 go (arg_d : arg_ds) = argOneShots good_one_shot arg_d `cons` go arg_ds
1660
1661 -- Avoid list tail like [ [], [], [] ]
1662 cons [] [] = []
1663 cons a as = a:as
1664
1665 argOneShots :: OneShotInfo -> JointDmd -> [OneShotInfo]
1666 argOneShots one_shot_info (JD { absd = usg })
1667 = case usg of
1668 Use _ arg_usg -> go arg_usg
1669 _ -> []
1670 where
1671 go (UCall One u) = one_shot_info : go u
1672 go (UCall Many u) = NoOneShotInfo : go u
1673 go _ = []
1674
1675 {- Note [Computing one-shot info, and ProbOneShot]
1676 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1677 Consider a call
1678 f (\pqr. e1) (\xyz. e2) e3
1679 where f has usage signature
1680 C1(C(C1(U))) C1(U) U
1681 Then argsOneShots returns a [[OneShotInfo]] of
1682 [[OneShot,NoOneShotInfo,OneShot], [OneShot]]
1683 The occurrence analyser propagates this one-shot infor to the
1684 binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal.
1685
1686 But suppose f was not saturated, so the call looks like
1687 f (\pqr. e1) (\xyz. e2)
1688 The in principle this partial application might be shared, and
1689 the (\prq.e1) abstraction might be called more than once. So
1690 we can't mark them OneShot. But instead we return
1691 [[ProbOneShot,NoOneShotInfo,ProbOneShot], [ProbOneShot]]
1692 The occurrence analyser propagates this to the \pqr and \xyz
1693 binders.
1694
1695 How is it used? Well, it's quite likely that the partial application
1696 of f is not shared, so the float-out pass (in SetLevels.lvlLamBndrs)
1697 does not float MFEs out of a ProbOneShot lambda. That currently is
1698 the only way that ProbOneShot is used.
1699 -}
1700
1701 -- appIsBottom returns true if an application to n args would diverge
1702 -- See Note [Unsaturated applications]
1703 appIsBottom :: StrictSig -> Int -> Bool
1704 appIsBottom (StrictSig (DmdType _ ds res)) n
1705 | isBotRes res = not $ lengthExceeds ds n
1706 appIsBottom _ _ = False
1707
1708 {-
1709 Note [Unsaturated applications]
1710 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1711 If a function having bottom as its demand result is applied to a less
1712 number of arguments than its syntactic arity, we cannot say for sure
1713 that it is going to diverge. This is the reason why we use the
1714 function appIsBottom, which, given a strictness signature and a number
1715 of arguments, says conservatively if the function is going to diverge
1716 or not.
1717
1718 Zap absence or one-shot information, under control of flags
1719
1720 Note [Killing usage information]
1721 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1722 The flags -fkill-one-shot and -fkill-absence let you switch off the generation
1723 of absence or one-shot information altogether. This is only used for performance
1724 tests, to see how important they are.
1725 -}
1726
1727 zapUsageDemand :: Demand -> Demand
1728 -- Remove the usage info, but not the strictness info, from the demand
1729 zapUsageDemand = kill_usage (True, True)
1730
1731 killUsageDemand :: DynFlags -> Demand -> Demand
1732 -- See Note [Killing usage information]
1733 killUsageDemand dflags dmd
1734 | Just kfs <- killFlags dflags = kill_usage kfs dmd
1735 | otherwise = dmd
1736
1737 killUsageSig :: DynFlags -> StrictSig -> StrictSig
1738 -- See Note [Killing usage information]
1739 killUsageSig dflags sig@(StrictSig (DmdType env ds r))
1740 | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)
1741 | otherwise = sig
1742
1743 type KillFlags = (Bool, Bool)
1744
1745 killFlags :: DynFlags -> Maybe KillFlags
1746 -- See Note [Killing usage information]
1747 killFlags dflags
1748 | not kill_abs && not kill_one_shot = Nothing
1749 | otherwise = Just (kill_abs, kill_one_shot)
1750 where
1751 kill_abs = gopt Opt_KillAbsence dflags
1752 kill_one_shot = gopt Opt_KillOneShot dflags
1753
1754 kill_usage :: KillFlags -> Demand -> Demand
1755 kill_usage kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
1756
1757 zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed
1758 zap_musg (kill_abs, _) Abs
1759 | kill_abs = useTop
1760 | otherwise = Abs
1761 zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u)
1762
1763 zap_count :: KillFlags -> Count -> Count
1764 zap_count (_, kill_one_shot) c
1765 | kill_one_shot = Many
1766 | otherwise = c
1767
1768 zap_usg :: KillFlags -> UseDmd -> UseDmd
1769 zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u)
1770 zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us)
1771 zap_usg _ u = u
1772
1773 -- If the argument is a used non-newtype dictionary, give it strict
1774 -- demand. Also split the product type & demand and recur in order to
1775 -- similarly strictify the argument's contained used non-newtype
1776 -- superclass dictionaries. We use the demand as our recursive measure
1777 -- to guarantee termination.
1778 strictifyDictDmd :: Type -> Demand -> Demand
1779 strictifyDictDmd ty dmd = case absd dmd of
1780 Use n _ |
1781 Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
1782 <- splitDataProductType_maybe ty,
1783 not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
1784 -> seqDmd `bothDmd` -- main idea: ensure it's strict
1785 case splitProdDmd_maybe dmd of
1786 -- superclass cycles should not be a problem, since the demand we are
1787 -- consuming would also have to be infinite in order for us to diverge
1788 Nothing -> dmd -- no components have interesting demand, so stop
1789 -- looking for superclass dicts
1790 Just dmds
1791 | all (not . isAbsDmd) dmds -> evalDmd
1792 -- abstract to strict w/ arbitrary component use, since this
1793 -- smells like reboxing; results in CBV boxed
1794 --
1795 -- TODO revisit this if we ever do boxity analysis
1796 | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of
1797 CD {sd = s,ud = a} -> JD (Str s) (Use n a)
1798 -- TODO could optimize with an aborting variant of zipWith since
1799 -- the superclass dicts are always a prefix
1800 _ -> dmd -- unused or not a dictionary
1801
1802 {-
1803 Note [HyperStr and Use demands]
1804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1805
1806 The information "HyperStr" needs to be in the strictness signature, and not in
1807 the demand signature, because we still want to know about the demand on things. Consider
1808
1809 f (x,y) True = error (show x)
1810 f (x,y) False = x+1
1811
1812 The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not
1813 distinguishing the uses on x and y in the True case, we could either not figure
1814 out how deeply we can unpack x, or that we do not have to pass y.
1815
1816
1817 ************************************************************************
1818 * *
1819 Serialisation
1820 * *
1821 ************************************************************************
1822 -}
1823
1824 instance Binary StrDmd where
1825 put_ bh HyperStr = do putByte bh 0
1826 put_ bh HeadStr = do putByte bh 1
1827 put_ bh (SCall s) = do putByte bh 2
1828 put_ bh s
1829 put_ bh (SProd sx) = do putByte bh 3
1830 put_ bh sx
1831 get bh = do
1832 h <- getByte bh
1833 case h of
1834 0 -> do return HyperStr
1835 1 -> do return HeadStr
1836 2 -> do s <- get bh
1837 return (SCall s)
1838 _ -> do sx <- get bh
1839 return (SProd sx)
1840
1841 instance Binary MaybeStr where
1842 put_ bh Lazy = do
1843 putByte bh 0
1844 put_ bh (Str s) = do
1845 putByte bh 1
1846 put_ bh s
1847
1848 get bh = do
1849 h <- getByte bh
1850 case h of
1851 0 -> return Lazy
1852 _ -> do s <- get bh
1853 return $ Str s
1854
1855 instance Binary Count where
1856 put_ bh One = do putByte bh 0
1857 put_ bh Many = do putByte bh 1
1858
1859 get bh = do h <- getByte bh
1860 case h of
1861 0 -> return One
1862 _ -> return Many
1863
1864 instance Binary MaybeUsed where
1865 put_ bh Abs = do
1866 putByte bh 0
1867 put_ bh (Use c u) = do
1868 putByte bh 1
1869 put_ bh c
1870 put_ bh u
1871
1872 get bh = do
1873 h <- getByte bh
1874 case h of
1875 0 -> return Abs
1876 _ -> do c <- get bh
1877 u <- get bh
1878 return $ Use c u
1879
1880 instance Binary UseDmd where
1881 put_ bh Used = do
1882 putByte bh 0
1883 put_ bh UHead = do
1884 putByte bh 1
1885 put_ bh (UCall c u) = do
1886 putByte bh 2
1887 put_ bh c
1888 put_ bh u
1889 put_ bh (UProd ux) = do
1890 putByte bh 3
1891 put_ bh ux
1892
1893 get bh = do
1894 h <- getByte bh
1895 case h of
1896 0 -> return $ Used
1897 1 -> return $ UHead
1898 2 -> do c <- get bh
1899 u <- get bh
1900 return (UCall c u)
1901 _ -> do ux <- get bh
1902 return (UProd ux)
1903
1904 instance Binary JointDmd where
1905 put_ bh (JD {strd = x, absd = y}) = do put_ bh x; put_ bh y
1906 get bh = do
1907 x <- get bh
1908 y <- get bh
1909 return $ mkJointDmd x y
1910
1911 instance Binary StrictSig where
1912 put_ bh (StrictSig aa) = do
1913 put_ bh aa
1914 get bh = do
1915 aa <- get bh
1916 return (StrictSig aa)
1917
1918 instance Binary DmdType where
1919 -- Ignore DmdEnv when spitting out the DmdType
1920 put_ bh (DmdType _ ds dr)
1921 = do put_ bh ds
1922 put_ bh dr
1923 get bh
1924 = do ds <- get bh
1925 dr <- get bh
1926 return (DmdType emptyDmdEnv ds dr)
1927
1928 instance Binary DmdResult where
1929 put_ bh (Dunno c) = do { putByte bh 0; put_ bh c }
1930 put_ bh Diverges = putByte bh 2
1931
1932 get bh = do { h <- getByte bh
1933 ; case h of
1934 0 -> do { c <- get bh; return (Dunno c) }
1935 _ -> return Diverges }
1936
1937 instance Binary CPRResult where
1938 put_ bh (RetSum n) = do { putByte bh 0; put_ bh n }
1939 put_ bh RetProd = putByte bh 1
1940 put_ bh NoCPR = putByte bh 2
1941
1942 get bh = do
1943 h <- getByte bh
1944 case h of
1945 0 -> do { n <- get bh; return (RetSum n) }
1946 1 -> return RetProd
1947 _ -> return NoCPR