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