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