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