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