Update Trac ticket URLs to point to GitLab
[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 GhcPrelude
17
18 import DynFlags
19 import WwLib ( findTypeShape, deepSplitProductType_maybe )
20 import Demand -- All of it
21 import CoreSyn
22 import CoreSeq ( seqBinds )
23 import Outputable
24 import VarEnv
25 import BasicTypes
26 import Data.List
27 import DataCon
28 import Id
29 import CoreUtils ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )
30 import TyCon
31 import Type
32 import Coercion ( Coercion, coVarsOfCo )
33 import FamInstEnv
34 import Util
35 import Maybes ( isJust )
36 import TysWiredIn
37 import TysPrim ( realWorldStatePrimTy )
38 import ErrUtils ( dumpIfSet_dyn )
39 import Name ( getName, stableNameCmp )
40 import Data.Function ( on )
41 import UniqSet
42
43 {-
44 ************************************************************************
45 * *
46 \subsection{Top level stuff}
47 * *
48 ************************************************************************
49 -}
50
51 dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
52 dmdAnalProgram dflags fam_envs binds
53 = do {
54 let { binds_plus_dmds = do_prog binds } ;
55 dumpIfSet_dyn dflags Opt_D_dump_str_signatures
56 "Strictness signatures" $
57 dumpStrSig binds_plus_dmds ;
58 -- See Note [Stamp out space leaks in demand analysis]
59 seqBinds binds_plus_dmds `seq` return binds_plus_dmds
60 }
61 where
62 do_prog :: CoreProgram -> CoreProgram
63 do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
64
65 -- Analyse a (group of) top-level binding(s)
66 dmdAnalTopBind :: AnalEnv
67 -> CoreBind
68 -> (AnalEnv, CoreBind)
69 dmdAnalTopBind env (NonRec id rhs)
70 = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2)
71 where
72 ( _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing env cleanEvalDmd id rhs
73 ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1
74 -- Do two passes to improve CPR information
75 -- See Note [CPR for thunks]
76 -- See Note [Optimistic CPR in the "virgin" case]
77 -- See Note [Initial CPR for strict binders]
78
79 dmdAnalTopBind env (Rec pairs)
80 = (env', Rec pairs')
81 where
82 (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs
83 -- We get two iterations automatically
84 -- c.f. the NonRec case above
85
86 {- Note [Stamp out space leaks in demand analysis]
87 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
88 The demand analysis pass outputs a new copy of the Core program in
89 which binders have been annotated with demand and strictness
90 information. It's tiresome to ensure that this information is fully
91 evaluated everywhere that we produce it, so we just run a single
92 seqBinds over the output before returning it, to ensure that there are
93 no references holding on to the input Core program.
94
95 This makes a ~30% reduction in peak memory usage when compiling
96 DynFlags (cf #9675 and #13426).
97
98 This is particularly important when we are doing late demand analysis,
99 since we don't do a seqBinds at any point thereafter. Hence code
100 generation would hold on to an extra copy of the Core program, via
101 unforced thunks in demand or strictness information; and it is the
102 most memory-intensive part of the compilation process, so this added
103 seqBinds makes a big difference in peak memory usage.
104 -}
105
106
107 {-
108 ************************************************************************
109 * *
110 \subsection{The analyser itself}
111 * *
112 ************************************************************************
113
114 Note [Ensure demand is strict]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 It's important not to analyse e with a lazy demand because
117 a) When we encounter case s of (a,b) ->
118 we demand s with U(d1d2)... but if the overall demand is lazy
119 that is wrong, and we'd need to reduce the demand on s,
120 which is inconvenient
121 b) More important, consider
122 f (let x = R in x+x), where f is lazy
123 We still want to mark x as demanded, because it will be when we
124 enter the let. If we analyse f's arg with a Lazy demand, we'll
125 just mark x as Lazy
126 c) The application rule wouldn't be right either
127 Evaluating (f x) in a L demand does *not* cause
128 evaluation of f in a C(L) demand!
129 -}
130
131 -- If e is complicated enough to become a thunk, its contents will be evaluated
132 -- at most once, so oneify it.
133 dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
134 dmdTransformThunkDmd e
135 | exprIsTrivial e = id
136 | otherwise = oneifyDmd
137
138 -- Do not process absent demands
139 -- Otherwise act like in a normal demand analysis
140 -- See ↦* relation in the Cardinality Analysis paper
141 dmdAnalStar :: AnalEnv
142 -> Demand -- This one takes a *Demand*
143 -> CoreExpr -- Should obey the let/app invariatn
144 -> (BothDmdArg, CoreExpr)
145 dmdAnalStar env dmd e
146 | (dmd_shell, cd) <- toCleanDmd dmd
147 , (dmd_ty, e') <- dmdAnal env cd e
148 = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
149 -- The argument 'e' should satisfy the let/app invariant
150 -- See Note [Analysing with absent demand] in Demand.hs
151 (postProcessDmdType dmd_shell dmd_ty, e')
152
153 -- Main Demand Analsysis machinery
154 dmdAnal, dmdAnal' :: AnalEnv
155 -> CleanDemand -- The main one takes a *CleanDemand*
156 -> CoreExpr -> (DmdType, CoreExpr)
157
158 -- The CleanDemand is always strict and not absent
159 -- See Note [Ensure demand is strict]
160
161 dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
162 dmdAnal' env d e
163
164 dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit)
165 dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact
166 dmdAnal' _ _ (Coercion co)
167 = (unitDmdType (coercionDmdEnv co), Coercion co)
168
169 dmdAnal' env dmd (Var var)
170 = (dmdTransform env var dmd, Var var)
171
172 dmdAnal' env dmd (Cast e co)
173 = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
174 where
175 (dmd_ty, e') = dmdAnal env dmd e
176
177 dmdAnal' env dmd (Tick t e)
178 = (dmd_ty, Tick t e')
179 where
180 (dmd_ty, e') = dmdAnal env dmd e
181
182 dmdAnal' env dmd (App fun (Type ty))
183 = (fun_ty, App fun' (Type ty))
184 where
185 (fun_ty, fun') = dmdAnal env dmd fun
186
187 -- Lots of the other code is there to make this
188 -- beautiful, compositional, application rule :-)
189 dmdAnal' env dmd (App fun arg)
190 = -- This case handles value arguments (type args handled above)
191 -- Crucially, coercions /are/ handled here, because they are
192 -- value arguments (#10288)
193 let
194 call_dmd = mkCallDmd dmd
195 (fun_ty, fun') = dmdAnal env call_dmd fun
196 (arg_dmd, res_ty) = splitDmdTy fun_ty
197 (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
198 in
199 -- pprTrace "dmdAnal:app" (vcat
200 -- [ text "dmd =" <+> ppr dmd
201 -- , text "expr =" <+> ppr (App fun arg)
202 -- , text "fun dmd_ty =" <+> ppr fun_ty
203 -- , text "arg dmd =" <+> ppr arg_dmd
204 -- , text "arg dmd_ty =" <+> ppr arg_ty
205 -- , text "res dmd_ty =" <+> ppr res_ty
206 -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
207 (res_ty `bothDmdType` arg_ty, App fun' arg')
208
209 -- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
210 dmdAnal' env dmd (Lam var body)
211 | isTyVar var
212 = let
213 (body_ty, body') = dmdAnal env dmd body
214 in
215 (body_ty, Lam var body')
216
217 | otherwise
218 = let (body_dmd, defer_and_use) = peelCallDmd dmd
219 -- body_dmd: a demand to analyze the body
220
221 env' = extendSigsWithLam env var
222 (body_ty, body') = dmdAnal env' body_dmd body
223 (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var
224 in
225 (postProcessUnsat defer_and_use lam_ty, Lam var' body')
226
227 dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
228 -- Only one alternative with a product constructor
229 | let tycon = dataConTyCon dc
230 , isJust (isDataProductTyCon_maybe tycon)
231 , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
232 = let
233 env_w_tc = env { ae_rec_tc = rec_tc' }
234 env_alt = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs
235 (rhs_ty, rhs') = dmdAnal env_alt dmd rhs
236 (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs
237 (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
238 id_dmds = addCaseBndrDmd case_bndr_dmd dmds
239 alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
240 | otherwise = alt_ty2
241
242 -- Compute demand on the scrutinee
243 -- See Note [Demand on scrutinee of a product case]
244 scrut_dmd = mkProdDmd id_dmds
245 (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
246 res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
247 case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd
248 bndrs' = setBndrsDemandInfo bndrs id_dmds
249 in
250 -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
251 -- , text "dmd" <+> ppr dmd
252 -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
253 -- , text "id_dmds" <+> ppr id_dmds
254 -- , text "scrut_dmd" <+> ppr scrut_dmd
255 -- , text "scrut_ty" <+> ppr scrut_ty
256 -- , text "alt_ty" <+> ppr alt_ty2
257 -- , text "res_ty" <+> ppr res_ty ]) $
258 (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])
259
260 dmdAnal' env dmd (Case scrut case_bndr ty alts)
261 = let -- Case expression with multiple alternatives
262 (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
263 (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut
264 (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
265 -- NB: Base case is botDmdType, for empty case alternatives
266 -- This is a unit for lubDmdType, and the right result
267 -- when there really are no alternatives
268 res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty
269 in
270 -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
271 -- , text "scrut_ty" <+> ppr scrut_ty
272 -- , text "alt_tys" <+> ppr alt_tys
273 -- , text "alt_ty" <+> ppr alt_ty
274 -- , text "res_ty" <+> ppr res_ty ]) $
275 (res_ty, Case scrut' case_bndr' ty alts')
276
277 -- Let bindings can be processed in two ways:
278 -- Down (RHS before body) or Up (body before RHS).
279 -- The following case handle the up variant.
280 --
281 -- It is very simple. For let x = rhs in body
282 -- * Demand-analyse 'body' in the current environment
283 -- * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
284 -- * Demand-analyse 'rhs' in 'rhs_dmd'
285 --
286 -- This is used for a non-recursive local let without manifest lambdas.
287 -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
288 dmdAnal' env dmd (Let (NonRec id rhs) body)
289 | useLetUp id rhs
290 , Nothing <- unpackTrivial rhs
291 -- dmdAnalRhsLetDown treats trivial right hand sides specially
292 -- so if we have a trival right hand side, fall through to that.
293 = (final_ty, Let (NonRec id' rhs') body')
294 where
295 (body_ty, body') = dmdAnal env dmd body
296 (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
297 id' = setIdDemandInfo id id_dmd
298
299 (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
300 final_ty = body_ty' `bothDmdType` rhs_ty
301
302 dmdAnal' env dmd (Let (NonRec id rhs) body)
303 = (body_ty2, Let (NonRec id2 rhs') body')
304 where
305 (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs
306 env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
307 (body_ty, body') = dmdAnal env1 dmd body
308 (body_ty1, id2) = annotateBndr env body_ty id1
309 body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
310
311 -- If the actual demand is better than the vanilla call
312 -- demand, you might think that we might do better to re-analyse
313 -- the RHS with the stronger demand.
314 -- But (a) That seldom happens, because it means that *every* path in
315 -- the body of the let has to use that stronger demand
316 -- (b) It often happens temporarily in when fixpointing, because
317 -- the recursive function at first seems to place a massive demand.
318 -- But we don't want to go to extra work when the function will
319 -- probably iterate to something less demanding.
320 -- In practice, all the times the actual demand on id2 is more than
321 -- the vanilla call demand seem to be due to (b). So we don't
322 -- bother to re-analyse the RHS.
323
324 dmdAnal' env dmd (Let (Rec pairs) body)
325 = let
326 (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
327 (body_ty, body') = dmdAnal env' dmd body
328 body_ty1 = deleteFVs body_ty (map fst pairs)
329 body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
330 in
331 body_ty2 `seq`
332 (body_ty2, Let (Rec pairs') body')
333
334 io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
335 -- See Note [IO hack in the demand analyser]
336 io_hack_reqd scrut con bndrs
337 | (bndr:_) <- bndrs
338 , con == tupleDataCon Unboxed 2
339 , idType bndr `eqType` realWorldStatePrimTy
340 , (fun, _) <- collectArgs scrut
341 = case fun of
342 Var f -> not (isPrimOpId f)
343 _ -> True
344 | otherwise
345 = False
346
347 dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
348 dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
349 | null bndrs -- Literals, DEFAULT, and nullary constructors
350 , (rhs_ty, rhs') <- dmdAnal env dmd rhs
351 = (rhs_ty, (con, [], rhs'))
352
353 | otherwise -- Non-nullary data constructors
354 , (rhs_ty, rhs') <- dmdAnal env dmd rhs
355 , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs
356 , let case_bndr_dmd = findIdDemand alt_ty case_bndr
357 id_dmds = addCaseBndrDmd case_bndr_dmd dmds
358 = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
359
360
361 {- Note [IO hack in the demand analyser]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 There's a hack here for I/O operations. Consider
364
365 case foo x s of { (# s', r #) -> y }
366
367 Is this strict in 'y'? Often not! If foo x s performs some observable action
368 (including raising an exception with raiseIO#, modifying a mutable variable, or
369 even ending the program normally), then we must not force 'y' (which may fail
370 to terminate) until we have performed foo x s.
371
372 Hackish solution: spot the IO-like situation and add a virtual branch,
373 as if we had
374 case foo x s of
375 (# s, r #) -> y
376 other -> return ()
377 So the 'y' isn't necessarily going to be evaluated
378
379 A more complete example (#148, #1592) where this shows up is:
380 do { let len = <expensive> ;
381 ; when (...) (exitWith ExitSuccess)
382 ; print len }
383
384 However, consider
385 f x s = case getMaskingState# s of
386 (# s, r #) ->
387 case x of I# x2 -> ...
388
389 Here it is terribly sad to make 'f' lazy in 's'. After all,
390 getMaskingState# is not going to diverge or throw an exception! This
391 situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
392 (on an MVar not an Int), and made a material difference.
393
394 So if the scrutinee is a primop call, we *don't* apply the
395 state hack:
396 - If it is a simple, terminating one like getMaskingState,
397 applying the hack is over-conservative.
398 - If the primop is raise# then it returns bottom, so
399 the case alternatives are already discarded.
400 - If the primop can raise a non-IO exception, like
401 divide by zero or seg-fault (eg writing an array
402 out of bounds) then we don't mind evaluating 'x' first.
403
404 Note [Demand on the scrutinee of a product case]
405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
406 When figuring out the demand on the scrutinee of a product case,
407 we use the demands of the case alternative, i.e. id_dmds.
408 But note that these include the demand on the case binder;
409 see Note [Demand on case-alternative binders] in Demand.hs.
410 This is crucial. Example:
411 f x = case x of y { (a,b) -> k y a }
412 If we just take scrut_demand = U(L,A), then we won't pass x to the
413 worker, so the worker will rebuild
414 x = (a, absent-error)
415 and that'll crash.
416
417 Note [Aggregated demand for cardinality]
418 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
419 We use different strategies for strictness and usage/cardinality to
420 "unleash" demands captured on free variables by bindings. Let us
421 consider the example:
422
423 f1 y = let {-# NOINLINE h #-}
424 h = y
425 in (h, h)
426
427 We are interested in obtaining cardinality demand U1 on |y|, as it is
428 used only in a thunk, and, therefore, is not going to be updated any
429 more. Therefore, the demand on |y|, captured and unleashed by usage of
430 |h| is U1. However, if we unleash this demand every time |h| is used,
431 and then sum up the effects, the ultimate demand on |y| will be U1 +
432 U1 = U. In order to avoid it, we *first* collect the aggregate demand
433 on |h| in the body of let-expression, and only then apply the demand
434 transformer:
435
436 transf[x](U) = {y |-> U1}
437
438 so the resulting demand on |y| is U1.
439
440 The situation is, however, different for strictness, where this
441 aggregating approach exhibits worse results because of the nature of
442 |both| operation for strictness. Consider the example:
443
444 f y c =
445 let h x = y |seq| x
446 in case of
447 True -> h True
448 False -> y
449
450 It is clear that |f| is strict in |y|, however, the suggested analysis
451 will infer from the body of |let| that |h| is used lazily (as it is
452 used in one branch only), therefore lazy demand will be put on its
453 free variable |y|. Conversely, if the demand on |h| is unleashed right
454 on the spot, we will get the desired result, namely, that |f| is
455 strict in |y|.
456
457
458 ************************************************************************
459 * *
460 Demand transformer
461 * *
462 ************************************************************************
463 -}
464
465 dmdTransform :: AnalEnv -- The strictness environment
466 -> Id -- The function
467 -> CleanDemand -- The demand on the function
468 -> DmdType -- The demand type of the function in this context
469 -- Returned DmdEnv includes the demand on
470 -- this function plus demand on its free variables
471
472 dmdTransform env var dmd
473 | isDataConWorkId var -- Data constructor
474 = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
475
476 | gopt Opt_DmdTxDictSel (ae_dflags env),
477 Just _ <- isClassOpId_maybe var -- Dictionary component selector
478 = dmdTransformDictSelSig (idStrictness var) dmd
479
480 | isGlobalId var -- Imported function
481 = let res = dmdTransformSig (idStrictness var) dmd in
482 -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
483 res
484
485 | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing
486 , let fn_ty = dmdTransformSig sig dmd
487 = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
488 if isTopLevel top_lvl
489 then fn_ty -- Don't record top level things
490 else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
491
492 | otherwise -- Local non-letrec-bound thing
493 = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
494
495 {-
496 ************************************************************************
497 * *
498 \subsection{Bindings}
499 * *
500 ************************************************************************
501 -}
502
503 -- Recursive bindings
504 dmdFix :: TopLevelFlag
505 -> AnalEnv -- Does not include bindings for this binding
506 -> CleanDemand
507 -> [(Id,CoreExpr)]
508 -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
509
510 dmdFix top_lvl env let_dmd orig_pairs
511 = loop 1 initial_pairs
512 where
513 bndrs = map fst orig_pairs
514
515 -- See Note [Initialising strictness]
516 initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
517 | otherwise = orig_pairs
518
519 -- If fixed-point iteration does not yield a result we use this instead
520 -- See Note [Safe abortion in the fixed-point iteration]
521 abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
522 abort = (env, lazy_fv', zapped_pairs)
523 where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
524 -- Note [Lazy and unleashable free variables]
525 non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
526 lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
527 zapped_pairs = zapIdStrictness pairs'
528
529 -- The fixed-point varies the idStrictness field of the binders, and terminates if that
530 -- annotation does not change any more.
531 loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
532 loop n pairs
533 | found_fixpoint = (final_anal_env, lazy_fv, pairs')
534 | n == 10 = abort
535 | otherwise = loop (n+1) pairs'
536 where
537 found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
538 first_round = n == 1
539 (lazy_fv, pairs') = step first_round pairs
540 final_anal_env = extendAnalEnvs top_lvl env (map fst pairs')
541
542 step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
543 step first_round pairs = (lazy_fv, pairs')
544 where
545 -- In all but the first iteration, delete the virgin flag
546 start_env | first_round = env
547 | otherwise = nonVirgin env
548
549 start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
550
551 ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
552 -- mapAccumL: Use the new signature to do the next pair
553 -- The occurrence analyser has arranged them in a good order
554 -- so this can significantly reduce the number of iterations needed
555
556 my_downRhs (env, lazy_fv) (id,rhs)
557 = ((env', lazy_fv'), (id', rhs'))
558 where
559 (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs
560 lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1
561 env' = extendAnalEnv top_lvl env id (idStrictness id')
562
563
564 zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
565 zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
566
567 {-
568 Note [Safe abortion in the fixed-point iteration]
569 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
570
571 Fixed-point iteration may fail to terminate. But we cannot simply give up and
572 return the environment and code unchanged! We still need to do one additional
573 round, for two reasons:
574
575 * To get information on used free variables (both lazy and strict!)
576 (see Note [Lazy and unleashable free variables])
577 * To ensure that all expressions have been traversed at least once, and any left-over
578 strictness annotations have been updated.
579
580 This final iteration does not add the variables to the strictness signature
581 environment, which effectively assigns them 'nopSig' (see "getStrictness")
582
583 -}
584
585 -- Trivial RHS
586 -- See Note [Demand analysis for trivial right-hand sides]
587 dmdAnalTrivialRhs ::
588 AnalEnv -> Id -> CoreExpr -> Var ->
589 (DmdEnv, Id, CoreExpr)
590 dmdAnalTrivialRhs env id rhs fn
591 = (fn_fv, set_idStrictness env id fn_str, rhs)
592 where
593 fn_str = getStrictness env fn
594 fn_fv | isLocalId fn = unitVarEnv fn topDmd
595 | otherwise = emptyDmdEnv
596 -- Note [Remember to demand the function itself]
597 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
598 -- fn_fv: don't forget to produce a demand for fn itself
599 -- Lacking this caused #9128
600 -- The demand is very conservative (topDmd), but that doesn't
601 -- matter; trivial bindings are usually inlined, so it only
602 -- kicks in for top-level bindings and NOINLINE bindings
603
604 -- Let bindings can be processed in two ways:
605 -- Down (RHS before body) or Up (body before RHS).
606 -- dmdAnalRhsLetDown implements the Down variant:
607 -- * assuming a demand of <L,U>
608 -- * looking at the definition
609 -- * determining a strictness signature
610 --
611 -- It is used for toplevel definition, recursive definitions and local
612 -- non-recursive definitions that have manifest lambdas.
613 -- Local non-recursive definitions without a lambda are handled with LetUp.
614 --
615 -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
616 dmdAnalRhsLetDown :: TopLevelFlag
617 -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
618 -> AnalEnv -> CleanDemand
619 -> Id -> CoreExpr
620 -> (DmdEnv, Id, CoreExpr)
621 -- Process the RHS of the binding, add the strictness signature
622 -- to the Id, and augment the environment with the signature as well.
623 dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
624 | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides]
625 = dmdAnalTrivialRhs env id rhs fn
626
627 | otherwise
628 = (lazy_fv, id', mkLams bndrs' body')
629 where
630 (bndrs, body, body_dmd)
631 = case isJoinId_maybe id of
632 Just join_arity -- See Note [Demand analysis for join points]
633 | (bndrs, body) <- collectNBinders join_arity rhs
634 -> (bndrs, body, let_dmd)
635
636 Nothing | (bndrs, body) <- collectBinders rhs
637 -> (bndrs, body, mkBodyDmd env body)
638
639 env_body = foldl' extendSigsWithLam env bndrs
640 (body_ty, body') = dmdAnal env_body body_dmd body
641 body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info
642 (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
643 = annotateLamBndrs env (isDFunId id) body_ty' bndrs
644 sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
645 id' = set_idStrictness env id sig_ty
646 -- See Note [NOINLINE and strictness]
647
648
649 -- See Note [Aggregated demand for cardinality]
650 rhs_fv1 = case rec_flag of
651 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
652 Nothing -> rhs_fv
653
654 -- See Note [Lazy and unleashable free variables]
655 (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
656
657 rhs_res' = trimCPRInfo trim_all trim_sums rhs_res
658 trim_all = is_thunk && not_strict
659 trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
660
661 -- See Note [CPR for thunks]
662 is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
663 not_strict
664 = isTopLevel top_lvl -- Top level and recursive things don't
665 || isJust rec_flag -- get their demandInfo set at all
666 || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
667 -- See Note [Optimistic CPR in the "virgin" case]
668
669 mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand
670 -- See Note [Product demands for function body]
671 mkBodyDmd env body
672 = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
673 Nothing -> cleanEvalDmd
674 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
675
676 unpackTrivial :: CoreExpr -> Maybe Id
677 -- Returns (Just v) if the arg is really equal to v, modulo
678 -- casts, type applications etc
679 -- See Note [Demand analysis for trivial right-hand sides]
680 unpackTrivial (Var v) = Just v
681 unpackTrivial (Cast e _) = unpackTrivial e
682 unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e
683 unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
684 unpackTrivial _ = Nothing
685
686 -- | If given the RHS of a let-binding, this 'useLetUp' determines
687 -- whether we should process the binding up (body before rhs) or
688 -- down (rhs before body).
689 --
690 -- We use LetDown if there is a chance to get a useful strictness signature.
691 -- This is the case when there are manifest value lambdas or the binding is a
692 -- join point (hence always acts like a function, not a value).
693 useLetUp :: Var -> CoreExpr -> Bool
694 useLetUp f _ | isJoinId f = False
695 useLetUp f (Lam v e) | isTyVar v = useLetUp f e
696 useLetUp _ (Lam _ _) = False
697 useLetUp _ _ = True
698
699
700 {- Note [Demand analysis for join points]
701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
702 Consider
703 g :: (Int,Int) -> Int
704 g (p,q) = p+q
705
706 f :: T -> Int -> Int
707 f x p = g (join j y = (p,y)
708 in case x of
709 A -> j 3
710 B -> j 4
711 C -> (p,7))
712
713 If j was a vanilla function definition, we'd analyse its body with
714 evalDmd, and think that it was lazy in p. But for join points we can
715 do better! We know that j's body will (if called at all) be evaluated
716 with the demand that consumes the entire join-binding, in this case
717 the argument demand from g. Whizzo! g evaluates both components of
718 its argument pair, so p will certainly be evaluated if j is called.
719
720 For f to be strict in p, we need /all/ paths to evaluate p; in this
721 case the C branch does so too, so we are fine. So, as usual, we need
722 to transport demands on free variables to the call site(s). Compare
723 Note [Lazy and unleashable free variables].
724
725 The implementation is easy. When analysing a join point, we can
726 analyse its body with the demand from the entire join-binding (written
727 let_dmd here).
728
729 Another win for join points! #13543.
730
731 Note [Demand analysis for trivial right-hand sides]
732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733 Consider
734 foo = plusInt |> co
735 where plusInt is an arity-2 function with known strictness. Clearly
736 we want plusInt's strictness to propagate to foo! But because it has
737 no manifest lambdas, it won't do so automatically, and indeed 'co' might
738 have type (Int->Int->Int) ~ T, so we *can't* eta-expand. So we have a
739 special case for right-hand sides that are "trivial", namely variables,
740 casts, type applications, and the like.
741
742 Note that this can mean that 'foo' has an arity that is smaller than that
743 indicated by its demand info. e.g. if co :: (Int->Int->Int) ~ T, then
744 foo's arity will be zero (see Note [exprArity invariant] in CoreArity),
745 but its demand signature will be that of plusInt. A small example is the
746 test case of #8963.
747
748
749 Note [Product demands for function body]
750 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
751 This example comes from shootout/binary_trees:
752
753 Main.check' = \ b z ds. case z of z' { I# ip ->
754 case ds_d13s of
755 Main.Nil -> z'
756 Main.Node s14k s14l s14m ->
757 Main.check' (not b)
758 (Main.check' b
759 (case b {
760 False -> I# (-# s14h s14k);
761 True -> I# (+# s14h s14k)
762 })
763 s14l)
764 s14m } } }
765
766 Here we *really* want to unbox z, even though it appears to be used boxed in
767 the Nil case. Partly the Nil case is not a hot path. But more specifically,
768 the whole function gets the CPR property if we do.
769
770 So for the demand on the body of a RHS we use a product demand if it's
771 a product type.
772
773 ************************************************************************
774 * *
775 \subsection{Strictness signatures and types}
776 * *
777 ************************************************************************
778 -}
779
780 unitDmdType :: DmdEnv -> DmdType
781 unitDmdType dmd_env = DmdType dmd_env [] topRes
782
783 coercionDmdEnv :: Coercion -> DmdEnv
784 coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
785 -- The VarSet from coVarsOfCo is really a VarEnv Var
786
787 addVarDmd :: DmdType -> Var -> Demand -> DmdType
788 addVarDmd (DmdType fv ds res) var dmd
789 = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
790
791 addLazyFVs :: DmdType -> DmdEnv -> DmdType
792 addLazyFVs dmd_ty lazy_fvs
793 = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
794 -- Using bothDmdType (rather than just both'ing the envs)
795 -- is vital. Consider
796 -- let f = \x -> (x,y)
797 -- in error (f 3)
798 -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
799 -- demand with the bottom coming up from 'error'
800 --
801 -- I got a loop in the fixpointer without this, due to an interaction
802 -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was
803 -- letrec f n x
804 -- = letrec g y = x `fatbar`
805 -- letrec h z = z + ...g...
806 -- in h (f (n-1) x)
807 -- in ...
808 -- In the initial iteration for f, f=Bot
809 -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
810 -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
811 -- places on its free variables. Suppose it places none. Then the
812 -- x `fatbar` ...call to h...
813 -- will give a x->V demand for x. That turns into a L demand for x,
814 -- which floats out of the defn for h. Without the modifyEnv, that
815 -- L demand doesn't get both'd with the Bot coming up from the inner
816 -- call to f. So we just get an L demand for x for g.
817
818 {-
819 Note [Do not strictify the argument dictionaries of a dfun]
820 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
821 The typechecker can tie recursive knots involving dfuns, so we do the
822 conservative thing and refrain from strictifying a dfun's argument
823 dictionaries.
824 -}
825
826 setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
827 setBndrsDemandInfo (b:bs) (d:ds)
828 | isTyVar b = b : setBndrsDemandInfo bs (d:ds)
829 | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds
830 setBndrsDemandInfo [] ds = ASSERT( null ds ) []
831 setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs)
832
833 annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
834 -- The returned env has the var deleted
835 -- The returned var is annotated with demand info
836 -- according to the result demand of the provided demand type
837 -- No effect on the argument demands
838 annotateBndr env dmd_ty var
839 | isId var = (dmd_ty', setIdDemandInfo var dmd)
840 | otherwise = (dmd_ty, var)
841 where
842 (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
843
844 annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
845 annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
846 where
847 annotate dmd_ty bndr
848 | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr
849 | otherwise = (dmd_ty, bndr)
850
851 annotateLamIdBndr :: AnalEnv
852 -> DFunFlag -- is this lambda at the top of the RHS of a dfun?
853 -> DmdType -- Demand type of body
854 -> Id -- Lambda binder
855 -> (DmdType, -- Demand type of lambda
856 Id) -- and binder annotated with demand
857
858 annotateLamIdBndr env arg_of_dfun dmd_ty id
859 -- For lambdas we add the demand to the argument demands
860 -- Only called for Ids
861 = ASSERT( isId id )
862 -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
863 (final_ty, setIdDemandInfo id dmd)
864 where
865 -- Watch out! See note [Lambda-bound unfoldings]
866 final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
867 Nothing -> main_ty
868 Just unf -> main_ty `bothDmdType` unf_ty
869 where
870 (unf_ty, _) = dmdAnalStar env dmd unf
871
872 main_ty = addDemand dmd dmd_ty'
873 (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
874
875 deleteFVs :: DmdType -> [Var] -> DmdType
876 deleteFVs (DmdType fvs dmds res) bndrs
877 = DmdType (delVarEnvList fvs bndrs) dmds res
878
879 {-
880 Note [CPR for sum types]
881 ~~~~~~~~~~~~~~~~~~~~~~~~
882 At the moment we do not do CPR for let-bindings that
883 * non-top level
884 * bind a sum type
885 Reason: I found that in some benchmarks we were losing let-no-escapes,
886 which messed it all up. Example
887 let j = \x. ....
888 in case y of
889 True -> j False
890 False -> j True
891 If we w/w this we get
892 let j' = \x. ....
893 in case y of
894 True -> case j' False of { (# a #) -> Just a }
895 False -> case j' True of { (# a #) -> Just a }
896 Notice that j' is not a let-no-escape any more.
897
898 However this means in turn that the *enclosing* function
899 may be CPR'd (via the returned Justs). But in the case of
900 sums, there may be Nothing alternatives; and that messes
901 up the sum-type CPR.
902
903 Conclusion: only do this for products. It's still not
904 guaranteed OK for products, but sums definitely lose sometimes.
905
906 Note [CPR for thunks]
907 ~~~~~~~~~~~~~~~~~~~~~
908 If the rhs is a thunk, we usually forget the CPR info, because
909 it is presumably shared (else it would have been inlined, and
910 so we'd lose sharing if w/w'd it into a function). E.g.
911
912 let r = case expensive of
913 (a,b) -> (b,a)
914 in ...
915
916 If we marked r as having the CPR property, then we'd w/w into
917
918 let $wr = \() -> case expensive of
919 (a,b) -> (# b, a #)
920 r = case $wr () of
921 (# b,a #) -> (b,a)
922 in ...
923
924 But now r is a thunk, which won't be inlined, so we are no further ahead.
925 But consider
926
927 f x = let r = case expensive of (a,b) -> (b,a)
928 in if foo r then r else (x,x)
929
930 Does f have the CPR property? Well, no.
931
932 However, if the strictness analyser has figured out (in a previous
933 iteration) that it's strict, then we DON'T need to forget the CPR info.
934 Instead we can retain the CPR info and do the thunk-splitting transform
935 (see WorkWrap.splitThunk).
936
937 This made a big difference to PrelBase.modInt, which had something like
938 modInt = \ x -> let r = ... -> I# v in
939 ...body strict in r...
940 r's RHS isn't a value yet; but modInt returns r in various branches, so
941 if r doesn't have the CPR property then neither does modInt
942 Another case I found in practice (in Complex.magnitude), looks like this:
943 let k = if ... then I# a else I# b
944 in ... body strict in k ....
945 (For this example, it doesn't matter whether k is returned as part of
946 the overall result; but it does matter that k's RHS has the CPR property.)
947 Left to itself, the simplifier will make a join point thus:
948 let $j k = ...body strict in k...
949 if ... then $j (I# a) else $j (I# b)
950 With thunk-splitting, we get instead
951 let $j x = let k = I#x in ...body strict in k...
952 in if ... then $j a else $j b
953 This is much better; there's a good chance the I# won't get allocated.
954
955 The difficulty with this is that we need the strictness type to
956 look at the body... but we now need the body to calculate the demand
957 on the variable, so we can decide whether its strictness type should
958 have a CPR in it or not. Simple solution:
959 a) use strictness info from the previous iteration
960 b) make sure we do at least 2 iterations, by doing a second
961 round for top-level non-recs. Top level recs will get at
962 least 2 iterations except for totally-bottom functions
963 which aren't very interesting anyway.
964
965 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
966
967 Note [Optimistic CPR in the "virgin" case]
968 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
969 Demand and strictness info are initialized by top elements. However,
970 this prevents from inferring a CPR property in the first pass of the
971 analyser, so we keep an explicit flag ae_virgin in the AnalEnv
972 datatype.
973
974 We can't start with 'not-demanded' (i.e., top) because then consider
975 f x = let
976 t = ... I# x
977 in
978 if ... then t else I# y else f x'
979
980 In the first iteration we'd have no demand info for x, so assume
981 not-demanded; then we'd get TopRes for f's CPR info. Next iteration
982 we'd see that t was demanded, and so give it the CPR property, but by
983 now f has TopRes, so it will stay TopRes. Instead, by checking the
984 ae_virgin flag at the first time round, we say 'yes t is demanded' the
985 first time.
986
987 However, this does mean that for non-recursive bindings we must
988 iterate twice to be sure of not getting over-optimistic CPR info,
989 in the case where t turns out to be not-demanded. This is handled
990 by dmdAnalTopBind.
991
992
993 Note [NOINLINE and strictness]
994 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
995 The strictness analyser used to have a HACK which ensured that NOINLNE
996 things were not strictness-analysed. The reason was unsafePerformIO.
997 Left to itself, the strictness analyser would discover this strictness
998 for unsafePerformIO:
999 unsafePerformIO: C(U(AV))
1000 But then consider this sub-expression
1001 unsafePerformIO (\s -> let r = f x in
1002 case writeIORef v r s of (# s1, _ #) ->
1003 (# s1, r #)
1004 The strictness analyser will now find that r is sure to be eval'd,
1005 and may then hoist it out. This makes tests/lib/should_run/memo002
1006 deadlock.
1007
1008 Solving this by making all NOINLINE things have no strictness info is overkill.
1009 In particular, it's overkill for runST, which is perfectly respectable.
1010 Consider
1011 f x = runST (return x)
1012 This should be strict in x.
1013
1014 So the new plan is to define unsafePerformIO using the 'lazy' combinator:
1015
1016 unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
1017
1018 Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
1019 magically NON-STRICT, and is inlined after strictness analysis. So
1020 unsafePerformIO will look non-strict, and that's what we want.
1021
1022 Now we don't need the hack in the strictness analyser. HOWEVER, this
1023 decision does mean that even a NOINLINE function is not entirely
1024 opaque: some aspect of its implementation leaks out, notably its
1025 strictness. For example, if you have a function implemented by an
1026 error stub, but which has RULES, you may want it not to be eliminated
1027 in favour of error!
1028
1029 Note [Lazy and unleashable free variables]
1030 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1031 We put the strict and once-used FVs in the DmdType of the Id, so
1032 that at its call sites we unleash demands on its strict fvs.
1033 An example is 'roll' in imaginary/wheel-sieve2
1034 Something like this:
1035 roll x = letrec
1036 go y = if ... then roll (x-1) else x+1
1037 in
1038 go ms
1039 We want to see that roll is strict in x, which is because
1040 go is called. So we put the DmdEnv for x in go's DmdType.
1041
1042 Another example:
1043
1044 f :: Int -> Int -> Int
1045 f x y = let t = x+1
1046 h z = if z==0 then t else
1047 if z==1 then x+1 else
1048 x + h (z-1)
1049 in h y
1050
1051 Calling h does indeed evaluate x, but we can only see
1052 that if we unleash a demand on x at the call site for t.
1053
1054 Incidentally, here's a place where lambda-lifting h would
1055 lose the cigar --- we couldn't see the joint strictness in t/x
1056
1057 ON THE OTHER HAND
1058
1059 We don't want to put *all* the fv's from the RHS into the
1060 DmdType. Because
1061
1062 * it makes the strictness signatures larger, and hence slows down fixpointing
1063
1064 and
1065
1066 * it is useless information at the call site anyways:
1067 For lazy, used-many times fv's we will never get any better result than
1068 that, no matter how good the actual demand on the function at the call site
1069 is (unless it is always absent, but then the whole binder is useless).
1070
1071 Therefore we exclude lazy multiple-used fv's from the environment in the
1072 DmdType.
1073
1074 But now the signature lies! (Missing variables are assumed to be absent.) To
1075 make up for this, the code that analyses the binding keeps the demand on those
1076 variable separate (usually called "lazy_fv") and adds it to the demand of the
1077 whole binding later.
1078
1079 What if we decide _not_ to store a strictness signature for a binding at all, as
1080 we do when aborting a fixed-point iteration? The we risk losing the information
1081 that the strict variables are being used. In that case, we take all free variables
1082 mentioned in the (unsound) strictness signature, conservatively approximate the
1083 demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
1084
1085
1086 Note [Lambda-bound unfoldings]
1087 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1088 We allow a lambda-bound variable to carry an unfolding, a facility that is used
1089 exclusively for join points; see Note [Case binders and join points]. If so,
1090 we must be careful to demand-analyse the RHS of the unfolding! Example
1091 \x. \y{=Just x}. <body>
1092 Then if <body> uses 'y', then transitively it uses 'x', and we must not
1093 forget that fact, otherwise we might make 'x' absent when it isn't.
1094
1095
1096 ************************************************************************
1097 * *
1098 \subsection{Strictness signatures}
1099 * *
1100 ************************************************************************
1101 -}
1102
1103 type DFunFlag = Bool -- indicates if the lambda being considered is in the
1104 -- sequence of lambdas at the top of the RHS of a dfun
1105 notArgOfDfun :: DFunFlag
1106 notArgOfDfun = False
1107
1108 data AnalEnv
1109 = AE { ae_dflags :: DynFlags
1110 , ae_sigs :: SigEnv
1111 , ae_virgin :: Bool -- True on first iteration only
1112 -- See Note [Initialising strictness]
1113 , ae_rec_tc :: RecTcChecker
1114 , ae_fam_envs :: FamInstEnvs
1115 }
1116
1117 -- We use the se_env to tell us whether to
1118 -- record info about a variable in the DmdEnv
1119 -- We do so if it's a LocalId, but not top-level
1120 --
1121 -- The DmdEnv gives the demand on the free vars of the function
1122 -- when it is given enough args to satisfy the strictness signature
1123
1124 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
1125
1126 instance Outputable AnalEnv where
1127 ppr (AE { ae_sigs = env, ae_virgin = virgin })
1128 = text "AE" <+> braces (vcat
1129 [ text "ae_virgin =" <+> ppr virgin
1130 , text "ae_sigs =" <+> ppr env ])
1131
1132 emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
1133 emptyAnalEnv dflags fam_envs
1134 = AE { ae_dflags = dflags
1135 , ae_sigs = emptySigEnv
1136 , ae_virgin = True
1137 , ae_rec_tc = initRecTc
1138 , ae_fam_envs = fam_envs
1139 }
1140
1141 emptySigEnv :: SigEnv
1142 emptySigEnv = emptyVarEnv
1143
1144 -- | Extend an environment with the strictness IDs attached to the id
1145 extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
1146 extendAnalEnvs top_lvl env vars
1147 = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
1148
1149 extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
1150 extendSigEnvs top_lvl sigs vars
1151 = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
1152
1153 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
1154 extendAnalEnv top_lvl env var sig
1155 = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
1156
1157 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
1158 extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
1159
1160 lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
1161 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
1162
1163 getStrictness :: AnalEnv -> Id -> StrictSig
1164 getStrictness env fn
1165 | isGlobalId fn = idStrictness fn
1166 | Just (sig, _) <- lookupSigEnv env fn = sig
1167 | otherwise = nopSig
1168
1169 nonVirgin :: AnalEnv -> AnalEnv
1170 nonVirgin env = env { ae_virgin = False }
1171
1172 extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
1173 -- Extend the AnalEnv when we meet a lambda binder
1174 extendSigsWithLam env id
1175 | isId id
1176 , isStrictDmd (idDemandInfo id) || ae_virgin env
1177 -- See Note [Optimistic CPR in the "virgin" case]
1178 -- See Note [Initial CPR for strict binders]
1179 , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
1180 = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
1181
1182 | otherwise
1183 = env
1184
1185 extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
1186 -- See Note [CPR in a product case alternative]
1187 extendEnvForProdAlt env scrut case_bndr dc bndrs
1188 = foldl' do_con_arg env1 ids_w_strs
1189 where
1190 env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
1191
1192 ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc
1193 case_bndr_sig = cprProdSig (dataConRepArity dc)
1194 fam_envs = ae_fam_envs env
1195
1196 do_con_arg env (id, str)
1197 | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str
1198 , ae_virgin env || (is_var_scrut && is_strict) -- See Note [CPR in a product case alternative]
1199 , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id
1200 = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
1201 | otherwise
1202 = env
1203
1204 is_var_scrut = is_var scrut
1205 is_var (Cast e _) = is_var e
1206 is_var (Var v) = isLocalId v
1207 is_var _ = False
1208
1209 findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
1210 -- Return the demands on the Ids in the [Var]
1211 findBndrsDmds env dmd_ty bndrs
1212 = go dmd_ty bndrs
1213 where
1214 go dmd_ty [] = (dmd_ty, [])
1215 go dmd_ty (b:bs)
1216 | isId b = let (dmd_ty1, dmds) = go dmd_ty bs
1217 (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b
1218 in (dmd_ty2, dmd : dmds)
1219 | otherwise = go dmd_ty bs
1220
1221 findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
1222 -- See Note [Trimming a demand to a type] in Demand.hs
1223 findBndrDmd env arg_of_dfun dmd_ty id
1224 = (dmd_ty', dmd')
1225 where
1226 dmd' = killUsageDemand (ae_dflags env) $
1227 strictify $
1228 trimToType starting_dmd (findTypeShape fam_envs id_ty)
1229
1230 (dmd_ty', starting_dmd) = peelFV dmd_ty id
1231
1232 id_ty = idType id
1233
1234 strictify dmd
1235 | gopt Opt_DictsStrict (ae_dflags env)
1236 -- We never want to strictify a recursive let. At the moment
1237 -- annotateBndr is only call for non-recursive lets; if that
1238 -- changes, we need a RecFlag parameter and another guard here.
1239 , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
1240 = strictifyDictDmd id_ty dmd
1241 | otherwise
1242 = dmd
1243
1244 fam_envs = ae_fam_envs env
1245
1246 set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
1247 set_idStrictness env id sig
1248 = setIdStrictness id (killUsageSig (ae_dflags env) sig)
1249
1250 dumpStrSig :: CoreProgram -> SDoc
1251 dumpStrSig binds = vcat (map printId ids)
1252 where
1253 ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
1254 getIds (NonRec i _) = [ i ]
1255 getIds (Rec bs) = map fst bs
1256 printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
1257 | otherwise = empty
1258
1259 {- Note [CPR in a product case alternative]
1260 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1261 In a case alternative for a product type, we want to give some of the
1262 binders the CPR property. Specifically
1263
1264 * The case binder; inside the alternative, the case binder always has
1265 the CPR property, meaning that a case on it will successfully cancel.
1266 Example:
1267 f True x = case x of y { I# x' -> if x' ==# 3
1268 then y
1269 else I# 8 }
1270 f False x = I# 3
1271
1272 By giving 'y' the CPR property, we ensure that 'f' does too, so we get
1273 f b x = case fw b x of { r -> I# r }
1274 fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
1275 fw False x = 3
1276
1277 Of course there is the usual risk of re-boxing: we have 'x' available
1278 boxed and unboxed, but we return the unboxed version for the wrapper to
1279 box. If the wrapper doesn't cancel with its caller, we'll end up
1280 re-boxing something that we did have available in boxed form.
1281
1282 * Any strict binders with product type, can use
1283 Note [Initial CPR for strict binders]. But we can go a little
1284 further. Consider
1285
1286 data T = MkT !Int Int
1287
1288 f2 (MkT x y) | y>0 = f2 (MkT x (y-1))
1289 | otherwise = x
1290
1291 For $wf2 we are going to unbox the MkT *and*, since it is strict, the
1292 first argument of the MkT; see Note [Add demands for strict constructors]
1293 in WwLib. But then we don't want box it up again when returning it! We want
1294 'f2' to have the CPR property, so we give 'x' the CPR property.
1295
1296 * It's a bit delicate because if this case is scrutinising something other
1297 than an argument the original function, we really don't have the unboxed
1298 version available. E.g
1299 g v = case foo v of
1300 MkT x y | y>0 -> ...
1301 | otherwise -> x
1302 Here we don't have the unboxed 'x' available. Hence the
1303 is_var_scrut test when making use of the strictness annotation.
1304 Slightly ad-hoc, because even if the scrutinee *is* a variable it
1305 might not be a onre of the arguments to the original function, or a
1306 sub-component thereof. But it's simple, and nothing terrible
1307 happens if we get it wrong. e.g. #10694.
1308
1309
1310 Note [Initial CPR for strict binders]
1311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1312 CPR is initialized for a lambda binder in an optimistic manner, i.e,
1313 if the binder is used strictly and at least some of its components as
1314 a product are used, which is checked by the value of the absence
1315 demand.
1316
1317 If the binder is marked demanded with a strict demand, then give it a
1318 CPR signature. Here's a concrete example ('f1' in test T10482a),
1319 assuming h is strict:
1320
1321 f1 :: Int -> Int
1322 f1 x = case h x of
1323 A -> x
1324 B -> f1 (x-1)
1325 C -> x+1
1326
1327 If we notice that 'x' is used strictly, we can give it the CPR
1328 property; and hence f1 gets the CPR property too. It's sound (doesn't
1329 change strictness) to give it the CPR property because by the time 'x'
1330 is returned (case A above), it'll have been evaluated (by the wrapper
1331 of 'h' in the example).
1332
1333 Moreover, if f itself is strict in x, then we'll pass x unboxed to
1334 f1, and so the boxed version *won't* be available; in that case it's
1335 very helpful to give 'x' the CPR property.
1336
1337 Note that
1338
1339 * We only want to do this for something that definitely
1340 has product type, else we may get over-optimistic CPR results
1341 (e.g. from \x -> x!).
1342
1343 * See Note [CPR examples]
1344
1345 Note [CPR examples]
1346 ~~~~~~~~~~~~~~~~~~~~
1347 Here are some examples (stranal/should_compile/T10482a) of the
1348 usefulness of Note [CPR in a product case alternative]. The main
1349 point: all of these functions can have the CPR property.
1350
1351 ------- f1 -----------
1352 -- x is used strictly by h, so it'll be available
1353 -- unboxed before it is returned in the True branch
1354
1355 f1 :: Int -> Int
1356 f1 x = case h x x of
1357 True -> x
1358 False -> f1 (x-1)
1359
1360
1361 ------- f2 -----------
1362 -- x is a strict field of MkT2, so we'll pass it unboxed
1363 -- to $wf2, so it's available unboxed. This depends on
1364 -- the case expression analysing (a subcomponent of) one
1365 -- of the original arguments to the function, so it's
1366 -- a bit more delicate.
1367
1368 data T2 = MkT2 !Int Int
1369
1370 f2 :: T2 -> Int
1371 f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1))
1372 | otherwise = x
1373
1374
1375 ------- f3 -----------
1376 -- h is strict in x, so x will be unboxed before it
1377 -- is rerturned in the otherwise case.
1378
1379 data T3 = MkT3 Int Int
1380
1381 f1 :: T3 -> Int
1382 f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1))
1383 | otherwise = x
1384
1385
1386 ------- f4 -----------
1387 -- Just like f2, but MkT4 can't unbox its strict
1388 -- argument automatically, as f2 can
1389
1390 data family Foo a
1391 newtype instance Foo Int = Foo Int
1392
1393 data T4 a = MkT4 !(Foo a) Int
1394
1395 f4 :: T4 Int -> Int
1396 f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1))
1397 | otherwise = v
1398
1399
1400 Note [Initialising strictness]
1401 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1402 See section 9.2 (Finding fixpoints) of the paper.
1403
1404 Our basic plan is to initialise the strictness of each Id in a
1405 recursive group to "bottom", and find a fixpoint from there. However,
1406 this group B might be inside an *enclosing* recursive group A, in
1407 which case we'll do the entire fixpoint shebang on for each iteration
1408 of A. This can be illustrated by the following example:
1409
1410 Example:
1411
1412 f [] = []
1413 f (x:xs) = let g [] = f xs
1414 g (y:ys) = y+1 : g ys
1415 in g (h x)
1416
1417 At each iteration of the fixpoint for f, the analyser has to find a
1418 fixpoint for the enclosed function g. In the meantime, the demand
1419 values for g at each iteration for f are *greater* than those we
1420 encountered in the previous iteration for f. Therefore, we can begin
1421 the fixpoint for g not with the bottom value but rather with the
1422 result of the previous analysis. I.e., when beginning the fixpoint
1423 process for g, we can start from the demand signature computed for g
1424 previously and attached to the binding occurrence of g.
1425
1426 To speed things up, we initialise each iteration of A (the enclosing
1427 one) from the result of the last one, which is neatly recorded in each
1428 binder. That way we make use of earlier iterations of the fixpoint
1429 algorithm. (Cunning plan.)
1430
1431 But on the *first* iteration we want to *ignore* the current strictness
1432 of the Id, and start from "bottom". Nowadays the Id can have a current
1433 strictness, because interface files record strictness for nested bindings.
1434 To know when we are in the first iteration, we look at the ae_virgin
1435 field of the AnalEnv.
1436
1437
1438 Note [Final Demand Analyser run]
1439 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1440 Some of the information that the demand analyser determines is not always
1441 preserved by the simplifier. For example, the simplifier will happily rewrite
1442 \y [Demand=1*U] let x = y in x + x
1443 to
1444 \y [Demand=1*U] y + y
1445 which is quite a lie.
1446
1447 The once-used information is (currently) only used by the code
1448 generator, though. So:
1449
1450 * We zap the used-once info in the worker-wrapper;
1451 see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's
1452 not reliable, it's better not to have it at all.
1453
1454 * Just before TidyCore, we add a pass of the demand analyser,
1455 but WITHOUT subsequent worker/wrapper and simplifier,
1456 right before TidyCore. See SimplCore.getCoreToDo.
1457
1458 This way, correct information finds its way into the module interface
1459 (strictness signatures!) and the code generator (single-entry thunks!)
1460
1461 Note that, in contrast, the single-call information (C1(..)) /can/ be
1462 relied upon, as the simplifier tends to be very careful about not
1463 duplicating actual function calls.
1464
1465 Also see #11731.
1466 -}