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