Do not forget CPR information after an IO action
[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, deferAfterIO, 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 -- When e is evaluated after executing an IO action, and d is e's demand, then
1090 -- what of this demand should we consider, given that the IO action can cleanly
1091 -- exit?
1092 -- * We have to kill all strictness demands (i.e. lub with a lazy demand)
1093 -- * We can keep demand information (i.e. lub with an absent deman)
1094 -- * We have to kill definite divergence
1095 -- * We can keep CPR information.
1096 -- See Note [IO hack in the demand analyser]
1097 deferAfterIO :: DmdType -> DmdType
1098 deferAfterIO d@(DmdType _ _ res) =
1099     case d `lubDmdType` topDmdType of
1100         DmdType fv ds _ -> DmdType fv ds (defer_res res)
1101   where
1102   defer_res BotCPR  = NoCPR
1103   defer_res r       = r
1104
1105
1106 modifyEnv :: Bool                       -- No-op if False
1107           -> (Demand -> Demand)         -- The zapper
1108           -> DmdEnv -> DmdEnv           -- Env1 and Env2
1109           -> DmdEnv -> DmdEnv           -- Transform this env
1110         -- Zap anything in Env1 but not in Env2
1111         -- Assume: dom(env) includes dom(Env1) and dom(Env2)
1112 modifyEnv need_to_modify zapper env1 env2 env
1113   | need_to_modify = foldr zap env (varEnvKeys (env1 `minusUFM` env2))
1114   | otherwise      = env
1115   where
1116     zap uniq env = addToUFM_Directly env uniq (zapper current_val)
1117                  where
1118                    current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
1119
1120 strictenDmd :: JointDmd -> CleanDemand
1121 strictenDmd (JD {strd = s, absd = u})
1122   = CD { sd = poke_s s, ud = poke_u u }
1123   where
1124     poke_s Lazy      = HeadStr
1125     poke_s (Str s)   = s
1126     poke_u Abs       = UHead
1127     poke_u (Use _ u) = u
1128
1129 toCleanDmd :: (CleanDemand -> e -> (DmdType, e))
1130            -> Demand
1131            -> e -> (DmdType, e)
1132 -- See Note [Analyzing with lazy demand and lambdas]
1133 toCleanDmd anal (JD { strd = s, absd = u }) e
1134   = case (s,u) of
1135       (_, Abs) -> mf (const topDmdType) (anal (CD { sd = HeadStr, ud = Used }) e)
1136                   --  See Note [Always analyse in virgin pass]
1137              
1138       (Str s', Use c u') -> mf (deferAndUse False c) (anal (CD { sd = s',      ud = u' }) e)
1139       (Lazy,   Use c u') -> mf (deferAndUse True c)  (anal (CD { sd = HeadStr, ud = u' }) e)
1140   where
1141     mf f (a,b) = (f a, b)
1142 \end{code}
1143
1144 Note [Always analyse in virgin pass]
1145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1146 Tricky point: make sure that we analyse in the 'virgin' pass. Consider
1147    rec { f acc x True  = f (...rec { g y = ...g... }...)
1148          f acc x False = acc }
1149 In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
1150 That might mean that we analyse the sub-expression containing the 
1151 E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*
1152 E, but just retuned botType.  
1153
1154 Then in the *next* (non-virgin) iteration for 'f', we might analyse E
1155 in a weaker demand, and that will trigger doing a fixpoint iteration
1156 for g.  But *because it's not the virgin pass* we won't start g's
1157 iteration at bottom.  Disaster.  (This happened in $sfibToList' of 
1158 nofib/spectral/fibheaps.)
1159
1160 So in the virgin pass we make sure that we do analyse the expression
1161 at least once, to initialise its signatures.
1162
1163 Note [Analyzing with lazy demand and lambdas]
1164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1165 The insight for analyzing lambdas follows from the fact that for
1166 strictness S = C(L). This polymorphic expansion is critical for
1167 cardinality analysis of the following example:
1168
1169 {-# NOINLINE build #-}
1170 build g = (g (:) [], g (:) [])
1171
1172 h c z = build (\x -> 
1173                 let z1 = z ++ z 
1174                  in if c
1175                     then \y -> x (y ++ z1)
1176                     else \y -> x (z1 ++ y))
1177
1178 One can see that `build` assigns to `g` demand <L,C(C1(U))>. 
1179 Therefore, when analyzing the lambda `(\x -> ...)`, we
1180 expect each lambda \y -> ... to be annotated as "one-shot"
1181 one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a
1182 demand <C(C(..), C(C1(U))>.
1183
1184 This is achieved by, first, converting the lazy demand L into the
1185 strict S by the second clause of the analysis.
1186
1187 %************************************************************************
1188 %*                                                                      *
1189                      Demand signatures
1190 %*                                                                      *
1191 %************************************************************************
1192
1193 In a let-bound Id we record its strictness info.  
1194 In principle, this strictness info is a demand transformer, mapping
1195 a demand on the Id into a DmdType, which gives
1196         a) the free vars of the Id's value
1197         b) the Id's arguments
1198         c) an indication of the result of applying 
1199            the Id to its arguments
1200
1201 However, in fact we store in the Id an extremely emascuated demand
1202 transfomer, namely
1203
1204                 a single DmdType
1205 (Nevertheless we dignify StrictSig as a distinct type.)
1206
1207 This DmdType gives the demands unleashed by the Id when it is applied
1208 to as many arguments as are given in by the arg demands in the DmdType.
1209
1210 If an Id is applied to less arguments than its arity, it means that
1211 the demand on the function at a call site is weaker than the vanilla
1212 call demand, used for signature inference. Therefore we place a top
1213 demand on all arguments. Otherwise, the demand is specified by Id's
1214 signature.
1215
1216 For example, the demand transformer described by the DmdType
1217                 DmdType {x -> <S(LL),U(UU)>} [V,A] Top
1218 says that when the function is applied to two arguments, it
1219 unleashes demand <S(LL),U(UU)> on the free var x, V on the first arg,
1220 and A on the second.  
1221
1222 If this same function is applied to one arg, all we can say is that it
1223 uses x with <L,U>, and its arg with demand <L,U>.
1224
1225 \begin{code}
1226 newtype StrictSig = StrictSig DmdType
1227                   deriving( Eq )
1228
1229 instance Outputable StrictSig where
1230    ppr (StrictSig ty) = ppr ty
1231
1232 mkStrictSig :: DmdType -> StrictSig
1233 mkStrictSig dmd_ty = StrictSig dmd_ty
1234
1235 splitStrictSig :: StrictSig -> ([Demand], DmdResult)
1236 splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
1237
1238 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
1239 -- Add extra arguments to a strictness signature
1240 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
1241   = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
1242
1243 isTopSig :: StrictSig -> Bool
1244 isTopSig (StrictSig ty) = isTopDmdType ty
1245
1246 isBottomingSig :: StrictSig -> Bool
1247 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
1248
1249 topSig, botSig :: StrictSig
1250 topSig = StrictSig topDmdType
1251 botSig = StrictSig botDmdType
1252
1253 cprProdSig :: StrictSig
1254 cprProdSig = StrictSig cprProdDmdType
1255
1256 argsOneShots :: StrictSig -> Arity -> [[Bool]]
1257 argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
1258   | arg_ds `lengthExceeds` n_val_args
1259   = []   -- Too few arguments
1260   | otherwise
1261   = go arg_ds
1262   where
1263     go []               = []
1264     go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds
1265     
1266     cons [] [] = []
1267     cons a  as = a:as
1268
1269 argOneShots :: JointDmd -> [Bool]
1270 argOneShots (JD { absd = usg })
1271   = case usg of
1272       Use _ arg_usg -> go arg_usg
1273       _             -> []
1274   where
1275     go (UCall One  u) = True  : go u
1276     go (UCall Many u) = False : go u
1277     go _              = []
1278
1279 dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
1280 -- (dmdTransformSig fun_sig dmd) considers a call to a function whose
1281 -- signature is fun_sig, with demand dmd.  We return the demand
1282 -- that the function places on its context (eg its args)
1283 dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) 
1284                 (CD { sd = str, ud = abs })
1285   = dmd_ty2
1286   where
1287     dmd_ty1 | str_sat   = dmd_ty
1288             | otherwise = deferType dmd_ty
1289     dmd_ty2 | abs_sat   = dmd_ty1
1290             | otherwise = useType dmd_ty1
1291
1292     str_sat = go_str arg_ds str
1293     abs_sat = go_abs arg_ds abs
1294
1295     go_str [] _              = True
1296     go_str (_:_)  HyperStr   = True         -- HyperStr = Call(HyperStr)
1297     go_str (_:as) (SCall d') = go_str as d'
1298     go_str _      _          = False
1299
1300     go_abs []      _             = True
1301     go_abs (_:as) (UCall One d') = go_abs as d'
1302     go_abs _      _              = False
1303
1304     -- NB: it's important to use deferType, and not just return topDmdType
1305     -- Consider     let { f x y = p + x } in f 1
1306     -- The application isn't saturated, but we must nevertheless propagate 
1307     --      a lazy demand for p!  
1308
1309 dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
1310 -- Same as dmdTranformSig but for a data constructor (worker), 
1311 -- which has a special kind of demand transformer.
1312 -- If the constructor is saturated, we feed the demand on 
1313 -- the result into the constructor arguments.
1314 dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) 
1315                              (CD { sd = str, ud = abs })
1316   | Just str_dmds <- go_str arity str
1317   , Just abs_dmds <- go_abs arity abs
1318   = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res
1319                 -- Must remember whether it's a product, hence con_res, not TopRes
1320
1321   | otherwise   -- Not saturated
1322   = topDmdType
1323   where
1324     go_str 0 dmd        = Just (splitStrProdDmd arity dmd)
1325     go_str n (SCall s') = go_str (n-1) s'
1326     go_str _ _          = Nothing
1327    
1328     go_abs 0 dmd            = Just (splitUseProdDmd arity dmd)
1329     go_abs n (UCall One u') = go_abs (n-1) u'
1330     go_abs _ _              = Nothing
1331
1332 dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
1333 -- Like dmdTransformDataConSig, we have a special demand transformer
1334 -- for dictionary selectors.  If the selector is saturated (ie has one
1335 -- argument: the dictionary), we feed the demand on the result into
1336 -- the indicated dictionary component.
1337 dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd
1338    | (cd',defer,_) <- peelCallDmd cd
1339    , not defer
1340    , Just jds <- splitProdDmd_maybe dict_dmd
1341    = DmdType emptyDmdEnv [mkManyUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes
1342    | otherwise
1343    = topDmdType              -- See Note [Demand transformer for a dictionary selector]
1344   where
1345     enhance cd old | isAbsDmd old = old
1346                    | otherwise    = mkManyUsedDmd cd
1347
1348 dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"
1349 \end{code}
1350
1351 Note [Demand transformer for a dictionary selector]
1352 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1353 If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'
1354 into the appropriate field of the dictionary. What *is* the appropriate field?
1355 We just look at the strictness signature of the class op, which will be
1356 something like: U(AAASAAAAA).  Then replace the 'S' by the demand 'd'.
1357
1358 For single-method classes, which are represented by newtypes the signature 
1359 of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.
1360 That's fine: if we are doing strictness analysis we are also doing inling,
1361 so we'll have inlined 'op' into a cast.  So we can bale out in a conservative
1362 way, returning topDmdType.
1363
1364 It is (just.. Trac #8329) possible to be running strictness analysis *without*
1365 having inlined class ops from single-method classes.  Suppose you are using
1366 ghc --make; and the first module has a local -O0 flag.  So you may load a class
1367 without interface pragmas, ie (currently) without an unfolding for the class
1368 ops.   Now if a subsequent module in the --make sweep has a local -O flag
1369 you might do strictness analysis, but there is no inlining for the class op.
1370 This is weird, so I'm not worried about whether this optimises brilliantly; but
1371 it should not fall over.
1372
1373 Note [Non-full application] 
1374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
1375 If a function having bottom as its demand result is applied to a less
1376 number of arguments than its syntactic arity, we cannot say for sure
1377 that it is going to diverge. This is the reason why we use the
1378 function appIsBottom, which, given a strictness signature and a number
1379 of arguments, says conservatively if the function is going to diverge
1380 or not.
1381
1382 \begin{code}
1383 -- appIsBottom returns true if an application to n args would diverge
1384 appIsBottom :: StrictSig -> Int -> Bool
1385 appIsBottom (StrictSig (DmdType _ ds res)) n
1386             | isBotRes res                      = not $ lengthExceeds ds n 
1387 appIsBottom _                                 _ = False
1388
1389 seqStrictSig :: StrictSig -> ()
1390 seqStrictSig (StrictSig ty) = seqDmdType ty
1391
1392 -- Used for printing top-level strictness pragmas in interface files
1393 pprIfaceStrictSig :: StrictSig -> SDoc
1394 pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
1395   = hcat (map ppr dmds) <> ppr res
1396 \end{code}
1397
1398 Zap absence or one-shot information, under control of flags
1399
1400 \begin{code}
1401 zapDemand :: DynFlags -> Demand -> Demand
1402 zapDemand dflags dmd 
1403   | Just kfs <- killFlags dflags = zap_dmd kfs dmd
1404   | otherwise                    = dmd
1405
1406 zapStrictSig :: DynFlags -> StrictSig -> StrictSig
1407 zapStrictSig dflags sig@(StrictSig (DmdType env ds r)) 
1408   | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (zap_dmd kfs) ds) r)
1409   | otherwise                    = sig
1410
1411 type KillFlags = (Bool, Bool)
1412
1413 killFlags :: DynFlags -> Maybe KillFlags
1414 killFlags dflags 
1415   | not kill_abs && not kill_one_shot = Nothing
1416   | otherwise                         = Just (kill_abs, kill_one_shot)
1417   where
1418     kill_abs      = gopt Opt_KillAbsence dflags
1419     kill_one_shot = gopt Opt_KillOneShot dflags
1420       
1421 zap_dmd :: KillFlags -> Demand -> Demand
1422 zap_dmd kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
1423
1424 zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed
1425 zap_musg (kill_abs, _) Abs 
1426   | kill_abs  = useTop
1427   | otherwise = Abs
1428 zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u)
1429
1430 zap_count :: KillFlags -> Count -> Count
1431 zap_count (_, kill_one_shot) c
1432   | kill_one_shot = Many
1433   | otherwise     = c
1434
1435 zap_usg :: KillFlags -> UseDmd -> UseDmd
1436 zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u)
1437 zap_usg kfs (UProd us)  = UProd (map (zap_musg kfs) us)
1438 zap_usg _   u           = u
1439 \end{code}
1440
1441 \begin{code}
1442 -- If the argument is a used non-newtype dictionary, give it strict
1443 -- demand. Also split the product type & demand and recur in order to
1444 -- similarly strictify the argument's contained used non-newtype
1445 -- superclass dictionaries. We use the demand as our recursive measure
1446 -- to guarantee termination.
1447 strictifyDictDmd :: Type -> Demand -> Demand
1448 strictifyDictDmd ty dmd = case absd dmd of
1449   Use n _ |
1450     Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
1451       <- splitDataProductType_maybe ty,
1452     not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
1453     -> seqDmd `bothDmd` -- main idea: ensure it's strict
1454        case splitProdDmd_maybe dmd of
1455          -- superclass cycles should not be a problem, since the demand we are
1456          -- consuming would also have to be infinite in order for us to diverge
1457          Nothing -> dmd -- no components have interesting demand, so stop
1458                         -- looking for superclass dicts
1459          Just dmds
1460            | all (not . isAbsDmd) dmds -> evalDmd
1461              -- abstract to strict w/ arbitrary component use, since this
1462              -- smells like reboxing; results in CBV boxed
1463              --
1464              -- TODO revisit this if we ever do boxity analysis
1465            | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of
1466                CD {sd = s,ud = a} -> JD (Str s) (Use n a)
1467              -- TODO could optimize with an aborting variant of zipWith since
1468              -- the superclass dicts are always a prefix
1469   _ -> dmd -- unused or not a dictionary
1470 \end{code}
1471
1472 Note [HyperStr and Use demands]
1473 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1474
1475 The information "HyperStr" needs to be in the strictness signature, and not in
1476 the demand signature, because we still want to know about the demand on things. Consider
1477
1478     f (x,y) True  = error (show x)
1479     f (x,y) False = x+1
1480
1481 The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not
1482 distinguishing the uses on x and y in the True case, we could either not figure
1483 out how deeply we can unpack x, or that we do not have to pass y.
1484
1485
1486 %************************************************************************
1487 %*                                                                      *
1488                      Serialisation
1489 %*                                                                      *
1490 %************************************************************************
1491
1492
1493 \begin{code}
1494 instance Binary StrDmd where
1495   put_ bh HyperStr     = do putByte bh 0
1496   put_ bh HeadStr      = do putByte bh 1
1497   put_ bh (SCall s)    = do putByte bh 2
1498                             put_ bh s
1499   put_ bh (SProd sx)   = do putByte bh 3
1500                             put_ bh sx  
1501   get bh = do 
1502          h <- getByte bh
1503          case h of
1504            0 -> do return HyperStr
1505            1 -> do return HeadStr
1506            2 -> do s  <- get bh
1507                    return (SCall s)
1508            _ -> do sx <- get bh
1509                    return (SProd sx)
1510
1511 instance Binary MaybeStr where
1512     put_ bh Lazy         = do 
1513             putByte bh 0
1514     put_ bh (Str s)    = do 
1515             putByte bh 1
1516             put_ bh s
1517
1518     get  bh = do
1519             h <- getByte bh
1520             case h of 
1521               0 -> return Lazy
1522               _ -> do s  <- get bh
1523                       return $ Str s
1524
1525 instance Binary Count where
1526     put_ bh One  = do putByte bh 0
1527     put_ bh Many = do putByte bh 1
1528     
1529     get  bh = do h <- getByte bh
1530                  case h of
1531                    0 -> return One
1532                    _ -> return Many   
1533
1534 instance Binary MaybeUsed where
1535     put_ bh Abs          = do 
1536             putByte bh 0
1537     put_ bh (Use c u)    = do 
1538             putByte bh 1
1539             put_ bh c
1540             put_ bh u
1541
1542     get  bh = do
1543             h <- getByte bh
1544             case h of 
1545               0 -> return Abs       
1546               _ -> do c  <- get bh
1547                       u  <- get bh
1548                       return $ Use c u
1549
1550 instance Binary UseDmd where
1551     put_ bh Used         = do 
1552             putByte bh 0
1553     put_ bh UHead        = do 
1554             putByte bh 1
1555     put_ bh (UCall c u)    = do
1556             putByte bh 2
1557             put_ bh c
1558             put_ bh u
1559     put_ bh (UProd ux)   = do
1560             putByte bh 3
1561             put_ bh ux
1562
1563     get  bh = do
1564             h <- getByte bh
1565             case h of 
1566               0 -> return $ Used
1567               1 -> return $ UHead
1568               2 -> do c <- get bh
1569                       u <- get bh
1570                       return (UCall c u)
1571               _ -> do ux <- get bh
1572                       return (UProd ux)
1573
1574 instance Binary JointDmd where
1575     put_ bh (JD {strd = x, absd = y}) = do put_ bh x; put_ bh y
1576     get  bh = do 
1577               x <- get bh
1578               y <- get bh
1579               return $ mkJointDmd x y
1580
1581 instance Binary StrictSig where
1582     put_ bh (StrictSig aa) = do
1583             put_ bh aa
1584     get bh = do
1585           aa <- get bh
1586           return (StrictSig aa)
1587
1588 instance Binary DmdType where
1589   -- Ignore DmdEnv when spitting out the DmdType
1590   put_ bh (DmdType _ ds dr) 
1591        = do put_ bh ds 
1592             put_ bh dr
1593   get bh 
1594       = do ds <- get bh 
1595            dr <- get bh 
1596            return (DmdType emptyDmdEnv ds dr)
1597
1598 instance Binary CPRResult where
1599     put_ bh (RetSum n)   = do { putByte bh 0; put_ bh n }
1600     put_ bh RetProd      = putByte bh 1
1601     put_ bh NoCPR        = putByte bh 2
1602     put_ bh BotCPR       = putByte bh 3
1603
1604     get  bh = do
1605             h <- getByte bh
1606             case h of 
1607               0 -> do { n <- get bh; return (RetSum n) }
1608               1 -> return RetProd
1609               2 -> return NoCPR
1610               _ -> return BotCPR
1611 \end{code}