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