Move peelFV from DmdAnal to Demand
[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 )
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 \end{code}
730
731 Note [Default demand for variables]
732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733
734 If the variable is not mentioned in the environment of a demand type,
735 its demand is taken to be a result demand of the type: either L or the
736 bottom. Both are safe from the semantical pont of view, however, for
737 the safe result we also have absent demand set to Abs, which makes it
738 possible to safely ignore non-mentioned variables (their joint demand
739 is <L,A>).
740
741 Note [do not strictify the argument dictionaries of a dfun]
742 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
743
744 The typechecker can tie recursive knots involving dfuns, so we do the
745 conservative thing and refrain from strictifying a dfun's argument
746 dictionaries.
747
748 \begin{code}
749 annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
750 -- The returned env has the var deleted
751 -- The returned var is annotated with demand info
752 -- according to the result demand of the provided demand type
753 -- No effect on the argument demands
754 annotateBndr env dmd_ty var
755   | isTyVar var = (dmd_ty, var)
756   | otherwise   = (dmd_ty', set_idDemandInfo env var dmd')
757   where
758     (dmd_ty', dmd) = peelFV dmd_ty var
759
760     dmd' | gopt Opt_DictsStrict (ae_dflags env)
761              -- We never want to strictify a recursive let. At the moment
762              -- annotateBndr is only call for non-recursive lets; if that
763              -- changes, we need a RecFlag parameter and another guard here.
764          = strictifyDictDmd (idType var) dmd
765          | otherwise = dmd
766
767 annotateBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var])
768 annotateBndrs env = mapAccumR (annotateBndr env)
769
770 annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
771 annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
772   where
773     annotate dmd_ty bndr
774       | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty Many bndr
775       | otherwise = (dmd_ty, bndr)
776
777 annotateLamIdBndr :: AnalEnv
778                   -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
779                   -> DmdType    -- Demand type of body
780                   -> Count      -- One-shot-ness of the lambda
781                   -> Id         -- Lambda binder
782                   -> (DmdType,  -- Demand type of lambda
783                       Id)       -- and binder annotated with demand
784
785 annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
786 -- For lambdas we add the demand to the argument demands
787 -- Only called for Ids
788   = ASSERT( isId id )
789     -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
790     (final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd'))
791   where
792       -- Watch out!  See note [Lambda-bound unfoldings]
793     final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
794                  Nothing  -> main_ty
795                  Just unf -> main_ty `bothDmdType` unf_ty
796                           where
797                              (unf_ty, _) = dmdAnalStar env dmd unf
798
799     main_ty = addDemand dmd dmd_ty'
800     (dmd_ty', dmd) = peelFV dmd_ty id
801
802     dmd' | gopt Opt_DictsStrict (ae_dflags env),
803            -- see Note [do not strictify the argument dictionaries of a dfun]
804            not arg_of_dfun
805          = strictifyDictDmd (idType id) dmd
806          | otherwise = dmd
807
808 deleteFVs :: DmdType -> [Var] -> DmdType
809 deleteFVs (DmdType fvs dmds res) bndrs
810   = DmdType (delVarEnvList fvs bndrs) dmds res
811 \end{code}
812
813 Note [CPR for sum types]
814 ~~~~~~~~~~~~~~~~~~~~~~~~
815 At the moment we do not do CPR for let-bindings that
816    * non-top level
817    * bind a sum type
818 Reason: I found that in some benchmarks we were losing let-no-escapes,
819 which messed it all up.  Example
820    let j = \x. ....
821    in case y of
822         True  -> j False
823         False -> j True
824 If we w/w this we get
825    let j' = \x. ....
826    in case y of
827         True  -> case j' False of { (# a #) -> Just a }
828         False -> case j' True of { (# a #) -> Just a }
829 Notice that j' is not a let-no-escape any more.
830
831 However this means in turn that the *enclosing* function
832 may be CPR'd (via the returned Justs).  But in the case of
833 sums, there may be Nothing alternatives; and that messes
834 up the sum-type CPR.
835
836 Conclusion: only do this for products.  It's still not
837 guaranteed OK for products, but sums definitely lose sometimes.
838
839 Note [CPR for thunks]
840 ~~~~~~~~~~~~~~~~~~~~~
841 If the rhs is a thunk, we usually forget the CPR info, because
842 it is presumably shared (else it would have been inlined, and 
843 so we'd lose sharing if w/w'd it into a function).  E.g.
844
845         let r = case expensive of
846                   (a,b) -> (b,a)
847         in ...
848
849 If we marked r as having the CPR property, then we'd w/w into
850
851         let $wr = \() -> case expensive of
852                             (a,b) -> (# b, a #)
853             r = case $wr () of
854                   (# b,a #) -> (b,a)
855         in ...
856
857 But now r is a thunk, which won't be inlined, so we are no further ahead.
858 But consider
859
860         f x = let r = case expensive of (a,b) -> (b,a)
861               in if foo r then r else (x,x)
862
863 Does f have the CPR property?  Well, no.
864
865 However, if the strictness analyser has figured out (in a previous 
866 iteration) that it's strict, then we DON'T need to forget the CPR info.
867 Instead we can retain the CPR info and do the thunk-splitting transform 
868 (see WorkWrap.splitThunk).
869
870 This made a big difference to PrelBase.modInt, which had something like
871         modInt = \ x -> let r = ... -> I# v in
872                         ...body strict in r...
873 r's RHS isn't a value yet; but modInt returns r in various branches, so
874 if r doesn't have the CPR property then neither does modInt
875 Another case I found in practice (in Complex.magnitude), looks like this:
876                 let k = if ... then I# a else I# b
877                 in ... body strict in k ....
878 (For this example, it doesn't matter whether k is returned as part of
879 the overall result; but it does matter that k's RHS has the CPR property.)  
880 Left to itself, the simplifier will make a join point thus:
881                 let $j k = ...body strict in k...
882                 if ... then $j (I# a) else $j (I# b)
883 With thunk-splitting, we get instead
884                 let $j x = let k = I#x in ...body strict in k...
885                 in if ... then $j a else $j b
886 This is much better; there's a good chance the I# won't get allocated.
887
888 The difficulty with this is that we need the strictness type to
889 look at the body... but we now need the body to calculate the demand
890 on the variable, so we can decide whether its strictness type should
891 have a CPR in it or not.  Simple solution: 
892         a) use strictness info from the previous iteration
893         b) make sure we do at least 2 iterations, by doing a second
894            round for top-level non-recs.  Top level recs will get at
895            least 2 iterations except for totally-bottom functions
896            which aren't very interesting anyway.
897
898 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
899
900 Note [Optimistic CPR in the "virgin" case]
901 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
902 Demand and strictness info are initialized by top elements. However,
903 this prevents from inferring a CPR property in the first pass of the
904 analyser, so we keep an explicit flag ae_virgin in the AnalEnv
905 datatype.
906
907 We can't start with 'not-demanded' (i.e., top) because then consider
908         f x = let 
909                   t = ... I# x
910               in
911               if ... then t else I# y else f x'
912
913 In the first iteration we'd have no demand info for x, so assume
914 not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
915 we'd see that t was demanded, and so give it the CPR property, but by
916 now f has TopRes, so it will stay TopRes.  Instead, by checking the
917 ae_virgin flag at the first time round, we say 'yes t is demanded' the
918 first time.
919
920 However, this does mean that for non-recursive bindings we must
921 iterate twice to be sure of not getting over-optimistic CPR info,
922 in the case where t turns out to be not-demanded.  This is handled
923 by dmdAnalTopBind.
924
925
926 Note [NOINLINE and strictness]
927 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
928 The strictness analyser used to have a HACK which ensured that NOINLNE
929 things were not strictness-analysed.  The reason was unsafePerformIO. 
930 Left to itself, the strictness analyser would discover this strictness 
931 for unsafePerformIO:
932         unsafePerformIO:  C(U(AV))
933 But then consider this sub-expression
934         unsafePerformIO (\s -> let r = f x in 
935                                case writeIORef v r s of (# s1, _ #) ->
936                                (# s1, r #)
937 The strictness analyser will now find that r is sure to be eval'd,
938 and may then hoist it out.  This makes tests/lib/should_run/memo002
939 deadlock.
940
941 Solving this by making all NOINLINE things have no strictness info is overkill.
942 In particular, it's overkill for runST, which is perfectly respectable.
943 Consider
944         f x = runST (return x)
945 This should be strict in x.
946
947 So the new plan is to define unsafePerformIO using the 'lazy' combinator:
948
949         unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
950
951 Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is 
952 magically NON-STRICT, and is inlined after strictness analysis.  So
953 unsafePerformIO will look non-strict, and that's what we want.
954
955 Now we don't need the hack in the strictness analyser.  HOWEVER, this
956 decision does mean that even a NOINLINE function is not entirely
957 opaque: some aspect of its implementation leaks out, notably its
958 strictness.  For example, if you have a function implemented by an
959 error stub, but which has RULES, you may want it not to be eliminated
960 in favour of error!
961
962 Note [Lazy and unleasheable free variables]
963 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
964 We put the strict and once-used FVs in the DmdType of the Id, so 
965 that at its call sites we unleash demands on its strict fvs.
966 An example is 'roll' in imaginary/wheel-sieve2
967 Something like this:
968         roll x = letrec 
969                      go y = if ... then roll (x-1) else x+1
970                  in 
971                  go ms
972 We want to see that roll is strict in x, which is because
973 go is called.   So we put the DmdEnv for x in go's DmdType.
974
975 Another example:
976
977         f :: Int -> Int -> Int
978         f x y = let t = x+1
979             h z = if z==0 then t else 
980                   if z==1 then x+1 else
981                   x + h (z-1)
982         in h y
983
984 Calling h does indeed evaluate x, but we can only see
985 that if we unleash a demand on x at the call site for t.
986
987 Incidentally, here's a place where lambda-lifting h would
988 lose the cigar --- we couldn't see the joint strictness in t/x
989
990         ON THE OTHER HAND
991 We don't want to put *all* the fv's from the RHS into the
992 DmdType, because that makes fixpointing very slow --- the 
993 DmdType gets full of lazy demands that are slow to converge.
994
995
996 Note [Lamba-bound unfoldings]
997 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
998 We allow a lambda-bound variable to carry an unfolding, a facility that is used
999 exclusively for join points; see Note [Case binders and join points].  If so,
1000 we must be careful to demand-analyse the RHS of the unfolding!  Example
1001    \x. \y{=Just x}. <body>
1002 Then if <body> uses 'y', then transitively it uses 'x', and we must not
1003 forget that fact, otherwise we might make 'x' absent when it isn't.
1004
1005
1006 %************************************************************************
1007 %*                                                                      *
1008 \subsection{Strictness signatures}
1009 %*                                                                      *
1010 %************************************************************************
1011
1012 \begin{code}
1013 type DFunFlag = Bool  -- indicates if the lambda being considered is in the
1014                       -- sequence of lambdas at the top of the RHS of a dfun
1015 notArgOfDfun :: DFunFlag
1016 notArgOfDfun = False
1017
1018 data AnalEnv
1019   = AE { ae_dflags :: DynFlags
1020        , ae_sigs   :: SigEnv
1021        , ae_virgin :: Bool    -- True on first iteration only
1022                               -- See Note [Initialising strictness]
1023        , ae_rec_tc :: RecTcChecker
1024  }
1025
1026         -- We use the se_env to tell us whether to
1027         -- record info about a variable in the DmdEnv
1028         -- We do so if it's a LocalId, but not top-level
1029         --
1030         -- The DmdEnv gives the demand on the free vars of the function
1031         -- when it is given enough args to satisfy the strictness signature
1032
1033 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
1034
1035 instance Outputable AnalEnv where
1036   ppr (AE { ae_sigs = env, ae_virgin = virgin })
1037     = ptext (sLit "AE") <+> braces (vcat
1038          [ ptext (sLit "ae_virgin =") <+> ppr virgin
1039          , ptext (sLit "ae_sigs =") <+> ppr env ])
1040
1041 emptyAnalEnv :: DynFlags -> AnalEnv
1042 emptyAnalEnv dflags = AE { ae_dflags = dflags, ae_sigs = emptySigEnv
1043                          , ae_virgin = True, ae_rec_tc = initRecTc }
1044
1045 emptySigEnv :: SigEnv
1046 emptySigEnv = emptyVarEnv
1047
1048 sigEnv :: AnalEnv -> SigEnv
1049 sigEnv = ae_sigs
1050
1051 updSigEnv :: AnalEnv -> SigEnv -> AnalEnv
1052 updSigEnv env sigs = env { ae_sigs = sigs }
1053
1054 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
1055 extendAnalEnv top_lvl env var sig
1056   = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
1057
1058 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
1059 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
1060
1061 lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
1062 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
1063
1064 getStrictness :: AnalEnv -> Id -> StrictSig
1065 getStrictness env fn
1066   | isGlobalId fn                        = idStrictness fn
1067   | Just (sig, _) <- lookupSigEnv env fn = sig
1068   | otherwise                            = nopSig
1069
1070 addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
1071 -- See Note [Initialising strictness]
1072 addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
1073   = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl))
1074                                           | id <- ids ] }
1075   where
1076     init_sig | virgin    = \_ -> botSig
1077              | otherwise = idStrictness
1078
1079 nonVirgin :: AnalEnv -> AnalEnv
1080 nonVirgin env = env { ae_virgin = False }
1081
1082 extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
1083 -- Extend the AnalEnv when we meet a lambda binder
1084 extendSigsWithLam env id
1085   | isId id
1086   , isStrictDmd (idDemandInfo id) || ae_virgin env  
1087        -- See Note [Optimistic CPR in the "virgin" case]
1088        -- See Note [Initial CPR for strict binders]
1089   , Just {} <- deepSplitProductType_maybe $ idType id
1090   = extendAnalEnv NotTopLevel env id cprProdSig 
1091
1092   | otherwise 
1093   = env
1094
1095 set_idDemandInfo :: AnalEnv -> Id -> Demand -> Id
1096 set_idDemandInfo env id dmd 
1097   = setIdDemandInfo id (zapDemand (ae_dflags env) dmd)
1098
1099 set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
1100 set_idStrictness env id sig
1101   = setIdStrictness id (zapStrictSig (ae_dflags env) sig)
1102
1103 dumpStrSig :: CoreProgram -> SDoc
1104 dumpStrSig binds = vcat (map printId ids)
1105   where
1106   ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
1107   getIds (NonRec i _) = [ i ]
1108   getIds (Rec bs)     = map fst bs
1109   printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
1110              | otherwise       = empty
1111
1112 \end{code}
1113
1114 Note [Initial CPR for strict binders]
1115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1116 CPR is initialized for a lambda binder in an optimistic manner, i.e,
1117 if the binder is used strictly and at least some of its components as
1118 a product are used, which is checked by the value of the absence
1119 demand.
1120
1121 If the binder is marked demanded with a strict demand, then give it a
1122 CPR signature, because in the likely event that this is a lambda on a
1123 fn defn [we only use this when the lambda is being consumed with a
1124 call demand], it'll be w/w'd and so it will be CPR-ish.  E.g.
1125
1126         f = \x::(Int,Int).  if ...strict in x... then
1127                                 x
1128                             else
1129                                 (a,b)
1130 We want f to have the CPR property because x does, by the time f has been w/w'd
1131
1132 Also note that we only want to do this for something that definitely
1133 has product type, else we may get over-optimistic CPR results
1134 (e.g. from \x -> x!).
1135
1136
1137 Note [Initialising strictness]
1138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1139 See section 9.2 (Finding fixpoints) of the paper.
1140
1141 Our basic plan is to initialise the strictness of each Id in a
1142 recursive group to "bottom", and find a fixpoint from there.  However,
1143 this group B might be inside an *enclosing* recursiveb group A, in
1144 which case we'll do the entire fixpoint shebang on for each iteration
1145 of A. This can be illustrated by the following example:
1146
1147 Example:
1148
1149   f [] = []
1150   f (x:xs) = let g []     = f xs
1151                  g (y:ys) = y+1 : g ys
1152               in g (h x)
1153
1154 At each iteration of the fixpoint for f, the analyser has to find a
1155 fixpoint for the enclosed function g. In the meantime, the demand
1156 values for g at each iteration for f are *greater* than those we
1157 encountered in the previous iteration for f. Therefore, we can begin
1158 the fixpoint for g not with the bottom value but rather with the
1159 result of the previous analysis. I.e., when beginning the fixpoint
1160 process for g, we can start from the demand signature computed for g
1161 previously and attached to the binding occurrence of g.
1162
1163 To speed things up, we initialise each iteration of A (the enclosing
1164 one) from the result of the last one, which is neatly recorded in each
1165 binder.  That way we make use of earlier iterations of the fixpoint
1166 algorithm. (Cunning plan.)
1167
1168 But on the *first* iteration we want to *ignore* the current strictness
1169 of the Id, and start from "bottom".  Nowadays the Id can have a current
1170 strictness, because interface files record strictness for nested bindings.
1171 To know when we are in the first iteration, we look at the ae_virgin
1172 field of the AnalEnv.