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