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