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