2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
10 module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
11 both {- needed by WwLib -}
14 #include "HsVersions.h"
16 import DynFlags ( DynFlags, DynFlag(..) )
17 import StaticFlags ( opt_MaxWorkerArgs )
18 import NewDemand -- All of it
21 import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )
22 import DataCon ( dataConTyCon )
23 import TyCon ( isProductTyCon, isRecursiveTyCon )
24 import Id ( Id, idType, idInlinePragma,
25 isDataConWorkId, isGlobalId, idArity,
27 idDemandInfo, idStrictness, idCprInfo, idName,
29 idNewStrictness, idNewStrictness_maybe,
30 setIdNewStrictness, idNewDemandInfo,
31 idNewDemandInfo_maybe,
35 import IdInfo ( newStrictnessFromOld, newDemand )
39 import TysWiredIn ( unboxedPairDataCon )
40 import TysPrim ( realWorldStatePrimTy )
41 import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
42 keysUFM, minusUFM, ufmToList, filterUFM )
43 import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
44 import Coercion ( coercionKind )
45 import CoreLint ( showPass, endPass )
46 import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
47 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
49 import Maybes ( orElse, expectJust )
55 * set a noinline pragma on bottoming Ids
57 * Consider f x = x+1 `fatbar` error (show x)
58 We'd like to unbox x, even if that means reboxing it in the error case.
61 %************************************************************************
63 \subsection{Top level stuff}
65 %************************************************************************
68 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
69 dmdAnalPgm dflags binds
71 showPass dflags "Demand analysis" ;
72 let { binds_plus_dmds = do_prog binds } ;
74 endPass dflags "Demand analysis"
75 Opt_D_dump_stranal binds_plus_dmds ;
77 -- Only if OLD_STRICTNESS is on, because only then is the old
78 -- strictness analyser run
79 let { dmd_changes = get_changes binds_plus_dmds } ;
80 printDump (text "Changes in demands" $$ dmd_changes) ;
82 return binds_plus_dmds
85 do_prog :: [CoreBind] -> [CoreBind]
86 do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
88 dmdAnalTopBind :: SigEnv
91 dmdAnalTopBind sigs (NonRec id rhs)
93 ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs)
94 (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1)
95 -- Do two passes to improve CPR information
96 -- See comments with ignore_cpr_info in mk_sig_ty
97 -- and with extendSigsWithLam
99 (sigs2, NonRec id2 rhs2)
101 dmdAnalTopBind sigs (Rec pairs)
103 (sigs', _, pairs') = dmdFix TopLevel sigs pairs
104 -- We get two iterations automatically
105 -- c.f. the NonRec case above
111 dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
112 -- Analyse the RHS and return
113 -- a) appropriate strictness info
114 -- b) the unfolding (decorated with stricntess info)
118 call_dmd = vanillaCall (exprArity rhs)
119 (_, rhs1) = dmdAnal emptySigEnv call_dmd rhs
120 (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1
121 sig = mkTopSigTy rhs rhs_ty
122 -- Do two passes; see notes with extendSigsWithLam
123 -- Otherwise we get bogus CPR info for constructors like
124 -- newtype T a = MkT a
125 -- The constructor looks like (\x::T a -> x), modulo the coerce
126 -- extendSigsWithLam will optimistically give x a CPR tag the
127 -- first time, which is wrong in the end.
130 %************************************************************************
132 \subsection{The analyser itself}
134 %************************************************************************
137 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
139 dmdAnal sigs Abs e = (topDmdType, e)
142 | not (isStrictDmd dmd)
144 (res_ty, e') = dmdAnal sigs evalDmd e
146 (deferType res_ty, e')
147 -- It's important not to analyse e with a lazy demand because
148 -- a) When we encounter case s of (a,b) ->
149 -- we demand s with U(d1d2)... but if the overall demand is lazy
150 -- that is wrong, and we'd need to reduce the demand on s,
151 -- which is inconvenient
152 -- b) More important, consider
153 -- f (let x = R in x+x), where f is lazy
154 -- We still want to mark x as demanded, because it will be when we
155 -- enter the let. If we analyse f's arg with a Lazy demand, we'll
156 -- just mark x as Lazy
157 -- c) The application rule wouldn't be right either
158 -- Evaluating (f x) in a L demand does *not* cause
159 -- evaluation of f in a C(L) demand!
162 dmdAnal sigs dmd (Lit lit)
163 = (topDmdType, Lit lit)
165 dmdAnal sigs dmd (Var var)
166 = (dmdTransform sigs var dmd, Var var)
168 dmdAnal sigs dmd (Cast e co)
169 = (dmd_ty, Cast e' co)
171 (dmd_ty, e') = dmdAnal sigs dmd' e
172 to_co = snd (coercionKind co)
174 -- | Just (tc, args) <- splitTyConApp_maybe to_co
176 -- , isRecursiveTyCon tc = evalDmd
178 -- This coerce usually arises from a recursive
179 -- newtype, and we don't want to look inside them
180 -- for exactly the same reason that we don't look
181 -- inside recursive products -- we might not reach
182 -- a fixpoint. So revert to a vanilla Eval demand
184 dmdAnal sigs dmd (Note n e)
185 = (dmd_ty, Note n e')
187 (dmd_ty, e') = dmdAnal sigs dmd e
189 dmdAnal sigs dmd (App fun (Type ty))
190 = (fun_ty, App fun' (Type ty))
192 (fun_ty, fun') = dmdAnal sigs dmd fun
194 -- Lots of the other code is there to make this
195 -- beautiful, compositional, application rule :-)
196 dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
197 = let -- [Type arg handled above]
198 (fun_ty, fun') = dmdAnal sigs (Call dmd) fun
199 (arg_ty, arg') = dmdAnal sigs arg_dmd arg
200 (arg_dmd, res_ty) = splitDmdTy fun_ty
202 (res_ty `bothType` arg_ty, App fun' arg')
204 dmdAnal sigs dmd (Lam var body)
207 (body_ty, body') = dmdAnal sigs dmd body
209 (body_ty, Lam var body')
211 | Call body_dmd <- dmd -- A call demand: good!
213 sigs' = extendSigsWithLam sigs var
214 (body_ty, body') = dmdAnal sigs' body_dmd body
215 (lam_ty, var') = annotateLamIdBndr body_ty var
217 (lam_ty, Lam var' body')
219 | otherwise -- Not enough demand on the lambda; but do the body
220 = let -- anyway to annotate it and gather free var info
221 (body_ty, body') = dmdAnal sigs evalDmd body
222 (lam_ty, var') = annotateLamIdBndr body_ty var
224 (deferType lam_ty, Lam var' body')
226 dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
227 | let tycon = dataConTyCon dc,
228 isProductTyCon tycon,
229 not (isRecursiveTyCon tycon)
231 sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
232 (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt
233 (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
234 (_, bndrs', _) = alt'
235 case_bndr_sig = cprSig
236 -- Inside the alternative, the case binder has the CPR property.
237 -- Meaning that a case on it will successfully cancel.
239 -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
242 -- We want f to have the CPR property:
243 -- f b x = case fw b x of { r -> I# r }
244 -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
247 -- Figure out whether the demand on the case binder is used, and use
248 -- that to set the scrut_dmd. This is utterly essential.
249 -- Consider f x = case x of y { (a,b) -> k y a }
250 -- If we just take scrut_demand = U(L,A), then we won't pass x to the
251 -- worker, so the worker will rebuild
252 -- x = (a, absent-error)
253 -- and that'll crash.
254 -- So at one stage I had:
255 -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
256 -- keepity | dead_case_bndr = Drop
257 -- | otherwise = Keep
260 -- case x of y { (a,b) -> h y + a }
261 -- where h : U(LL) -> T
262 -- The above code would compute a Keep for x, since y is not Abs, which is silly
263 -- The insight is, of course, that a demand on y is a demand on the
264 -- scrutinee, so we need to `both` it with the scrut demand
266 scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
268 idNewDemandInfo case_bndr'
270 (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
272 (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
274 dmdAnal sigs dmd (Case scrut case_bndr ty alts)
276 (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
277 (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
278 (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
280 -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
281 (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
283 dmdAnal sigs dmd (Let (NonRec id rhs) body)
285 (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)
286 (body_ty, body') = dmdAnal sigs' dmd body
287 (body_ty1, id2) = annotateBndr body_ty id1
288 body_ty2 = addLazyFVs body_ty1 lazy_fv
290 -- If the actual demand is better than the vanilla call
291 -- demand, you might think that we might do better to re-analyse
292 -- the RHS with the stronger demand.
293 -- But (a) That seldom happens, because it means that *every* path in
294 -- the body of the let has to use that stronger demand
295 -- (b) It often happens temporarily in when fixpointing, because
296 -- the recursive function at first seems to place a massive demand.
297 -- But we don't want to go to extra work when the function will
298 -- probably iterate to something less demanding.
299 -- In practice, all the times the actual demand on id2 is more than
300 -- the vanilla call demand seem to be due to (b). So we don't
301 -- bother to re-analyse the RHS.
302 (body_ty2, Let (NonRec id2 rhs') body')
304 dmdAnal sigs dmd (Let (Rec pairs) body)
306 bndrs = map fst pairs
307 (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs
308 (body_ty, body') = dmdAnal sigs' dmd body
309 body_ty1 = addLazyFVs body_ty lazy_fv
311 sigs' `seq` body_ty `seq`
313 (body_ty2, _) = annotateBndrs body_ty1 bndrs
314 -- Don't bother to add demand info to recursive
315 -- binders as annotateBndr does;
316 -- being recursive, we can't treat them strictly.
317 -- But we do need to remove the binders from the result demand env
319 (body_ty2, Let (Rec pairs') body')
322 dmdAnalAlt sigs dmd (con,bndrs,rhs)
324 (rhs_ty, rhs') = dmdAnal sigs dmd rhs
325 (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
326 final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
329 -- There's a hack here for I/O operations. Consider
330 -- case foo x s of { (# s, r #) -> y }
331 -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O
332 -- operation that simply terminates the program (not in an erroneous way)?
333 -- In that case we should not evaluate y before the call to 'foo'.
334 -- Hackish solution: spot the IO-like situation and add a virtual branch,
338 -- other -> return ()
339 -- So the 'y' isn't necessarily going to be evaluated
341 -- A more complete example where this shows up is:
342 -- do { let len = <expensive> ;
343 -- ; when (...) (exitWith ExitSuccess)
346 io_hack_reqd = con == DataAlt unboxedPairDataCon &&
347 idType (head bndrs) `coreEqType` realWorldStatePrimTy
349 (final_alt_ty, (con, bndrs', rhs'))
352 %************************************************************************
354 \subsection{Bindings}
356 %************************************************************************
359 dmdFix :: TopLevelFlag
360 -> SigEnv -- Does not include bindings for this binding
363 [(Id,CoreExpr)]) -- Binders annotated with stricness info
365 dmdFix top_lvl sigs orig_pairs
366 = loop 1 initial_sigs orig_pairs
368 bndrs = map fst orig_pairs
369 initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs]
372 -> SigEnv -- Already contains the current sigs
374 -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
377 = (sigs', lazy_fv, pairs')
378 -- Note: use pairs', not pairs. pairs' is the result of
379 -- processing the RHSs with sigs (= sigs'), whereas pairs
380 -- is the result of processing the RHSs with the *previous*
381 -- iteration of sigs.
383 | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat
384 [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
385 text "env:" <+> ppr (ufmToList sigs),
386 text "binds:" <+> pprCoreBinding (Rec pairs)]))
387 (emptySigEnv, lazy_fv, orig_pairs) -- Safe output
388 -- The lazy_fv part is really important! orig_pairs has no strictness
389 -- info, including nothing about free vars. But if we have
390 -- letrec f = ....y..... in ...f...
391 -- where 'y' is free in f, we must record that y is mentioned,
392 -- otherwise y will get recorded as absent altogether
394 | otherwise = loop (n+1) sigs' pairs'
396 found_fixpoint = all (same_sig sigs sigs') bndrs
397 -- Use the new signature to do the next pair
398 -- The occurrence analyser has arranged them in a good order
399 -- so this can significantly reduce the number of iterations needed
400 ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs
402 my_downRhs top_lvl (sigs,lazy_fv) (id,rhs)
403 = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig))
405 -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' )
406 ((sigs', lazy_fv'), pair')
409 (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
410 lazy_fv' = plusUFM_C both lazy_fv lazy_fv1
411 -- old_sig = lookup sigs id
412 -- new_sig = lookup sigs' id
414 same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
415 lookup sigs var = case lookupVarEnv sigs var of
418 -- Get an initial strictness signature from the Id
419 -- itself. That way we make use of earlier iterations
420 -- of the fixpoint algorithm. (Cunning plan.)
421 -- Note that the cunning plan extends to the DmdEnv too,
422 -- since it is part of the strictness signature
423 initialSig id = idNewStrictness_maybe id `orElse` botSig
425 dmdAnalRhs :: TopLevelFlag -> RecFlag
426 -> SigEnv -> (Id, CoreExpr)
427 -> (SigEnv, DmdEnv, (Id, CoreExpr))
428 -- Process the RHS of the binding, add the strictness signature
429 -- to the Id, and augment the environment with the signature as well.
431 dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
432 = (sigs', lazy_fv, (id', rhs'))
434 arity = idArity id -- The idArity should be up to date
435 -- The simplifier was run just beforehand
436 (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
437 (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
438 -- The RHS can be eta-reduced to just a variable,
439 -- in which case we should not complain.
440 mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
441 id' = id `setIdNewStrictness` sig_ty
442 sigs' = extendSigEnv top_lvl sigs id sig_ty
445 %************************************************************************
447 \subsection{Strictness signatures and types}
449 %************************************************************************
452 mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
453 -- Take a DmdType and turn it into a StrictSig
454 -- NB: not used for never-inline things; hence False
455 mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
457 mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
458 mkSigTy top_lvl rec_flag id rhs dmd_ty
459 = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
461 never_inline = isNeverActive (idInlinePragma id)
462 maybe_id_dmd = idNewDemandInfo_maybe id
463 -- Is Nothing the first time round
466 | isTopLevel top_lvl = False -- Top level things don't get
467 -- their demandInfo set at all
468 | isRec rec_flag = False -- Ditto recursive things
469 | Just dmd <- maybe_id_dmd = isStrictDmd dmd
470 | otherwise = True -- Optimistic, first time round
474 The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]
475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
476 If the rhs is a thunk, we usually forget the CPR info, because
477 it is presumably shared (else it would have been inlined, and
478 so we'd lose sharing if w/w'd it into a function.
480 However, if the strictness analyser has figured out (in a previous
481 iteration) that it's strict, then we DON'T need to forget the CPR info.
482 Instead we can retain the CPR info and do the thunk-splitting transform
483 (see WorkWrap.splitThunk).
485 This made a big difference to PrelBase.modInt, which had something like
486 modInt = \ x -> let r = ... -> I# v in
487 ...body strict in r...
488 r's RHS isn't a value yet; but modInt returns r in various branches, so
489 if r doesn't have the CPR property then neither does modInt
490 Another case I found in practice (in Complex.magnitude), looks like this:
491 let k = if ... then I# a else I# b
492 in ... body strict in k ....
493 (For this example, it doesn't matter whether k is returned as part of
494 the overall result; but it does matter that k's RHS has the CPR property.)
495 Left to itself, the simplifier will make a join point thus:
496 let $j k = ...body strict in k...
497 if ... then $j (I# a) else $j (I# b)
498 With thunk-splitting, we get instead
499 let $j x = let k = I#x in ...body strict in k...
500 in if ... then $j a else $j b
501 This is much better; there's a good chance the I# won't get allocated.
503 The difficulty with this is that we need the strictness type to
504 look at the body... but we now need the body to calculate the demand
505 on the variable, so we can decide whether its strictness type should
506 have a CPR in it or not. Simple solution:
507 a) use strictness info from the previous iteration
508 b) make sure we do at least 2 iterations, by doing a second
509 round for top-level non-recs. Top level recs will get at
510 least 2 iterations except for totally-bottom functions
511 which aren't very interesting anyway.
513 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
515 The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS]
516 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
517 Demand info now has a 'Nothing' state, just like strictness info.
518 The analysis works from 'dangerous' towards a 'safe' state; so we
519 start with botSig for 'Nothing' strictness infos, and we start with
520 "yes, it's demanded" for 'Nothing' in the demand info. The
521 fixpoint iteration will sort it all out.
523 We can't start with 'not-demanded' because then consider
527 if ... then t else I# y else f x'
529 In the first iteration we'd have no demand info for x, so assume
530 not-demanded; then we'd get TopRes for f's CPR info. Next iteration
531 we'd see that t was demanded, and so give it the CPR property, but by
532 now f has TopRes, so it will stay TopRes. Instead, with the Nothing
533 setting the first time round, we say 'yes t is demanded' the first
536 However, this does mean that for non-recursive bindings we must
537 iterate twice to be sure of not getting over-optimistic CPR info,
538 in the case where t turns out to be not-demanded. This is handled
543 mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
544 = (lazy_fv, mkStrictSig dmd_ty)
546 dmd_ty = DmdType strict_fv final_dmds res'
548 lazy_fv = filterUFM (not . isStrictDmd) fv
549 strict_fv = filterUFM isStrictDmd fv
550 -- We put the strict FVs in the DmdType of the Id, so
551 -- that at its call sites we unleash demands on its strict fvs.
552 -- An example is 'roll' in imaginary/wheel-sieve2
553 -- Something like this:
555 -- go y = if ... then roll (x-1) else x+1
558 -- We want to see that roll is strict in x, which is because
559 -- go is called. So we put the DmdEnv for x in go's DmdType.
562 -- f :: Int -> Int -> Int
563 -- f x y = let t = x+1
564 -- h z = if z==0 then t else
565 -- if z==1 then x+1 else
569 -- Calling h does indeed evaluate x, but we can only see
570 -- that if we unleash a demand on x at the call site for t.
572 -- Incidentally, here's a place where lambda-lifting h would
573 -- lose the cigar --- we couldn't see the joint strictness in t/x
576 -- We don't want to put *all* the fv's from the RHS into the
577 -- DmdType, because that makes fixpointing very slow --- the
578 -- DmdType gets full of lazy demands that are slow to converge.
580 final_dmds = setUnpackStrategy dmds
581 -- Set the unpacking strategy
584 RetCPR | ignore_cpr_info -> TopRes
586 ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
589 The unpack strategy determines whether we'll *really* unpack the argument,
590 or whether we'll just remember its strictness. If unpacking would give
591 rise to a *lot* of worker args, we may decide not to unpack after all.
594 setUnpackStrategy :: [Demand] -> [Demand]
596 = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds)
598 go :: Int -- Max number of args available for sub-components of [Demand]
600 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
602 go n (Eval (Prod cs) : ds)
603 | n' >= 0 = Eval (Prod cs') `cons` go n'' ds
604 | otherwise = Box (Eval (Prod cs)) `cons` go n ds
607 n' = n + 1 - non_abs_args
608 -- Add one to the budget 'cos we drop the top-level arg
609 non_abs_args = nonAbsentArgs cs
610 -- Delete # of non-absent args to which we'll now be committed
612 go n (d:ds) = d `cons` go n ds
615 cons d (n,ds) = (n, d:ds)
617 nonAbsentArgs :: [Demand] -> Int
619 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
620 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
624 %************************************************************************
626 \subsection{Strictness signatures and types}
628 %************************************************************************
631 splitDmdTy :: DmdType -> (Demand, DmdType)
632 -- Split off one function argument
633 -- We already have a suitable demand on all
634 -- free vars, so no need to add more!
635 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
636 splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
640 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
642 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
643 | isTopLevel top_lvl = dmd_ty -- Don't record top level things
644 | otherwise = DmdType (extendVarEnv fv var dmd) ds res
646 addLazyFVs (DmdType fv ds res) lazy_fvs
647 = DmdType both_fv1 ds res
649 both_fv = (plusUFM_C both fv lazy_fvs)
650 both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
651 -- This modifyEnv is vital. Consider
652 -- let f = \x -> (x,y)
654 -- Here, y is treated as a lazy-fv of f, but we must `both` that L
655 -- demand with the bottom coming up from 'error'
657 -- I got a loop in the fixpointer without this, due to an interaction
658 -- with the lazy_fv filtering in mkSigTy. Roughly, it was
660 -- = letrec g y = x `fatbar`
661 -- letrec h z = z + ...g...
664 -- In the initial iteration for f, f=Bot
665 -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
666 -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
667 -- places on its free variables. Suppose it places none. Then the
668 -- x `fatbar` ...call to h...
669 -- will give a x->V demand for x. That turns into a L demand for x,
670 -- which floats out of the defn for h. Without the modifyEnv, that
671 -- L demand doesn't get both'd with the Bot coming up from the inner
672 -- call to f. So we just get an L demand for x for g.
674 -- A better way to say this is that the lazy-fv filtering should give the
675 -- same answer as putting the lazy fv demands in the function's type.
677 annotateBndr :: DmdType -> Var -> (DmdType, Var)
678 -- The returned env has the var deleted
679 -- The returned var is annotated with demand info
680 -- No effect on the argument demands
681 annotateBndr dmd_ty@(DmdType fv ds res) var
682 | isTyVar var = (dmd_ty, var)
683 | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
685 (fv', dmd) = removeFV fv var res
687 annotateBndrs = mapAccumR annotateBndr
689 annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
690 -- For lambdas we add the demand to the argument demands
691 -- Only called for Ids
693 (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
695 (fv', dmd) = removeFV fv id res
696 hacked_dmd = argDemand dmd
697 -- This call to argDemand is vital, because otherwise we label
698 -- a lambda binder with demand 'B'. But in terms of calling
699 -- conventions that's Abs, because we don't pass it. But
700 -- when we do a w/w split we get
701 -- fw x = (\x y:B -> ...) x (error "oops")
702 -- And then the simplifier things the 'B' is a strict demand
703 -- and evaluates the (error "oops"). Sigh
705 removeFV fv id res = (fv', zapUnlifted id dmd)
707 fv' = fv `delVarEnv` id
708 dmd = lookupVarEnv fv id `orElse` deflt
709 deflt | isBotRes res = Bot
712 -- For unlifted-type variables, we are only
713 -- interested in Bot/Abs/Box Abs
714 zapUnlifted is Bot = Bot
715 zapUnlifted id Abs = Abs
716 zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
720 %************************************************************************
722 \subsection{Strictness signatures}
724 %************************************************************************
727 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
728 -- We use the SigEnv to tell us whether to
729 -- record info about a variable in the DmdEnv
730 -- We do so if it's a LocalId, but not top-level
732 -- The DmdEnv gives the demand on the free vars of the function
733 -- when it is given enough args to satisfy the strictness signature
735 emptySigEnv = emptyVarEnv
737 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
738 extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
740 extendSigEnvList = extendVarEnvList
742 extendSigsWithLam :: SigEnv -> Id -> SigEnv
743 -- Extend the SigEnv when we meet a lambda binder
744 -- If the binder is marked demanded with a product demand, then give it a CPR
745 -- signature, because in the likely event that this is a lambda on a fn defn
746 -- [we only use this when the lambda is being consumed with a call demand],
747 -- it'll be w/w'd and so it will be CPR-ish. E.g.
748 -- f = \x::(Int,Int). if ...strict in x... then
752 -- We want f to have the CPR property because x does, by the time f has been w/w'd
754 -- Also note that we only want to do this for something that
755 -- definitely has product type, else we may get over-optimistic
756 -- CPR results (e.g. from \x -> x!).
758 extendSigsWithLam sigs id
759 = case idNewDemandInfo_maybe id of
760 Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
761 -- Optimistic in the Nothing case;
762 -- See notes [CPR-AND-STRICTNESS]
763 Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
767 dmdTransform :: SigEnv -- The strictness environment
768 -> Id -- The function
769 -> Demand -- The demand on the function
770 -> DmdType -- The demand type of the function in this context
771 -- Returned DmdEnv includes the demand on
772 -- this function plus demand on its free variables
774 dmdTransform sigs var dmd
776 ------ DATA CONSTRUCTOR
777 | isDataConWorkId var -- Data constructor
779 StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
780 DmdType _ _ con_res = dmd_ty
783 if arity == call_depth then -- Saturated, so unleash the demand
785 -- Important! If we Keep the constructor application, then
786 -- we need the demands the constructor places (always lazy)
787 -- If not, we don't need to. For example:
788 -- f p@(x,y) = (p,y) -- S(AL)
790 -- It's vital that we don't calculate Absent for a!
791 dmd_ds = case res_dmd of
792 Box (Eval ds) -> mapDmds box ds
796 -- ds can be empty, when we are just seq'ing the thing
797 -- If so we must make up a suitable bunch of demands
798 arg_ds = case dmd_ds of
799 Poly d -> replicate arity d
800 Prod ds -> ASSERT( ds `lengthIs` arity ) ds
803 mkDmdType emptyDmdEnv arg_ds con_res
804 -- Must remember whether it's a product, hence con_res, not TopRes
808 ------ IMPORTED FUNCTION
809 | isGlobalId var, -- Imported function
810 let StrictSig dmd_ty = idNewStrictness var
811 = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
816 ------ LOCAL LET/REC BOUND THING
817 | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
819 fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
820 | otherwise = deferType dmd_ty
821 -- NB: it's important to use deferType, and not just return topDmdType
822 -- Consider let { f x y = p + x } in f 1
823 -- The application isn't saturated, but we must nevertheless propagate
824 -- a lazy demand for p!
826 addVarDmd top_lvl fn_ty var dmd
828 ------ LOCAL NON-LET/REC BOUND THING
829 | otherwise -- Default case
833 (call_depth, res_dmd) = splitCallDmd dmd
837 %************************************************************************
841 %************************************************************************
844 splitCallDmd :: Demand -> (Int, Demand)
845 splitCallDmd (Call d) = case splitCallDmd d of
847 splitCallDmd d = (0, d)
849 vanillaCall :: Arity -> Demand
850 vanillaCall 0 = evalDmd
851 vanillaCall n = Call (vanillaCall (n-1))
853 deferType :: DmdType -> DmdType
854 deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
855 -- Notice that we throw away info about both arguments and results
856 -- For example, f = let ... in \x -> x
857 -- We don't want to get a stricness type V->T for f.
860 deferEnv :: DmdEnv -> DmdEnv
861 deferEnv fv = mapVarEnv defer fv
865 argDemand :: Demand -> Demand
866 -- The 'Defer' demands are just Lazy at function boundaries
867 -- Ugly! Ask John how to improve it.
868 argDemand Top = lazyDmd
869 argDemand (Defer d) = lazyDmd
870 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
871 argDemand (Box Bot) = evalDmd
872 argDemand (Box d) = box (argDemand d)
873 argDemand Bot = Abs -- Don't pass args that are consumed (only) by bottom
878 -------------------------
879 -- Consider (if x then y else []) with demand V
880 -- Then the first branch gives {y->V} and the second
881 -- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
882 -- in the result env.
883 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
884 = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
886 lub_fv = plusUFM_C lub fv1 fv2
887 lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
888 lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
889 -- lub is the identity for Bot
891 -- Extend the shorter argument list to match the longer
892 lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
894 lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1
895 lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2
897 -----------------------------------
898 -- (t1 `bothType` t2) takes the argument/result info from t1,
899 -- using t2 just for its free-var info
900 -- NB: Don't forget about r2! It might be BotRes, which is
901 -- a bottom demand on all the in-scope variables.
902 -- Peter: can this be done more neatly?
903 bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
904 = DmdType both_fv2 ds1 (r1 `bothRes` r2)
906 both_fv = plusUFM_C both fv1 fv2
907 both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
908 both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
909 -- both is the identity for Abs
916 lubRes RetCPR RetCPR = RetCPR
917 lubRes r1 r2 = TopRes
919 -- If either diverges, the whole thing does
920 -- Otherwise take CPR info from the first
921 bothRes r1 BotRes = BotRes
926 modifyEnv :: Bool -- No-op if False
927 -> (Demand -> Demand) -- The zapper
928 -> DmdEnv -> DmdEnv -- Env1 and Env2
929 -> DmdEnv -> DmdEnv -- Transform this env
930 -- Zap anything in Env1 but not in Env2
931 -- Assume: dom(env) includes dom(Env1) and dom(Env2)
933 modifyEnv need_to_modify zapper env1 env2 env
934 | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
937 zap uniq env = addToUFM_Directly env uniq (zapper current_val)
939 current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
943 %************************************************************************
945 \subsection{LUB and BOTH}
947 %************************************************************************
950 lub :: Demand -> Demand -> Demand
953 lub Abs d2 = absLub d2
955 lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
957 lub (Call d1) (Call d2) = Call (d1 `lub` d2)
958 lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box
959 lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval
960 lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top
962 -- For the Eval case, we use these approximation rules
963 -- Box Bot <= Eval (Box Bot ...)
964 -- Box Top <= Defer (Box Bot ...)
965 -- Box (Eval ds) <= Eval (map Box ds)
966 lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2)
967 lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1)
968 lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
969 lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1)
970 lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
972 lub (Box d1) (Box d2) = box (d1 `lub` d2)
973 lub d1@(Box _) d2 = d2 `lub` d1
975 lubs = zipWithDmds lub
977 ---------------------
978 -- box is the smart constructor for Box
979 -- It computes <B,bot> & d
980 -- INVARIANT: (Box d) => d = Bot, Abs, Eval
981 -- Seems to be no point in allowing (Box (Call d))
982 box (Call d) = Call d -- The odd man out. Why?
984 box (Defer _) = lazyDmd
985 box Top = lazyDmd -- Box Abs and Box Top
986 box Abs = lazyDmd -- are the same <B,L>
987 box d = Box d -- Bot, Eval
990 defer :: Demand -> Demand
992 -- defer is the smart constructor for Defer
993 -- The idea is that (Defer ds) = <U(ds), L>
995 -- It specifies what happens at a lazy function argument
996 -- or a lambda; the L* operator
997 -- Set the strictness part to L, but leave
998 -- the boxity side unaffected
999 -- It also ensures that Defer (Eval [LLLL]) = L
1004 defer (Call _) = lazyDmd -- Approximation here?
1005 defer (Box _) = lazyDmd
1006 defer (Defer ds) = Defer ds
1007 defer (Eval ds) = deferEval ds
1009 -- deferEval ds = defer (Eval ds)
1010 deferEval ds | allTop ds = Top
1011 | otherwise = Defer ds
1013 ---------------------
1014 absLub :: Demand -> Demand
1015 -- Computes (Abs `lub` d)
1016 -- For the Bot case consider
1017 -- f x y = if ... then x else error x
1018 -- Then for y we get Abs `lub` Bot, and we really
1023 absLub (Call _) = Top
1024 absLub (Box _) = Top
1025 absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)?
1026 absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)?
1028 absLubs = mapDmds absLub
1031 both :: Demand -> Demand -> Demand
1037 both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
1040 -- From 'error' itself we get demand Bot on x
1041 -- From the arg demand on x we get
1042 -- x :-> evalDmd = Box (Eval (Poly Abs))
1043 -- So we get Bot `both` Box (Eval (Poly Abs))
1044 -- = Seq Keep (Poly Bot)
1047 -- f x = if ... then error (fst x) else fst x
1048 -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
1050 -- which is what we want.
1053 both Top Bot = errDmd
1056 both Top (Box d) = Box d
1057 both Top (Call d) = Call d
1058 both Top (Eval ds) = Eval (mapDmds (`both` Top) ds)
1059 both Top (Defer ds) -- = defer (Top `both` Eval ds)
1060 -- = defer (Eval (mapDmds (`both` Top) ds))
1061 = deferEval (mapDmds (`both` Top) ds)
1064 both (Box d1) (Box d2) = box (d1 `both` d2)
1065 both (Box d1) d2@(Call _) = box (d1 `both` d2)
1066 both (Box d1) d2@(Eval _) = box (d1 `both` d2)
1067 both (Box d1) (Defer d2) = Box d1
1068 both d1@(Box _) d2 = d2 `both` d1
1070 both (Call d1) (Call d2) = Call (d1 `both` d2)
1071 both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)?
1072 both (Call d1) (Defer ds2) = Call d1 -- Ditto
1073 both d1@(Call _) d2 = d1 `both` d1
1075 both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2)
1076 both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
1077 both d1@(Eval ds1) d2 = d2 `both` d1
1079 both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
1080 both d1@(Defer ds1) d2 = d2 `both` d1
1082 boths = zipWithDmds both
1087 %************************************************************************
1089 \subsection{Miscellaneous
1091 %************************************************************************
1095 #ifdef OLD_STRICTNESS
1096 get_changes binds = vcat (map get_changes_bind binds)
1098 get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
1099 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
1101 get_changes_pr (id,rhs)
1102 = get_changes_var id $$ get_changes_expr rhs
1105 | isId var = get_changes_str var $$ get_changes_dmd var
1108 get_changes_expr (Type t) = empty
1109 get_changes_expr (Var v) = empty
1110 get_changes_expr (Lit l) = empty
1111 get_changes_expr (Note n e) = get_changes_expr e
1112 get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
1113 get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
1114 get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
1115 get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
1117 get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
1120 | new_better && old_better = empty
1121 | new_better = message "BETTER"
1122 | old_better = message "WORSE"
1123 | otherwise = message "INCOMPARABLE"
1125 message word = text word <+> text "strictness for" <+> ppr id <+> info
1126 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1127 new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
1128 -- strictness analyser can't track
1129 old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
1130 old_better = old `betterStrictness` new
1131 new_better = new `betterStrictness` old
1134 | isUnLiftedType (idType id) = empty -- Not useful
1135 | new_better && old_better = empty
1136 | new_better = message "BETTER"
1137 | old_better = message "WORSE"
1138 | otherwise = message "INCOMPARABLE"
1140 message word = text word <+> text "demand for" <+> ppr id <+> info
1141 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1142 new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
1144 old = newDemand (idDemandInfo id)
1145 new_better = new `betterDemand` old
1146 old_better = old `betterDemand` new
1148 betterStrictness :: StrictSig -> StrictSig -> Bool
1149 betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
1151 betterDmdType t1 t2 = (t1 `lubType` t2) == t2
1153 betterDemand :: Demand -> Demand -> Bool
1154 -- If d1 `better` d2, and d2 `better` d2, then d1==d2
1155 betterDemand d1 d2 = (d1 `lub` d2) == d2
1157 squashSig (StrictSig (DmdType fv ds res))
1158 = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
1160 -- squash just gets rid of call demands
1161 -- which the old analyser doesn't track
1162 squashDmd (Call d) = evalDmd
1163 squashDmd (Box d) = Box (squashDmd d)
1164 squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
1165 squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)