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