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