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