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