27d9112733f286552c3e34973485ecea1dac411f
[ghc.git] / compiler / stranal / DmdAnal.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4
5                         -----------------
6                         A demand analysis
7                         -----------------
8
9 \begin{code}
10 {-# OPTIONS -fno-warn-tabs #-}
11
12 module DmdAnal ( dmdAnalProgram ) where
13
14 #include "HsVersions.h"
15
16 import Var              ( isTyVar )
17 import DynFlags
18 import WwLib            ( deepSplitProductType_maybe )
19 import Demand   -- All of it
20 import CoreSyn
21 import Outputable
22 import VarEnv
23 import BasicTypes       
24 import FastString
25 import Data.List
26 import DataCon
27 import Id
28 import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial )
29 -- import PprCore       
30 import TyCon
31 import Type             ( eqType )
32 -- import Pair
33 -- import Coercion         ( coercionKind )
34 import Util
35 import Maybes           ( isJust, orElse )
36 import TysWiredIn       ( unboxedPairDataCon )
37 import TysPrim          ( realWorldStatePrimTy )
38 import ErrUtils         ( dumpIfSet_dyn )
39 import Name             ( getName, stableNameCmp )
40 import Data.Function    ( on )
41 \end{code}
42
43 %************************************************************************
44 %*                                                                      *
45 \subsection{Top level stuff}
46 %*                                                                      *
47 %************************************************************************
48
49 \begin{code}
50 dmdAnalProgram :: DynFlags -> CoreProgram -> IO CoreProgram
51 dmdAnalProgram dflags binds
52   = do {
53         let { binds_plus_dmds = do_prog binds } ;
54         dumpIfSet_dyn dflags Opt_D_dump_strsigs "Strictness signatures" $
55             dumpStrSig binds_plus_dmds ;
56         return binds_plus_dmds
57     }
58   where
59     do_prog :: CoreProgram -> CoreProgram
60     do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags) binds
61
62 -- Analyse a (group of) top-level binding(s)
63 dmdAnalTopBind :: AnalEnv
64                -> CoreBind 
65                -> (AnalEnv, CoreBind)
66 dmdAnalTopBind sigs (NonRec id rhs)
67   = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2)
68   where
69     (  _, _, _,   rhs1) = dmdAnalRhs TopLevel Nothing sigs             id rhs
70     (sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1
71         -- Do two passes to improve CPR information
72         -- See comments with ignore_cpr_info in mk_sig_ty
73         -- and with extendSigsWithLam
74
75 dmdAnalTopBind sigs (Rec pairs)
76   = (sigs', Rec pairs')
77   where
78     (sigs', _, pairs')  = dmdFix TopLevel sigs pairs
79                 -- We get two iterations automatically
80                 -- c.f. the NonRec case above
81 \end{code}
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection{The analyser itself}        
86 %*                                                                      *
87 %************************************************************************
88
89 Note [Ensure demand is strict]
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
91 It's important not to analyse e with a lazy demand because
92 a) When we encounter   case s of (a,b) -> 
93         we demand s with U(d1d2)... but if the overall demand is lazy
94         that is wrong, and we'd need to reduce the demand on s,
95         which is inconvenient
96 b) More important, consider
97         f (let x = R in x+x), where f is lazy
98    We still want to mark x as demanded, because it will be when we
99    enter the let.  If we analyse f's arg with a Lazy demand, we'll
100    just mark x as Lazy
101 c) The application rule wouldn't be right either
102    Evaluating (f x) in a L demand does *not* cause
103    evaluation of f in a C(L) demand!
104
105 \begin{code}
106 dmdAnalArg :: AnalEnv 
107            -> Demand    -- This one takes a *Demand*
108            -> CoreExpr -> (DmdType, CoreExpr)
109 -- Used for function arguments
110 dmdAnalArg env dmd e
111   | exprIsTrivial e = dmdAnalStar env dmd e
112   | otherwise       = dmdAnalStar env (oneifyDmd dmd) e
113
114 -- Do not process absent demands
115 -- Otherwise act like in a normal demand analysis
116 -- See |-* relation in the companion paper
117 dmdAnalStar :: AnalEnv 
118             -> Demand   -- This one takes a *Demand*
119             -> CoreExpr -> (DmdType, CoreExpr)
120 dmdAnalStar env dmd e 
121   | (cd, defer_and_use) <- toCleanDmd dmd
122   , (dmd_ty, e')        <- dmdAnal env cd e
123   = (postProcessDmdTypeM defer_and_use dmd_ty, e')
124
125 -- Main Demand Analsysis machinery
126 dmdAnal :: AnalEnv
127         -> CleanDemand         -- The main one takes a *CleanDemand*
128         -> CoreExpr -> (DmdType, CoreExpr)
129
130 -- The CleanDemand is always strict and not absent
131 --    See Note [Ensure demand is strict]
132
133 dmdAnal _ _ (Lit lit)     = (nopDmdType, Lit lit)
134 dmdAnal _ _ (Type ty)     = (nopDmdType, Type ty)       -- Doesn't happen, in fact
135 dmdAnal _ _ (Coercion co) = (nopDmdType, Coercion co)
136
137 dmdAnal env dmd (Var var)
138   = (dmdTransform env var dmd, Var var)
139
140 dmdAnal env dmd (Cast e co)
141   = (dmd_ty, Cast e' co)
142   where
143     (dmd_ty, e') = dmdAnal env dmd e
144
145 {-       ----- I don't get this, so commenting out -------
146     to_co        = pSnd (coercionKind co)
147     dmd'
148       | Just tc <- tyConAppTyCon_maybe to_co
149       , isRecursiveTyCon tc = cleanEvalDmd
150       | otherwise           = dmd
151         -- This coerce usually arises from a recursive
152         -- newtype, and we don't want to look inside them
153         -- for exactly the same reason that we don't look
154         -- inside recursive products -- we might not reach
155         -- a fixpoint.  So revert to a vanilla Eval demand
156 -}
157
158 dmdAnal env dmd (Tick t e)
159   = (dmd_ty, Tick t e')
160   where
161     (dmd_ty, e') = dmdAnal env dmd e
162
163 dmdAnal env dmd (App fun (Type ty))
164   = (fun_ty, App fun' (Type ty))
165   where
166     (fun_ty, fun') = dmdAnal env dmd fun
167
168 dmdAnal sigs dmd (App fun (Coercion co))
169   = (fun_ty, App fun' (Coercion co))
170   where
171     (fun_ty, fun') = dmdAnal sigs dmd fun
172
173 -- Lots of the other code is there to make this
174 -- beautiful, compositional, application rule :-)
175 dmdAnal env dmd (App fun arg)   -- Non-type arguments
176   = let                         -- [Type arg handled above]
177         call_dmd          = mkCallDmd dmd
178         (fun_ty, fun')    = dmdAnal env call_dmd fun
179         (arg_dmd, res_ty) = splitDmdTy fun_ty
180         (arg_ty, arg')    = dmdAnalArg env arg_dmd arg
181     in
182 --    pprTrace "dmdAnal:app" (vcat
183 --         [ text "dmd =" <+> ppr dmd
184 --         , text "expr =" <+> ppr (App fun arg)
185 --         , text "fun dmd_ty =" <+> ppr fun_ty
186 --         , text "arg dmd =" <+> ppr arg_dmd
187 --         , text "arg dmd_ty =" <+> ppr arg_ty
188 --         , text "res dmd_ty =" <+> ppr res_ty
189 --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
190     (res_ty `bothDmdType` arg_ty, App fun' arg')
191
192 -- this is an anonymous lambda, since @dmdAnalRhs@ uses @collectBinders@
193 dmdAnal env dmd (Lam var body)
194   | isTyVar var
195   = let 
196         (body_ty, body') = dmdAnal env dmd body
197     in
198     (body_ty, Lam var body')
199
200   | otherwise
201   = let (body_dmd, defer_and_use@(_,one_shot)) = peelCallDmd dmd
202           -- body_dmd  - a demand to analyze the body
203           -- one_shot  - one-shotness of the lambda
204           --             hence, cardinality of its free vars
205
206         env'             = extendSigsWithLam env var
207         (body_ty, body') = dmdAnal env' body_dmd body
208         (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty one_shot var
209     in
210     (postProcessDmdType defer_and_use lam_ty, Lam var' body')
211
212 dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
213   -- Only one alternative with a product constructor
214   | let tycon = dataConTyCon dc
215   , isProductTyCon tycon 
216   , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
217   = let
218         env_w_tc              = env { ae_rec_tc = rec_tc' }
219         env_alt               = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig
220         (alt_ty, alt')        = dmdAnalAlt env_alt dmd alt
221         (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr
222         (_, bndrs', _)        = alt'
223         case_bndr_sig         = cprProdSig
224                 -- Inside the alternative, the case binder has the CPR property.
225                 -- Meaning that a case on it will successfully cancel.
226                 -- Example:
227                 --      f True  x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
228                 --      f False x = I# 3
229                 --      
230                 -- We want f to have the CPR property:
231                 --      f b x = case fw b x of { r -> I# r }
232                 --      fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
233                 --      fw False x = 3
234
235         -- Figure out whether the demand on the case binder is used, and use
236         -- that to set the scrut_dmd.  This is utterly essential.
237         -- Consider     f x = case x of y { (a,b) -> k y a }
238         -- If we just take scrut_demand = U(L,A), then we won't pass x to the
239         -- worker, so the worker will rebuild 
240         --      x = (a, absent-error)
241         -- and that'll crash.
242         -- So at one stage I had:
243         --      dead_case_bndr           = isAbsDmd (idDemandInfo case_bndr')
244         --      keepity | dead_case_bndr = Drop
245         --              | otherwise      = Keep         
246         --
247         -- But then consider
248         --      case x of y { (a,b) -> h y + a }
249         -- where h : U(LL) -> T
250         -- The above code would compute a Keep for x, since y is not Abs, which is silly
251         -- The insight is, of course, that a demand on y is a demand on the
252         -- scrutinee, so we need to `both` it with the scrut demand
253         
254         scrut_dmd1 = mkProdDmd [idDemandInfo b | b <- bndrs', isId b]
255         scrut_dmd2 = strictenDmd (idDemandInfo case_bndr')
256         scrut_dmd  = scrut_dmd1 `bothCleanDmd` scrut_dmd2
257
258         (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
259         res_ty             = alt_ty1 `bothDmdType` scrut_ty
260     in
261 --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
262 --                                   , text "dmd" <+> ppr dmd
263 --                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
264 --                                   , text "scrut_dmd" <+> ppr scrut_dmd
265 --                                   , text "scrut_ty" <+> ppr scrut_ty
266 --                                   , text "alt_ty" <+> ppr alt_ty1
267 --                                   , text "res_ty" <+> ppr res_ty ]) $
268     (res_ty, Case scrut' case_bndr' ty [alt'])
269
270 dmdAnal env dmd (Case scrut case_bndr ty alts)
271   = let      -- Case expression with multiple alternatives
272         (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd) alts
273         (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
274         (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
275         res_ty               = alt_ty `bothDmdType` scrut_ty
276     in
277 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
278 --                                   , text "scrut_ty" <+> ppr scrut_ty
279 --                                   , text "alt_tys" <+> ppr alt_tys
280 --                                   , text "alt_ty" <+> ppr alt_ty
281 --                                   , text "res_ty" <+> ppr res_ty ]) $
282     (res_ty, Case scrut' case_bndr' ty alts')
283
284 dmdAnal env dmd (Let (NonRec id rhs) body)
285   = (body_ty2, Let (NonRec id2 annotated_rhs) body')                    
286   where
287     (sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs
288     (body_ty, body')          = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
289     (body_ty1, id2)           = annotateBndr env body_ty id1
290     body_ty2                  = addLazyFVs body_ty1 lazy_fv
291
292     -- Annotate top-level lambdas at RHS basing on the aggregated demand info
293     -- See Note [Annotating lambdas at right-hand side] 
294     annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs'   
295
296         -- If the actual demand is better than the vanilla call
297         -- demand, you might think that we might do better to re-analyse 
298         -- the RHS with the stronger demand.
299         -- But (a) That seldom happens, because it means that *every* path in 
300         --         the body of the let has to use that stronger demand
301         -- (b) It often happens temporarily in when fixpointing, because
302         --     the recursive function at first seems to place a massive demand.
303         --     But we don't want to go to extra work when the function will
304         --     probably iterate to something less demanding.  
305         -- In practice, all the times the actual demand on id2 is more than
306         -- the vanilla call demand seem to be due to (b).  So we don't
307         -- bother to re-analyse the RHS.
308
309 dmdAnal env dmd (Let (Rec pairs) body)
310   = let
311         (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
312         (body_ty, body')        = dmdAnal env' dmd body
313         body_ty1                = deleteFVs body_ty (map fst pairs)
314         body_ty2                = addLazyFVs body_ty1 lazy_fv 
315     in
316     body_ty2 `seq`
317     (body_ty2,  Let (Rec pairs') body')
318
319 annLamWithShotness :: Demand -> CoreExpr -> CoreExpr
320 annLamWithShotness d e
321   | Just u <- cleanUseDmd_maybe d
322   = go u e
323   | otherwise = e
324   where
325     go u e
326       | Just (c, u') <- peelUseCall u
327       , Lam bndr body <- e
328       = if isTyVar bndr 
329         then Lam bndr                    (go u  body)
330         else Lam (setOneShotness c bndr) (go u' body)
331       | otherwise
332       = e
333
334 setOneShotness :: Count -> Id -> Id
335 setOneShotness One  bndr = setOneShotLambda bndr
336 setOneShotness Many bndr = bndr
337
338 dmdAnalAlt :: AnalEnv -> CleanDemand -> Alt Var -> (DmdType, Alt Var)
339 dmdAnalAlt env dmd (con,bndrs,rhs)
340   = let 
341         (rhs_ty, rhs')   = dmdAnal env dmd rhs
342         rhs_ty'          = addDataConPatDmds con bndrs rhs_ty
343         (alt_ty, bndrs') = annotateBndrs env rhs_ty' bndrs
344         final_alt_ty | io_hack_reqd = deferAfterIO alt_ty
345                      | otherwise    = alt_ty
346
347         -- Note [IO hack in the demand analyser]
348         --
349         -- There's a hack here for I/O operations.  Consider
350         --      case foo x s of { (# s, r #) -> y }
351         -- Is this strict in 'y'.  Normally yes, but what if 'foo' is an I/O
352         -- operation that simply terminates the program (not in an erroneous way)?
353         -- In that case we should not evaluate y before the call to 'foo'.
354         -- Hackish solution: spot the IO-like situation and add a virtual branch,
355         -- as if we had
356         --      case foo x s of 
357         --         (# s, r #) -> y 
358         --         other      -> return ()
359         -- So the 'y' isn't necessarily going to be evaluated
360         --
361         -- A more complete example (Trac #148, #1592) where this shows up is:
362         --      do { let len = <expensive> ;
363         --         ; when (...) (exitWith ExitSuccess)
364         --         ; print len }
365
366         io_hack_reqd = con == DataAlt unboxedPairDataCon &&
367                        idType (head bndrs) `eqType` realWorldStatePrimTy
368     in  
369     (final_alt_ty, (con, bndrs', rhs'))
370 \end{code}
371
372 Note [Aggregated demand for cardinality]
373 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 We use different strategies for strictness and usage/cardinality to
375 "unleash" demands captured on free variables by bindings. Let us
376 consider the example:
377
378 f1 y = let {-# NOINLINE h #-}
379            h = y
380        in  (h, h)
381
382 We are interested in obtaining cardinality demand U1 on |y|, as it is
383 used only in a thunk, and, therefore, is not going to be updated any
384 more. Therefore, the demand on |y|, captured and unleashed by usage of
385 |h| is U1. However, if we unleash this demand every time |h| is used,
386 and then sum up the effects, the ultimate demand on |y| will be U1 +
387 U1 = U. In order to avoid it, we *first* collect the aggregate demand
388 on |h| in the body of let-expression, and only then apply the demand
389 transformer:
390
391 transf[x](U) = {y |-> U1}
392
393 so the resulting demand on |y| is U1. 
394
395 The situation is, however, different for strictness, where this
396 aggregating approach exhibits worse results because of the nature of
397 |both| operation for strictness. Consider the example:
398
399 f y c = 
400   let h x = y |seq| x
401    in case of 
402         True  -> h True
403         False -> y
404
405 It is clear that |f| is strict in |y|, however, the suggested analysis
406 will infer from the body of |let| that |h| is used lazily (as it is
407 used in one branch only), therefore lazy demand will be put on its
408 free variable |y|. Conversely, if the demand on |h| is unleashed right
409 on the spot, we will get the desired result, namely, that |f| is
410 strict in |y|.
411
412 Note [Annotating lambdas at right-hand side]
413 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414 Let us take a look at the following example:
415
416 g f = let x = 100
417           h = \y -> f x y
418        in h 5
419
420 One can see that |h| is called just once, therefore the RHS of h can
421 be annotated as a one-shot lambda. This is done by the function
422 annLamWithShotness *a posteriori*, i.e., basing on the aggregated
423 usage demand on |h| from the body of |let|-expression, which is C1(U)
424 in this case.
425
426 In other words, for locally-bound lambdas we can infer
427 one-shotness. 
428
429 \begin{code}
430 addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
431 -- See Note [Add demands for strict constructors]
432 addDataConPatDmds DEFAULT    _ dmd_ty = dmd_ty
433 addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty
434 addDataConPatDmds (DataAlt con) bndrs dmd_ty
435   = foldr add dmd_ty str_bndrs 
436   where
437     add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd
438     str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs"
439                                    (filter isId bndrs)
440                                    (dataConRepStrictness con)
441                     , isMarkedStrict s ]
442 \end{code}
443
444 Note [Add demands for strict constructors]
445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
446 Consider this program (due to Roman):
447
448     data X a = X !a
449
450     foo :: X Int -> Int -> Int
451     foo (X a) n = go 0
452      where
453        go i | i < n     = a + go (i+1)
454             | otherwise = 0
455
456 We want the worker for 'foo' too look like this:
457
458     $wfoo :: Int# -> Int# -> Int#
459
460 with the first argument unboxed, so that it is not eval'd each time
461 around the loop (which would otherwise happen, since 'foo' is not
462 strict in 'a'.  It is sound for the wrapper to pass an unboxed arg
463 because X is strict, so its argument must be evaluated.  And if we
464 *don't* pass an unboxed argument, we can't even repair it by adding a
465 `seq` thus:
466
467     foo (X a) n = a `seq` go 0
468
469 because the seq is discarded (very early) since X is strict!
470
471 There is the usual danger of reboxing, which as usual we ignore. But 
472 if X is monomorphic, and has an UNPACK pragma, then this optimisation
473 is even more important.  We don't want the wrapper to rebox an unboxed
474 argument, and pass an Int to $wfoo!
475
476 %************************************************************************
477 %*                                                                      *
478                     Demand transformer
479 %*                                                                      *
480 %************************************************************************
481
482 \begin{code}
483 dmdTransform :: AnalEnv         -- The strictness environment
484              -> Id              -- The function
485              -> CleanDemand     -- The demand on the function
486              -> DmdType         -- The demand type of the function in this context
487         -- Returned DmdEnv includes the demand on 
488         -- this function plus demand on its free variables
489
490 dmdTransform env var dmd
491   | isDataConWorkId var                          -- Data constructor
492   = dmdTransformDataConSig 
493        (idArity var) (idStrictness var) dmd
494
495   | gopt Opt_DmdTxDictSel (ae_dflags env),
496     Just _ <- isClassOpId_maybe var -- Dictionary component selector
497   = dmdTransformDictSelSig (idStrictness var) dmd
498
499   | isGlobalId var                               -- Imported function
500   = let res = dmdTransformSig (idStrictness var) dmd in
501 --    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
502     res
503
504   | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
505   , let fn_ty = dmdTransformSig sig dmd
506   = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
507     if isTopLevel top_lvl
508     then fn_ty   -- Don't record top level things
509     else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
510
511   | otherwise                                    -- Local non-letrec-bound thing
512   = unitVarDmd var (mkOnceUsedDmd dmd)
513 \end{code}
514
515 %************************************************************************
516 %*                                                                      *
517 \subsection{Bindings}
518 %*                                                                      *
519 %************************************************************************
520
521 \begin{code}
522
523 -- Recursive bindings
524 dmdFix :: TopLevelFlag
525        -> AnalEnv               -- Does not include bindings for this binding
526        -> [(Id,CoreExpr)]
527        -> (AnalEnv, DmdEnv,
528            [(Id,CoreExpr)])     -- Binders annotated with stricness info
529
530 dmdFix top_lvl env orig_pairs
531   = (updSigEnv env (sigEnv final_env), lazy_fv, pairs')
532      -- Return to original virgin state, keeping new signatures
533   where
534     bndrs        = map fst orig_pairs
535     initial_env = addInitialSigs top_lvl env bndrs
536     (final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs
537     
538     loop :: Int
539          -> AnalEnv                     -- Already contains the current sigs
540          -> [(Id,CoreExpr)]             
541          -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
542     loop n env pairs
543       = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $
544         loop' n env pairs
545
546     loop' n env pairs
547       | found_fixpoint
548       = (env', lazy_fv, pairs')
549                 -- Note: return pairs', not pairs.   pairs' is the result of 
550                 -- processing the RHSs with sigs (= sigs'), whereas pairs 
551                 -- is the result of processing the RHSs with the *previous* 
552                 -- iteration of sigs.
553
554       | n >= 10
555       = -- pprTrace "dmdFix loop" (ppr n <+> (vcat 
556         --                 [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id, 
557         --                                              lookupVarEnv (sigEnv env') id) 
558         --                                          | (id,_) <- pairs],
559         --                   text "env:" <+> ppr env,
560         --                   text "binds:" <+> pprCoreBinding (Rec pairs)]))
561         (env, lazy_fv, orig_pairs)      -- Safe output
562                 -- The lazy_fv part is really important!  orig_pairs has no strictness
563                 -- info, including nothing about free vars.  But if we have
564                 --      letrec f = ....y..... in ...f...
565                 -- where 'y' is free in f, we must record that y is mentioned, 
566                 -- otherwise y will get recorded as absent altogether
567
568       | otherwise
569       = loop (n+1) (nonVirgin env') pairs'
570       where
571         found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs 
572
573         ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs
574                 -- mapAccumL: Use the new signature to do the next pair
575                 -- The occurrence analyser has arranged them in a good order
576                 -- so this can significantly reduce the number of iterations needed
577         
578         my_downRhs (env, lazy_fv) (id,rhs)
579           = ((env', lazy_fv'), (id', rhs'))
580           where
581             (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
582             lazy_fv'                   = plusVarEnv_C bothDmd lazy_fv lazy_fv1
583             env'                       = extendAnalEnv top_lvl env id sig
584            
585     same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
586     lookup sigs var = case lookupVarEnv sigs var of
587                         Just (sig,_) -> sig
588                         Nothing      -> pprPanic "dmdFix" (ppr var)
589
590 -- Non-recursive bindings
591 dmdAnalRhs :: TopLevelFlag 
592            -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
593            -> AnalEnv -> Id -> CoreExpr
594            -> (StrictSig,  DmdEnv, Id, CoreExpr)
595 -- Process the RHS of the binding, add the strictness signature
596 -- to the Id, and augment the environment with the signature as well.
597 dmdAnalRhs top_lvl rec_flag env id rhs
598   | Just fn <- unpackTrivial rhs   -- See Note [Trivial right-hand sides]
599   , let fn_str = getStrictness env fn
600   = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs)
601
602   | otherwise
603   = (sig_ty, lazy_fv, id', mkLams bndrs' body')
604   where
605     (bndrs, body)        = collectBinders rhs
606     env_body             = foldl extendSigsWithLam env bndrs
607     (DmdType body_fv _      body_res, body')  = dmdAnal env_body body_dmd body
608     (DmdType rhs_fv rhs_dmds rhs_res, bndrs') = annotateLamBndrs env (isDFunId id)
609                                                   (DmdType body_fv [] body_res) bndrs
610     sig_ty               = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
611     id'                  = set_idStrictness env id sig_ty
612         -- See Note [NOINLINE and strictness]
613
614     -- See Note [Product demands for function body]
615     body_dmd = case deepSplitProductType_maybe (exprType body) of
616                  Nothing            -> cleanEvalDmd
617                  Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
618
619     -- See Note [Lazy and unleashable free variables]
620     -- See Note [Aggregated demand for cardinality]
621     rhs_fv1 = case rec_flag of
622                 Just bs -> useEnv (delVarEnvList rhs_fv bs)
623                 Nothing -> rhs_fv
624
625     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
626
627     rhs_res' | returnsCPR rhs_res
628              , discard_cpr_info   = topRes
629              | otherwise          = rhs_res
630
631     discard_cpr_info = nested_sum || (is_thunk && not_strict)
632     nested_sum     -- See Note [CPR for sum types ]
633         = not (isTopLevel top_lvl || returnsCPRProd rhs_res) 
634
635     -- See Note [CPR for thunks]
636     is_thunk = not (exprIsHNF rhs)
637     not_strict 
638        =  isTopLevel top_lvl  -- Top level and recursive things don't 
639        || isJust rec_flag     -- get their demandInfo set at all
640        || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
641           -- See Note [Optimistic CPR in the "virgin" case]
642
643 unpackTrivial :: CoreExpr -> Maybe Id
644 -- Returns (Just v) if the arg is really equal to v, modulo
645 -- casts, type applications etc 
646 -- See Note [Trivial right-hand sides]
647 unpackTrivial (Var v)                 = Just v
648 unpackTrivial (Cast e _)              = unpackTrivial e
649 unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
650 unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
651 unpackTrivial _                       = Nothing
652 \end{code}
653
654 Note [Trivial right-hand sides]
655 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
656 Consider
657         foo = plusInt |> co
658 where plusInt is an arity-2 function with known strictness.  Clearly
659 we want plusInt's strictness to propagate to foo!  But because it has
660 no manifest lambdas, it won't do so automatically.  So we have a 
661 special case for right-hand sides that are "trivial", namely variables,
662 casts, type applications, and the like. 
663
664 Note [Product demands for function body]
665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666 This example comes from shootout/binary_trees:
667
668     Main.check' = \ b z ds. case z of z' { I# ip ->
669                                 case ds_d13s of
670                                   Main.Nil -> z'
671                                   Main.Node s14k s14l s14m ->
672                                     Main.check' (not b)
673                                       (Main.check' b
674                                          (case b {
675                                             False -> I# (-# s14h s14k);
676                                             True  -> I# (+# s14h s14k)
677                                           })
678                                          s14l)
679                                      s14m   }   }   }
680
681 Here we *really* want to unbox z, even though it appears to be used boxed in
682 the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
683 the whole function gets the CPR property if we do. 
684
685 So for the demand on the body of a RHS we use a product demand if it's
686 a product type.
687
688 %************************************************************************
689 %*                                                                      *
690 \subsection{Strictness signatures and types}
691 %*                                                                      *
692 %************************************************************************
693
694 \begin{code}
695 unitVarDmd :: Var -> Demand -> DmdType
696 unitVarDmd var dmd 
697   = DmdType (unitVarEnv var dmd) [] topRes
698
699 addVarDmd :: DmdType -> Var -> Demand -> DmdType
700 addVarDmd (DmdType fv ds res) var dmd
701   = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
702
703 addLazyFVs :: DmdType -> DmdEnv -> DmdType
704 addLazyFVs dmd_ty lazy_fvs
705   = dmd_ty `bothDmdType` mkDmdType lazy_fvs [] topRes
706         -- Using bothDmdType (rather than just both'ing the envs)
707         -- is vital.  Consider
708         --      let f = \x -> (x,y)
709         --      in  error (f 3)
710         -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
711         -- demand with the bottom coming up from 'error'
712         -- 
713         -- I got a loop in the fixpointer without this, due to an interaction
714         -- with the lazy_fv filtering in dmdAnalRhs.  Roughly, it was
715         --      letrec f n x 
716         --          = letrec g y = x `fatbar` 
717         --                         letrec h z = z + ...g...
718         --                         in h (f (n-1) x)
719         --      in ...
720         -- In the initial iteration for f, f=Bot
721         -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
722         -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
723         -- places on its free variables.  Suppose it places none.  Then the
724         --      x `fatbar` ...call to h...
725         -- will give a x->V demand for x.  That turns into a L demand for x,
726         -- which floats out of the defn for h.  Without the modifyEnv, that
727         -- L demand doesn't get both'd with the Bot coming up from the inner
728         -- call to f.  So we just get an L demand for x for g.
729
730 peelFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand)
731 peelFV fv id res = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
732                      (fv', dmd)
733                 where
734                   fv' = fv `delVarEnv` id
735                   dmd = lookupVarEnv fv id `orElse` deflt
736                   -- See note [Default demand for variables]
737                   deflt | isBotRes res = botDmd
738                         | otherwise    = absDmd
739 \end{code}
740
741 Note [Default demand for variables]
742 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
743
744 If the variable is not mentioned in the environment of a demand type,
745 its demand is taken to be a result demand of the type: either L or the
746 bottom. Both are safe from the semantical pont of view, however, for
747 the safe result we also have absent demand set to Abs, which makes it
748 possible to safely ignore non-mentioned variables (their joint demand
749 is <L,A>).
750
751 Note [do not strictify the argument dictionaries of a dfun]
752 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
753
754 The typechecker can tie recursive knots involving dfuns, so we do the
755 conservative thing and refrain from strictifying a dfun's argument
756 dictionaries.
757
758 \begin{code}
759 annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
760 -- The returned env has the var deleted
761 -- The returned var is annotated with demand info
762 -- according to the result demand of the provided demand type
763 -- No effect on the argument demands
764 annotateBndr env dmd_ty@(DmdType fv ds res) var
765   | isTyVar var = (dmd_ty, var)
766   | otherwise   = (DmdType fv' ds res, set_idDemandInfo env var dmd')
767   where
768     (fv', dmd) = peelFV fv var res
769
770     dmd' | gopt Opt_DictsStrict (ae_dflags env)
771              -- We never want to strictify a recursive let. At the moment
772              -- annotateBndr is only call for non-recursive lets; if that
773              -- changes, we need a RecFlag parameter and another guard here.
774          = strictifyDictDmd (idType var) dmd
775          | otherwise = dmd
776
777 annotateBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var])
778 annotateBndrs env = mapAccumR (annotateBndr env)
779
780 annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
781 annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
782   where
783     annotate dmd_ty bndr
784       | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty Many bndr
785       | otherwise = (dmd_ty, bndr)
786
787 annotateLamIdBndr :: AnalEnv
788                   -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
789                   -> DmdType    -- Demand type of body
790                   -> Count      -- One-shot-ness of the lambda
791                   -> Id         -- Lambda binder
792                   -> (DmdType,  -- Demand type of lambda
793                       Id)       -- and binder annotated with demand     
794
795 annotateLamIdBndr env arg_of_dfun _dmd_ty@(DmdType fv ds res) one_shot id
796 -- For lambdas we add the demand to the argument demands
797 -- Only called for Ids
798   = ASSERT( isId id )
799     -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
800     (final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd'))
801   where
802       -- Watch out!  See note [Lambda-bound unfoldings]
803     final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
804                  Nothing  -> main_ty
805                  Just unf -> main_ty `bothDmdType` unf_ty
806                           where
807                              (unf_ty, _) = dmdAnalStar env dmd unf
808     
809     main_ty = DmdType fv' (dmd:ds) res
810
811     (fv', dmd) = peelFV fv id res
812
813     dmd' | gopt Opt_DictsStrict (ae_dflags env),
814            -- see Note [do not strictify the argument dictionaries of a dfun]
815            not arg_of_dfun
816          = strictifyDictDmd (idType id) dmd
817          | otherwise = dmd
818
819 deleteFVs :: DmdType -> [Var] -> DmdType
820 deleteFVs (DmdType fvs dmds res) bndrs
821   = DmdType (delVarEnvList fvs bndrs) dmds res
822 \end{code}
823
824 Note [CPR for sum types]
825 ~~~~~~~~~~~~~~~~~~~~~~~~
826 At the moment we do not do CPR for let-bindings that
827    * non-top level
828    * bind a sum type
829 Reason: I found that in some benchmarks we were losing let-no-escapes,
830 which messed it all up.  Example
831    let j = \x. ....
832    in case y of
833         True  -> j False
834         False -> j True
835 If we w/w this we get
836    let j' = \x. ....
837    in case y of
838         True  -> case j' False of { (# a #) -> Just a }
839         False -> case j' True of { (# a #) -> Just a }
840 Notice that j' is not a let-no-escape any more.
841
842 However this means in turn that the *enclosing* function
843 may be CPR'd (via the returned Justs).  But in the case of
844 sums, there may be Nothing alternatives; and that messes
845 up the sum-type CPR.
846
847 Conclusion: only do this for products.  It's still not
848 guaranteed OK for products, but sums definitely lose sometimes.
849
850 Note [CPR for thunks]
851 ~~~~~~~~~~~~~~~~~~~~~
852 If the rhs is a thunk, we usually forget the CPR info, because
853 it is presumably shared (else it would have been inlined, and 
854 so we'd lose sharing if w/w'd it into a function).  E.g.
855
856         let r = case expensive of
857                   (a,b) -> (b,a)
858         in ...
859
860 If we marked r as having the CPR property, then we'd w/w into
861
862         let $wr = \() -> case expensive of
863                             (a,b) -> (# b, a #)
864             r = case $wr () of
865                   (# b,a #) -> (b,a)
866         in ...
867
868 But now r is a thunk, which won't be inlined, so we are no further ahead.
869 But consider
870
871         f x = let r = case expensive of (a,b) -> (b,a)
872               in if foo r then r else (x,x)
873
874 Does f have the CPR property?  Well, no.
875
876 However, if the strictness analyser has figured out (in a previous 
877 iteration) that it's strict, then we DON'T need to forget the CPR info.
878 Instead we can retain the CPR info and do the thunk-splitting transform 
879 (see WorkWrap.splitThunk).
880
881 This made a big difference to PrelBase.modInt, which had something like
882         modInt = \ x -> let r = ... -> I# v in
883                         ...body strict in r...
884 r's RHS isn't a value yet; but modInt returns r in various branches, so
885 if r doesn't have the CPR property then neither does modInt
886 Another case I found in practice (in Complex.magnitude), looks like this:
887                 let k = if ... then I# a else I# b
888                 in ... body strict in k ....
889 (For this example, it doesn't matter whether k is returned as part of
890 the overall result; but it does matter that k's RHS has the CPR property.)  
891 Left to itself, the simplifier will make a join point thus:
892                 let $j k = ...body strict in k...
893                 if ... then $j (I# a) else $j (I# b)
894 With thunk-splitting, we get instead
895                 let $j x = let k = I#x in ...body strict in k...
896                 in if ... then $j a else $j b
897 This is much better; there's a good chance the I# won't get allocated.
898
899 The difficulty with this is that we need the strictness type to
900 look at the body... but we now need the body to calculate the demand
901 on the variable, so we can decide whether its strictness type should
902 have a CPR in it or not.  Simple solution: 
903         a) use strictness info from the previous iteration
904         b) make sure we do at least 2 iterations, by doing a second
905            round for top-level non-recs.  Top level recs will get at
906            least 2 iterations except for totally-bottom functions
907            which aren't very interesting anyway.
908
909 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
910
911 Note [Optimistic CPR in the "virgin" case]
912 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
913 Demand and strictness info are initialized by top elements. However,
914 this prevents from inferring a CPR property in the first pass of the
915 analyser, so we keep an explicit flag ae_virgin in the AnalEnv
916 datatype.
917
918 We can't start with 'not-demanded' (i.e., top) because then consider
919         f x = let 
920                   t = ... I# x
921               in
922               if ... then t else I# y else f x'
923
924 In the first iteration we'd have no demand info for x, so assume
925 not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
926 we'd see that t was demanded, and so give it the CPR property, but by
927 now f has TopRes, so it will stay TopRes.  Instead, by checking the
928 ae_virgin flag at the first time round, we say 'yes t is demanded' the
929 first time.
930
931 However, this does mean that for non-recursive bindings we must
932 iterate twice to be sure of not getting over-optimistic CPR info,
933 in the case where t turns out to be not-demanded.  This is handled
934 by dmdAnalTopBind.
935
936
937 Note [NOINLINE and strictness]
938 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
939 The strictness analyser used to have a HACK which ensured that NOINLNE
940 things were not strictness-analysed.  The reason was unsafePerformIO. 
941 Left to itself, the strictness analyser would discover this strictness 
942 for unsafePerformIO:
943         unsafePerformIO:  C(U(AV))
944 But then consider this sub-expression
945         unsafePerformIO (\s -> let r = f x in 
946                                case writeIORef v r s of (# s1, _ #) ->
947                                (# s1, r #)
948 The strictness analyser will now find that r is sure to be eval'd,
949 and may then hoist it out.  This makes tests/lib/should_run/memo002
950 deadlock.
951
952 Solving this by making all NOINLINE things have no strictness info is overkill.
953 In particular, it's overkill for runST, which is perfectly respectable.
954 Consider
955         f x = runST (return x)
956 This should be strict in x.
957
958 So the new plan is to define unsafePerformIO using the 'lazy' combinator:
959
960         unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
961
962 Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is 
963 magically NON-STRICT, and is inlined after strictness analysis.  So
964 unsafePerformIO will look non-strict, and that's what we want.
965
966 Now we don't need the hack in the strictness analyser.  HOWEVER, this
967 decision does mean that even a NOINLINE function is not entirely
968 opaque: some aspect of its implementation leaks out, notably its
969 strictness.  For example, if you have a function implemented by an
970 error stub, but which has RULES, you may want it not to be eliminated
971 in favour of error!
972
973 Note [Lazy and unleasheable free variables]
974 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
975 We put the strict and once-used FVs in the DmdType of the Id, so 
976 that at its call sites we unleash demands on its strict fvs.
977 An example is 'roll' in imaginary/wheel-sieve2
978 Something like this:
979         roll x = letrec 
980                      go y = if ... then roll (x-1) else x+1
981                  in 
982                  go ms
983 We want to see that roll is strict in x, which is because
984 go is called.   So we put the DmdEnv for x in go's DmdType.
985
986 Another example:
987
988         f :: Int -> Int -> Int
989         f x y = let t = x+1
990             h z = if z==0 then t else 
991                   if z==1 then x+1 else
992                   x + h (z-1)
993         in h y
994
995 Calling h does indeed evaluate x, but we can only see
996 that if we unleash a demand on x at the call site for t.
997
998 Incidentally, here's a place where lambda-lifting h would
999 lose the cigar --- we couldn't see the joint strictness in t/x
1000
1001         ON THE OTHER HAND
1002 We don't want to put *all* the fv's from the RHS into the
1003 DmdType, because that makes fixpointing very slow --- the 
1004 DmdType gets full of lazy demands that are slow to converge.
1005
1006
1007 Note [Lamba-bound unfoldings]
1008 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1009 We allow a lambda-bound variable to carry an unfolding, a facility that is used
1010 exclusively for join points; see Note [Case binders and join points].  If so,
1011 we must be careful to demand-analyse the RHS of the unfolding!  Example
1012    \x. \y{=Just x}. <body>
1013 Then if <body> uses 'y', then transitively it uses 'x', and we must not
1014 forget that fact, otherwise we might make 'x' absent when it isn't.
1015
1016
1017 %************************************************************************
1018 %*                                                                      *
1019 \subsection{Strictness signatures}
1020 %*                                                                      *
1021 %************************************************************************
1022
1023 \begin{code}
1024 type DFunFlag = Bool  -- indicates if the lambda being considered is in the
1025                       -- sequence of lambdas at the top of the RHS of a dfun
1026 notArgOfDfun :: DFunFlag
1027 notArgOfDfun = False
1028
1029 data AnalEnv
1030   = AE { ae_dflags :: DynFlags
1031        , ae_sigs   :: SigEnv
1032        , ae_virgin :: Bool    -- True on first iteration only
1033                               -- See Note [Initialising strictness]
1034        , ae_rec_tc :: RecTcChecker
1035  }
1036
1037         -- We use the se_env to tell us whether to
1038         -- record info about a variable in the DmdEnv
1039         -- We do so if it's a LocalId, but not top-level
1040         --
1041         -- The DmdEnv gives the demand on the free vars of the function
1042         -- when it is given enough args to satisfy the strictness signature
1043
1044 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
1045
1046 instance Outputable AnalEnv where
1047   ppr (AE { ae_sigs = env, ae_virgin = virgin })
1048     = ptext (sLit "AE") <+> braces (vcat
1049          [ ptext (sLit "ae_virgin =") <+> ppr virgin
1050          , ptext (sLit "ae_sigs =") <+> ppr env ])
1051
1052 emptyAnalEnv :: DynFlags -> AnalEnv
1053 emptyAnalEnv dflags = AE { ae_dflags = dflags, ae_sigs = emptySigEnv
1054                          , ae_virgin = True, ae_rec_tc = initRecTc }
1055
1056 emptySigEnv :: SigEnv
1057 emptySigEnv = emptyVarEnv
1058
1059 sigEnv :: AnalEnv -> SigEnv
1060 sigEnv = ae_sigs
1061
1062 updSigEnv :: AnalEnv -> SigEnv -> AnalEnv
1063 updSigEnv env sigs = env { ae_sigs = sigs }
1064
1065 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
1066 extendAnalEnv top_lvl env var sig
1067   = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
1068
1069 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
1070 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
1071
1072 lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
1073 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
1074
1075 getStrictness :: AnalEnv -> Id -> StrictSig
1076 getStrictness env fn
1077   | isGlobalId fn                        = idStrictness fn
1078   | Just (sig, _) <- lookupSigEnv env fn = sig
1079   | otherwise                            = nopSig
1080
1081 addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
1082 -- See Note [Initialising strictness]
1083 addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
1084   = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl))
1085                                           | id <- ids ] }
1086   where
1087     init_sig | virgin    = \_ -> botSig
1088              | otherwise = idStrictness
1089
1090 nonVirgin :: AnalEnv -> AnalEnv
1091 nonVirgin env = env { ae_virgin = False }
1092
1093 extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
1094 -- Extend the AnalEnv when we meet a lambda binder
1095 extendSigsWithLam env id
1096   | isId id
1097   , isStrictDmd (idDemandInfo id) || ae_virgin env  
1098        -- See Note [Optimistic CPR in the "virgin" case]
1099        -- See Note [Initial CPR for strict binders]
1100   , Just {} <- deepSplitProductType_maybe $ idType id
1101   = extendAnalEnv NotTopLevel env id cprProdSig 
1102
1103   | otherwise 
1104   = env
1105
1106 set_idDemandInfo :: AnalEnv -> Id -> Demand -> Id
1107 set_idDemandInfo env id dmd 
1108   = setIdDemandInfo id (zapDemand (ae_dflags env) dmd)
1109
1110 set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
1111 set_idStrictness env id sig
1112   = setIdStrictness id (zapStrictSig (ae_dflags env) sig)
1113
1114 dumpStrSig :: CoreProgram -> SDoc
1115 dumpStrSig binds = vcat (map printId ids)
1116   where
1117   ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
1118   getIds (NonRec i _) = [ i ]
1119   getIds (Rec bs)     = map fst bs
1120   printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
1121              | otherwise       = empty
1122
1123 \end{code}
1124
1125 Note [Initial CPR for strict binders]
1126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1127 CPR is initialized for a lambda binder in an optimistic manner, i.e,
1128 if the binder is used strictly and at least some of its components as
1129 a product are used, which is checked by the value of the absence
1130 demand.
1131
1132 If the binder is marked demanded with a strict demand, then give it a
1133 CPR signature, because in the likely event that this is a lambda on a
1134 fn defn [we only use this when the lambda is being consumed with a
1135 call demand], it'll be w/w'd and so it will be CPR-ish.  E.g.
1136
1137         f = \x::(Int,Int).  if ...strict in x... then
1138                                 x
1139                             else
1140                                 (a,b)
1141 We want f to have the CPR property because x does, by the time f has been w/w'd
1142
1143 Also note that we only want to do this for something that definitely
1144 has product type, else we may get over-optimistic CPR results
1145 (e.g. from \x -> x!).
1146
1147
1148 Note [Initialising strictness]
1149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 See section 9.2 (Finding fixpoints) of the paper.
1151
1152 Our basic plan is to initialise the strictness of each Id in a
1153 recursive group to "bottom", and find a fixpoint from there.  However,
1154 this group B might be inside an *enclosing* recursiveb group A, in
1155 which case we'll do the entire fixpoint shebang on for each iteration
1156 of A. This can be illustrated by the following example:
1157
1158 Example:
1159
1160   f [] = []
1161   f (x:xs) = let g []     = f xs
1162                  g (y:ys) = y+1 : g ys
1163               in g (h x)
1164
1165 At each iteration of the fixpoint for f, the analyser has to find a
1166 fixpoint for the enclosed function g. In the meantime, the demand
1167 values for g at each iteration for f are *greater* than those we
1168 encountered in the previous iteration for f. Therefore, we can begin
1169 the fixpoint for g not with the bottom value but rather with the
1170 result of the previous analysis. I.e., when beginning the fixpoint
1171 process for g, we can start from the demand signature computed for g
1172 previously and attached to the binding occurrence of g.
1173
1174 To speed things up, we initialise each iteration of A (the enclosing
1175 one) from the result of the last one, which is neatly recorded in each
1176 binder.  That way we make use of earlier iterations of the fixpoint
1177 algorithm. (Cunning plan.)
1178
1179 But on the *first* iteration we want to *ignore* the current strictness
1180 of the Id, and start from "bottom".  Nowadays the Id can have a current
1181 strictness, because interface files record strictness for nested bindings.
1182 To know when we are in the first iteration, we look at the ae_virgin
1183 field of the AnalEnv.