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