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