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
175 , isRecursiveTyCon tc = evalDmd
177 -- This coerce usually arises from a recursive
178 -- newtype, and we don't want to look inside them
179 -- for exactly the same reason that we don't look
180 -- inside recursive products -- we might not reach
181 -- a fixpoint. So revert to a vanilla Eval demand
183 dmdAnal sigs dmd (Note n e)
184 = (dmd_ty, Note n e')
186 (dmd_ty, e') = dmdAnal sigs dmd e
188 dmdAnal sigs dmd (App fun (Type ty))
189 = (fun_ty, App fun' (Type ty))
191 (fun_ty, fun') = dmdAnal sigs dmd fun
193 -- Lots of the other code is there to make this
194 -- beautiful, compositional, application rule :-)
195 dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
196 = let -- [Type arg handled above]
197 (fun_ty, fun') = dmdAnal sigs (Call dmd) fun
198 (arg_ty, arg') = dmdAnal sigs arg_dmd arg
199 (arg_dmd, res_ty) = splitDmdTy fun_ty
201 (res_ty `bothType` arg_ty, App fun' arg')
203 dmdAnal sigs dmd (Lam var body)
206 (body_ty, body') = dmdAnal sigs dmd body
208 (body_ty, Lam var body')
210 | Call body_dmd <- dmd -- A call demand: good!
212 sigs' = extendSigsWithLam sigs var
213 (body_ty, body') = dmdAnal sigs' body_dmd body
214 (lam_ty, var') = annotateLamIdBndr body_ty var
216 (lam_ty, Lam var' body')
218 | otherwise -- Not enough demand on the lambda; but do the body
219 = let -- anyway to annotate it and gather free var info
220 (body_ty, body') = dmdAnal sigs evalDmd body
221 (lam_ty, var') = annotateLamIdBndr body_ty var
223 (deferType lam_ty, Lam var' body')
225 dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
226 | let tycon = dataConTyCon dc,
227 isProductTyCon tycon,
228 not (isRecursiveTyCon tycon)
230 sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
231 (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt
232 (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
233 (_, bndrs', _) = alt'
234 case_bndr_sig = cprSig
235 -- Inside the alternative, the case binder has the CPR property.
236 -- Meaning that a case on it will successfully cancel.
238 -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
241 -- We want f to have the CPR property:
242 -- f b x = case fw b x of { r -> I# r }
243 -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
246 -- Figure out whether the demand on the case binder is used, and use
247 -- that to set the scrut_dmd. This is utterly essential.
248 -- Consider f x = case x of y { (a,b) -> k y a }
249 -- If we just take scrut_demand = U(L,A), then we won't pass x to the
250 -- worker, so the worker will rebuild
251 -- x = (a, absent-error)
252 -- and that'll crash.
253 -- So at one stage I had:
254 -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
255 -- keepity | dead_case_bndr = Drop
256 -- | otherwise = Keep
259 -- case x of y { (a,b) -> h y + a }
260 -- where h : U(LL) -> T
261 -- The above code would compute a Keep for x, since y is not Abs, which is silly
262 -- The insight is, of course, that a demand on y is a demand on the
263 -- scrutinee, so we need to `both` it with the scrut demand
265 scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
267 idNewDemandInfo case_bndr'
269 (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
271 (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
273 dmdAnal sigs dmd (Case scrut case_bndr ty alts)
275 (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
276 (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
277 (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
279 -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
280 (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
282 dmdAnal sigs dmd (Let (NonRec id rhs) body)
284 (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)
285 (body_ty, body') = dmdAnal sigs' dmd body
286 (body_ty1, id2) = annotateBndr body_ty id1
287 body_ty2 = addLazyFVs body_ty1 lazy_fv
289 -- If the actual demand is better than the vanilla call
290 -- demand, you might think that we might do better to re-analyse
291 -- the RHS with the stronger demand.
292 -- But (a) That seldom happens, because it means that *every* path in
293 -- the body of the let has to use that stronger demand
294 -- (b) It often happens temporarily in when fixpointing, because
295 -- the recursive function at first seems to place a massive demand.
296 -- But we don't want to go to extra work when the function will
297 -- probably iterate to something less demanding.
298 -- In practice, all the times the actual demand on id2 is more than
299 -- the vanilla call demand seem to be due to (b). So we don't
300 -- bother to re-analyse the RHS.
301 (body_ty2, Let (NonRec id2 rhs') body')
303 dmdAnal sigs dmd (Let (Rec pairs) body)
305 bndrs = map fst pairs
306 (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs
307 (body_ty, body') = dmdAnal sigs' dmd body
308 body_ty1 = addLazyFVs body_ty lazy_fv
310 sigs' `seq` body_ty `seq`
312 (body_ty2, _) = annotateBndrs body_ty1 bndrs
313 -- Don't bother to add demand info to recursive
314 -- binders as annotateBndr does;
315 -- being recursive, we can't treat them strictly.
316 -- But we do need to remove the binders from the result demand env
318 (body_ty2, Let (Rec pairs') body')
321 dmdAnalAlt sigs dmd (con,bndrs,rhs)
323 (rhs_ty, rhs') = dmdAnal sigs dmd rhs
324 (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
325 final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType
328 -- There's a hack here for I/O operations. Consider
329 -- case foo x s of { (# s, r #) -> y }
330 -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O
331 -- operation that simply terminates the program (not in an erroneous way)?
332 -- In that case we should not evaluate y before the call to 'foo'.
333 -- Hackish solution: spot the IO-like situation and add a virtual branch,
337 -- other -> return ()
338 -- So the 'y' isn't necessarily going to be evaluated
340 -- A more complete example where this shows up is:
341 -- do { let len = <expensive> ;
342 -- ; when (...) (exitWith ExitSuccess)
345 io_hack_reqd = con == DataAlt unboxedPairDataCon &&
346 idType (head bndrs) `coreEqType` realWorldStatePrimTy
348 (final_alt_ty, (con, bndrs', rhs'))
351 %************************************************************************
353 \subsection{Bindings}
355 %************************************************************************
358 dmdFix :: TopLevelFlag
359 -> SigEnv -- Does not include bindings for this binding
362 [(Id,CoreExpr)]) -- Binders annotated with stricness info
364 dmdFix top_lvl sigs orig_pairs
365 = loop 1 initial_sigs orig_pairs
367 bndrs = map fst orig_pairs
368 initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs]
371 -> SigEnv -- Already contains the current sigs
373 -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
376 = (sigs', lazy_fv, pairs')
377 -- Note: use pairs', not pairs. pairs' is the result of
378 -- processing the RHSs with sigs (= sigs'), whereas pairs
379 -- is the result of processing the RHSs with the *previous*
380 -- iteration of sigs.
382 | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat
383 [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
384 text "env:" <+> ppr (ufmToList sigs),
385 text "binds:" <+> pprCoreBinding (Rec pairs)]))
386 (emptySigEnv, lazy_fv, orig_pairs) -- Safe output
387 -- The lazy_fv part is really important! orig_pairs has no strictness
388 -- info, including nothing about free vars. But if we have
389 -- letrec f = ....y..... in ...f...
390 -- where 'y' is free in f, we must record that y is mentioned,
391 -- otherwise y will get recorded as absent altogether
393 | otherwise = loop (n+1) sigs' pairs'
395 found_fixpoint = all (same_sig sigs sigs') bndrs
396 -- Use the new signature to do the next pair
397 -- The occurrence analyser has arranged them in a good order
398 -- so this can significantly reduce the number of iterations needed
399 ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs
401 my_downRhs top_lvl (sigs,lazy_fv) (id,rhs)
402 = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig))
404 -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' )
405 ((sigs', lazy_fv'), pair')
408 (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)
409 lazy_fv' = plusUFM_C both lazy_fv lazy_fv1
410 -- old_sig = lookup sigs id
411 -- new_sig = lookup sigs' id
413 same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
414 lookup sigs var = case lookupVarEnv sigs var of
417 -- Get an initial strictness signature from the Id
418 -- itself. That way we make use of earlier iterations
419 -- of the fixpoint algorithm. (Cunning plan.)
420 -- Note that the cunning plan extends to the DmdEnv too,
421 -- since it is part of the strictness signature
422 initialSig id = idNewStrictness_maybe id `orElse` botSig
424 dmdAnalRhs :: TopLevelFlag -> RecFlag
425 -> SigEnv -> (Id, CoreExpr)
426 -> (SigEnv, DmdEnv, (Id, CoreExpr))
427 -- Process the RHS of the binding, add the strictness signature
428 -- to the Id, and augment the environment with the signature as well.
430 dmdAnalRhs top_lvl rec_flag sigs (id, rhs)
431 = (sigs', lazy_fv, (id', rhs'))
433 arity = idArity id -- The idArity should be up to date
434 -- The simplifier was run just beforehand
435 (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
436 (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
437 -- The RHS can be eta-reduced to just a variable,
438 -- in which case we should not complain.
439 mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
440 id' = id `setIdNewStrictness` sig_ty
441 sigs' = extendSigEnv top_lvl sigs id sig_ty
444 %************************************************************************
446 \subsection{Strictness signatures and types}
448 %************************************************************************
451 mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
452 -- Take a DmdType and turn it into a StrictSig
453 -- NB: not used for never-inline things; hence False
454 mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
456 mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
457 mkSigTy top_lvl rec_flag id rhs dmd_ty
458 = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
460 never_inline = isNeverActive (idInlinePragma id)
461 maybe_id_dmd = idNewDemandInfo_maybe id
462 -- Is Nothing the first time round
465 | isTopLevel top_lvl = False -- Top level things don't get
466 -- their demandInfo set at all
467 | isRec rec_flag = False -- Ditto recursive things
468 | Just dmd <- maybe_id_dmd = isStrictDmd dmd
469 | otherwise = True -- Optimistic, first time round
473 The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 If the rhs is a thunk, we usually forget the CPR info, because
476 it is presumably shared (else it would have been inlined, and
477 so we'd lose sharing if w/w'd it into a function). E.g.
479 let r = case expensive of
483 If we marked r as having the CPR property, then we'd w/w into
485 let $wr = \() -> case expensive of
491 But now r is a thunk, which won't be inlined, so we are no further ahead.
494 However, if the strictness analyser has figured out (in a previous
495 iteration) that it's strict, then we DON'T need to forget the CPR info.
496 Instead we can retain the CPR info and do the thunk-splitting transform
497 (see WorkWrap.splitThunk).
499 This made a big difference to PrelBase.modInt, which had something like
500 modInt = \ x -> let r = ... -> I# v in
501 ...body strict in r...
502 r's RHS isn't a value yet; but modInt returns r in various branches, so
503 if r doesn't have the CPR property then neither does modInt
504 Another case I found in practice (in Complex.magnitude), looks like this:
505 let k = if ... then I# a else I# b
506 in ... body strict in k ....
507 (For this example, it doesn't matter whether k is returned as part of
508 the overall result; but it does matter that k's RHS has the CPR property.)
509 Left to itself, the simplifier will make a join point thus:
510 let $j k = ...body strict in k...
511 if ... then $j (I# a) else $j (I# b)
512 With thunk-splitting, we get instead
513 let $j x = let k = I#x in ...body strict in k...
514 in if ... then $j a else $j b
515 This is much better; there's a good chance the I# won't get allocated.
517 The difficulty with this is that we need the strictness type to
518 look at the body... but we now need the body to calculate the demand
519 on the variable, so we can decide whether its strictness type should
520 have a CPR in it or not. Simple solution:
521 a) use strictness info from the previous iteration
522 b) make sure we do at least 2 iterations, by doing a second
523 round for top-level non-recs. Top level recs will get at
524 least 2 iterations except for totally-bottom functions
525 which aren't very interesting anyway.
527 NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
529 The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS]
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
531 Demand info now has a 'Nothing' state, just like strictness info.
532 The analysis works from 'dangerous' towards a 'safe' state; so we
533 start with botSig for 'Nothing' strictness infos, and we start with
534 "yes, it's demanded" for 'Nothing' in the demand info. The
535 fixpoint iteration will sort it all out.
537 We can't start with 'not-demanded' because then consider
541 if ... then t else I# y else f x'
543 In the first iteration we'd have no demand info for x, so assume
544 not-demanded; then we'd get TopRes for f's CPR info. Next iteration
545 we'd see that t was demanded, and so give it the CPR property, but by
546 now f has TopRes, so it will stay TopRes. Instead, with the Nothing
547 setting the first time round, we say 'yes t is demanded' the first
550 However, this does mean that for non-recursive bindings we must
551 iterate twice to be sure of not getting over-optimistic CPR info,
552 in the case where t turns out to be not-demanded. This is handled
557 mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
558 = (lazy_fv, mkStrictSig dmd_ty)
560 dmd_ty = DmdType strict_fv final_dmds res'
562 lazy_fv = filterUFM (not . isStrictDmd) fv
563 strict_fv = filterUFM isStrictDmd fv
564 -- We put the strict FVs in the DmdType of the Id, so
565 -- that at its call sites we unleash demands on its strict fvs.
566 -- An example is 'roll' in imaginary/wheel-sieve2
567 -- Something like this:
569 -- go y = if ... then roll (x-1) else x+1
572 -- We want to see that roll is strict in x, which is because
573 -- go is called. So we put the DmdEnv for x in go's DmdType.
576 -- f :: Int -> Int -> Int
577 -- f x y = let t = x+1
578 -- h z = if z==0 then t else
579 -- if z==1 then x+1 else
583 -- Calling h does indeed evaluate x, but we can only see
584 -- that if we unleash a demand on x at the call site for t.
586 -- Incidentally, here's a place where lambda-lifting h would
587 -- lose the cigar --- we couldn't see the joint strictness in t/x
590 -- We don't want to put *all* the fv's from the RHS into the
591 -- DmdType, because that makes fixpointing very slow --- the
592 -- DmdType gets full of lazy demands that are slow to converge.
594 final_dmds = setUnpackStrategy dmds
595 -- Set the unpacking strategy
598 RetCPR | ignore_cpr_info -> TopRes
600 ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
603 The unpack strategy determines whether we'll *really* unpack the argument,
604 or whether we'll just remember its strictness. If unpacking would give
605 rise to a *lot* of worker args, we may decide not to unpack after all.
608 setUnpackStrategy :: [Demand] -> [Demand]
610 = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds)
612 go :: Int -- Max number of args available for sub-components of [Demand]
614 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
616 go n (Eval (Prod cs) : ds)
617 | n' >= 0 = Eval (Prod cs') `cons` go n'' ds
618 | otherwise = Box (Eval (Prod cs)) `cons` go n ds
621 n' = n + 1 - non_abs_args
622 -- Add one to the budget 'cos we drop the top-level arg
623 non_abs_args = nonAbsentArgs cs
624 -- Delete # of non-absent args to which we'll now be committed
626 go n (d:ds) = d `cons` go n ds
629 cons d (n,ds) = (n, d:ds)
631 nonAbsentArgs :: [Demand] -> Int
633 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
634 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
638 %************************************************************************
640 \subsection{Strictness signatures and types}
642 %************************************************************************
645 splitDmdTy :: DmdType -> (Demand, DmdType)
646 -- Split off one function argument
647 -- We already have a suitable demand on all
648 -- free vars, so no need to add more!
649 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
650 splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
654 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
656 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
657 | isTopLevel top_lvl = dmd_ty -- Don't record top level things
658 | otherwise = DmdType (extendVarEnv fv var dmd) ds res
660 addLazyFVs (DmdType fv ds res) lazy_fvs
661 = DmdType both_fv1 ds res
663 both_fv = (plusUFM_C both fv lazy_fvs)
664 both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
665 -- This modifyEnv is vital. Consider
666 -- let f = \x -> (x,y)
668 -- Here, y is treated as a lazy-fv of f, but we must `both` that L
669 -- demand with the bottom coming up from 'error'
671 -- I got a loop in the fixpointer without this, due to an interaction
672 -- with the lazy_fv filtering in mkSigTy. Roughly, it was
674 -- = letrec g y = x `fatbar`
675 -- letrec h z = z + ...g...
678 -- In the initial iteration for f, f=Bot
679 -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
680 -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
681 -- places on its free variables. Suppose it places none. Then the
682 -- x `fatbar` ...call to h...
683 -- will give a x->V demand for x. That turns into a L demand for x,
684 -- which floats out of the defn for h. Without the modifyEnv, that
685 -- L demand doesn't get both'd with the Bot coming up from the inner
686 -- call to f. So we just get an L demand for x for g.
688 -- A better way to say this is that the lazy-fv filtering should give the
689 -- same answer as putting the lazy fv demands in the function's type.
691 annotateBndr :: DmdType -> Var -> (DmdType, Var)
692 -- The returned env has the var deleted
693 -- The returned var is annotated with demand info
694 -- No effect on the argument demands
695 annotateBndr dmd_ty@(DmdType fv ds res) var
696 | isTyVar var = (dmd_ty, var)
697 | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
699 (fv', dmd) = removeFV fv var res
701 annotateBndrs = mapAccumR annotateBndr
703 annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
704 -- For lambdas we add the demand to the argument demands
705 -- Only called for Ids
707 (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
709 (fv', dmd) = removeFV fv id res
710 hacked_dmd = argDemand dmd
711 -- This call to argDemand is vital, because otherwise we label
712 -- a lambda binder with demand 'B'. But in terms of calling
713 -- conventions that's Abs, because we don't pass it. But
714 -- when we do a w/w split we get
715 -- fw x = (\x y:B -> ...) x (error "oops")
716 -- And then the simplifier things the 'B' is a strict demand
717 -- and evaluates the (error "oops"). Sigh
719 removeFV fv id res = (fv', zapUnlifted id dmd)
721 fv' = fv `delVarEnv` id
722 dmd = lookupVarEnv fv id `orElse` deflt
723 deflt | isBotRes res = Bot
726 -- For unlifted-type variables, we are only
727 -- interested in Bot/Abs/Box Abs
728 zapUnlifted is Bot = Bot
729 zapUnlifted id Abs = Abs
730 zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
734 %************************************************************************
736 \subsection{Strictness signatures}
738 %************************************************************************
741 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
742 -- We use the SigEnv to tell us whether to
743 -- record info about a variable in the DmdEnv
744 -- We do so if it's a LocalId, but not top-level
746 -- The DmdEnv gives the demand on the free vars of the function
747 -- when it is given enough args to satisfy the strictness signature
749 emptySigEnv = emptyVarEnv
751 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
752 extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
754 extendSigEnvList = extendVarEnvList
756 extendSigsWithLam :: SigEnv -> Id -> SigEnv
757 -- Extend the SigEnv when we meet a lambda binder
758 -- If the binder is marked demanded with a product demand, then give it a CPR
759 -- signature, because in the likely event that this is a lambda on a fn defn
760 -- [we only use this when the lambda is being consumed with a call demand],
761 -- it'll be w/w'd and so it will be CPR-ish. E.g.
762 -- f = \x::(Int,Int). if ...strict in x... then
766 -- We want f to have the CPR property because x does, by the time f has been w/w'd
768 -- Also note that we only want to do this for something that
769 -- definitely has product type, else we may get over-optimistic
770 -- CPR results (e.g. from \x -> x!).
772 extendSigsWithLam sigs id
773 = case idNewDemandInfo_maybe id of
774 Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
775 -- Optimistic in the Nothing case;
776 -- See notes [CPR-AND-STRICTNESS]
777 Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel)
781 dmdTransform :: SigEnv -- The strictness environment
782 -> Id -- The function
783 -> Demand -- The demand on the function
784 -> DmdType -- The demand type of the function in this context
785 -- Returned DmdEnv includes the demand on
786 -- this function plus demand on its free variables
788 dmdTransform sigs var dmd
790 ------ DATA CONSTRUCTOR
791 | isDataConWorkId var -- Data constructor
793 StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
794 DmdType _ _ con_res = dmd_ty
797 if arity == call_depth then -- Saturated, so unleash the demand
799 -- Important! If we Keep the constructor application, then
800 -- we need the demands the constructor places (always lazy)
801 -- If not, we don't need to. For example:
802 -- f p@(x,y) = (p,y) -- S(AL)
804 -- It's vital that we don't calculate Absent for a!
805 dmd_ds = case res_dmd of
806 Box (Eval ds) -> mapDmds box ds
810 -- ds can be empty, when we are just seq'ing the thing
811 -- If so we must make up a suitable bunch of demands
812 arg_ds = case dmd_ds of
813 Poly d -> replicate arity d
814 Prod ds -> ASSERT( ds `lengthIs` arity ) ds
817 mkDmdType emptyDmdEnv arg_ds con_res
818 -- Must remember whether it's a product, hence con_res, not TopRes
822 ------ IMPORTED FUNCTION
823 | isGlobalId var, -- Imported function
824 let StrictSig dmd_ty = idNewStrictness var
825 = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
830 ------ LOCAL LET/REC BOUND THING
831 | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
833 fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
834 | otherwise = deferType dmd_ty
835 -- NB: it's important to use deferType, and not just return topDmdType
836 -- Consider let { f x y = p + x } in f 1
837 -- The application isn't saturated, but we must nevertheless propagate
838 -- a lazy demand for p!
840 addVarDmd top_lvl fn_ty var dmd
842 ------ LOCAL NON-LET/REC BOUND THING
843 | otherwise -- Default case
847 (call_depth, res_dmd) = splitCallDmd dmd
851 %************************************************************************
855 %************************************************************************
858 splitCallDmd :: Demand -> (Int, Demand)
859 splitCallDmd (Call d) = case splitCallDmd d of
861 splitCallDmd d = (0, d)
863 vanillaCall :: Arity -> Demand
864 vanillaCall 0 = evalDmd
865 vanillaCall n = Call (vanillaCall (n-1))
867 deferType :: DmdType -> DmdType
868 deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
869 -- Notice that we throw away info about both arguments and results
870 -- For example, f = let ... in \x -> x
871 -- We don't want to get a stricness type V->T for f.
874 deferEnv :: DmdEnv -> DmdEnv
875 deferEnv fv = mapVarEnv defer fv
879 argDemand :: Demand -> Demand
880 -- The 'Defer' demands are just Lazy at function boundaries
881 -- Ugly! Ask John how to improve it.
882 argDemand Top = lazyDmd
883 argDemand (Defer d) = lazyDmd
884 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
885 argDemand (Box Bot) = evalDmd
886 argDemand (Box d) = box (argDemand d)
887 argDemand Bot = Abs -- Don't pass args that are consumed (only) by bottom
892 -------------------------
893 -- Consider (if x then y else []) with demand V
894 -- Then the first branch gives {y->V} and the second
895 -- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
896 -- in the result env.
897 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
898 = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
900 lub_fv = plusUFM_C lub fv1 fv2
901 lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
902 lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
903 -- lub is the identity for Bot
905 -- Extend the shorter argument list to match the longer
906 lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
908 lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1
909 lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2
911 -----------------------------------
912 -- (t1 `bothType` t2) takes the argument/result info from t1,
913 -- using t2 just for its free-var info
914 -- NB: Don't forget about r2! It might be BotRes, which is
915 -- a bottom demand on all the in-scope variables.
916 -- Peter: can this be done more neatly?
917 bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
918 = DmdType both_fv2 ds1 (r1 `bothRes` r2)
920 both_fv = plusUFM_C both fv1 fv2
921 both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
922 both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
923 -- both is the identity for Abs
930 lubRes RetCPR RetCPR = RetCPR
931 lubRes r1 r2 = TopRes
933 -- If either diverges, the whole thing does
934 -- Otherwise take CPR info from the first
935 bothRes r1 BotRes = BotRes
940 modifyEnv :: Bool -- No-op if False
941 -> (Demand -> Demand) -- The zapper
942 -> DmdEnv -> DmdEnv -- Env1 and Env2
943 -> DmdEnv -> DmdEnv -- Transform this env
944 -- Zap anything in Env1 but not in Env2
945 -- Assume: dom(env) includes dom(Env1) and dom(Env2)
947 modifyEnv need_to_modify zapper env1 env2 env
948 | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
951 zap uniq env = addToUFM_Directly env uniq (zapper current_val)
953 current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
957 %************************************************************************
959 \subsection{LUB and BOTH}
961 %************************************************************************
964 lub :: Demand -> Demand -> Demand
967 lub Abs d2 = absLub d2
969 lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
971 lub (Call d1) (Call d2) = Call (d1 `lub` d2)
972 lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box
973 lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval
974 lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top
976 -- For the Eval case, we use these approximation rules
977 -- Box Bot <= Eval (Box Bot ...)
978 -- Box Top <= Defer (Box Bot ...)
979 -- Box (Eval ds) <= Eval (map Box ds)
980 lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2)
981 lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1)
982 lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
983 lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1)
984 lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
986 lub (Box d1) (Box d2) = box (d1 `lub` d2)
987 lub d1@(Box _) d2 = d2 `lub` d1
989 lubs = zipWithDmds lub
991 ---------------------
992 -- box is the smart constructor for Box
993 -- It computes <B,bot> & d
994 -- INVARIANT: (Box d) => d = Bot, Abs, Eval
995 -- Seems to be no point in allowing (Box (Call d))
996 box (Call d) = Call d -- The odd man out. Why?
998 box (Defer _) = lazyDmd
999 box Top = lazyDmd -- Box Abs and Box Top
1000 box Abs = lazyDmd -- are the same <B,L>
1001 box d = Box d -- Bot, Eval
1004 defer :: Demand -> Demand
1006 -- defer is the smart constructor for Defer
1007 -- The idea is that (Defer ds) = <U(ds), L>
1009 -- It specifies what happens at a lazy function argument
1010 -- or a lambda; the L* operator
1011 -- Set the strictness part to L, but leave
1012 -- the boxity side unaffected
1013 -- It also ensures that Defer (Eval [LLLL]) = L
1018 defer (Call _) = lazyDmd -- Approximation here?
1019 defer (Box _) = lazyDmd
1020 defer (Defer ds) = Defer ds
1021 defer (Eval ds) = deferEval ds
1023 -- deferEval ds = defer (Eval ds)
1024 deferEval ds | allTop ds = Top
1025 | otherwise = Defer ds
1027 ---------------------
1028 absLub :: Demand -> Demand
1029 -- Computes (Abs `lub` d)
1030 -- For the Bot case consider
1031 -- f x y = if ... then x else error x
1032 -- Then for y we get Abs `lub` Bot, and we really
1037 absLub (Call _) = Top
1038 absLub (Box _) = Top
1039 absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)?
1040 absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)?
1042 absLubs = mapDmds absLub
1045 both :: Demand -> Demand -> Demand
1051 both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
1054 -- From 'error' itself we get demand Bot on x
1055 -- From the arg demand on x we get
1056 -- x :-> evalDmd = Box (Eval (Poly Abs))
1057 -- So we get Bot `both` Box (Eval (Poly Abs))
1058 -- = Seq Keep (Poly Bot)
1061 -- f x = if ... then error (fst x) else fst x
1062 -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
1064 -- which is what we want.
1067 both Top Bot = errDmd
1070 both Top (Box d) = Box d
1071 both Top (Call d) = Call d
1072 both Top (Eval ds) = Eval (mapDmds (`both` Top) ds)
1073 both Top (Defer ds) -- = defer (Top `both` Eval ds)
1074 -- = defer (Eval (mapDmds (`both` Top) ds))
1075 = deferEval (mapDmds (`both` Top) ds)
1078 both (Box d1) (Box d2) = box (d1 `both` d2)
1079 both (Box d1) d2@(Call _) = box (d1 `both` d2)
1080 both (Box d1) d2@(Eval _) = box (d1 `both` d2)
1081 both (Box d1) (Defer d2) = Box d1
1082 both d1@(Box _) d2 = d2 `both` d1
1084 both (Call d1) (Call d2) = Call (d1 `both` d2)
1085 both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)?
1086 both (Call d1) (Defer ds2) = Call d1 -- Ditto
1087 both d1@(Call _) d2 = d1 `both` d1
1089 both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2)
1090 both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
1091 both d1@(Eval ds1) d2 = d2 `both` d1
1093 both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
1094 both d1@(Defer ds1) d2 = d2 `both` d1
1096 boths = zipWithDmds both
1101 %************************************************************************
1103 \subsection{Miscellaneous
1105 %************************************************************************
1109 #ifdef OLD_STRICTNESS
1110 get_changes binds = vcat (map get_changes_bind binds)
1112 get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
1113 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
1115 get_changes_pr (id,rhs)
1116 = get_changes_var id $$ get_changes_expr rhs
1119 | isId var = get_changes_str var $$ get_changes_dmd var
1122 get_changes_expr (Type t) = empty
1123 get_changes_expr (Var v) = empty
1124 get_changes_expr (Lit l) = empty
1125 get_changes_expr (Note n e) = get_changes_expr e
1126 get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
1127 get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
1128 get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
1129 get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
1131 get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
1134 | new_better && old_better = empty
1135 | new_better = message "BETTER"
1136 | old_better = message "WORSE"
1137 | otherwise = message "INCOMPARABLE"
1139 message word = text word <+> text "strictness for" <+> ppr id <+> info
1140 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1141 new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
1142 -- strictness analyser can't track
1143 old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
1144 old_better = old `betterStrictness` new
1145 new_better = new `betterStrictness` old
1148 | isUnLiftedType (idType id) = empty -- Not useful
1149 | new_better && old_better = empty
1150 | new_better = message "BETTER"
1151 | old_better = message "WORSE"
1152 | otherwise = message "INCOMPARABLE"
1154 message word = text word <+> text "demand for" <+> ppr id <+> info
1155 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1156 new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
1158 old = newDemand (idDemandInfo id)
1159 new_better = new `betterDemand` old
1160 old_better = old `betterDemand` new
1162 betterStrictness :: StrictSig -> StrictSig -> Bool
1163 betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
1165 betterDmdType t1 t2 = (t1 `lubType` t2) == t2
1167 betterDemand :: Demand -> Demand -> Bool
1168 -- If d1 `better` d2, and d2 `better` d2, then d1==d2
1169 betterDemand d1 d2 = (d1 `lub` d2) == d2
1171 squashSig (StrictSig (DmdType fv ds res))
1172 = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
1174 -- squash just gets rid of call demands
1175 -- which the old analyser doesn't track
1176 squashDmd (Call d) = evalDmd
1177 squashDmd (Box d) = Box (squashDmd d)
1178 squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
1179 squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)