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 CmdLineOpts ( DynFlags, DynFlag(..), opt_MaxWorkerArgs )
17 import NewDemand -- All of it
20 import CoreUtils ( exprIsValue, exprArity )
21 import DataCon ( dataConTyCon )
22 import TyCon ( isProductTyCon, isRecursiveTyCon )
23 import Id ( Id, idType, idInlinePragma,
24 isDataConId, isGlobalId, idArity,
26 idDemandInfo, idStrictness, idCprInfo,
28 idNewStrictness, idNewStrictness_maybe,
29 setIdNewStrictness, idNewDemandInfo,
30 setIdNewDemandInfo, idName
33 import IdInfo ( newStrictnessFromOld, newDemand )
37 import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
38 keysUFM, minusUFM, ufmToList, filterUFM )
39 import Type ( isUnLiftedType )
40 import CoreLint ( showPass, endPass )
41 import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
42 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive )
43 import Maybes ( orElse, expectJust )
49 * set a noinline pragma on bottoming Ids
51 * Consider f x = x+1 `fatbar` error (show x)
52 We'd like to unbox x, even if that means reboxing it in the error case.
55 instance Outputable TopLevelFlag where
59 %************************************************************************
61 \subsection{Top level stuff}
63 %************************************************************************
66 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
67 dmdAnalPgm dflags binds
69 showPass dflags "Demand analysis" ;
70 let { binds_plus_dmds = do_prog binds } ;
71 endPass dflags "Demand analysis"
72 Opt_D_dump_stranal binds_plus_dmds ;
74 -- Only if DEBUG is on, because only then is the old
75 -- strictness analyser run
76 let { dmd_changes = get_changes binds_plus_dmds } ;
77 printDump (text "Changes in demands" $$ dmd_changes) ;
79 return binds_plus_dmds
82 do_prog :: [CoreBind] -> [CoreBind]
83 do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
85 dmdAnalTopBind :: SigEnv
88 dmdAnalTopBind sigs (NonRec id rhs)
90 ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel sigs (id, rhs)
91 (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel sigs (id, rhs1)
92 -- Do two passes to improve CPR information
93 -- See the comments with mkSigTy.ignore_cpr_info below
95 (sigs2, NonRec id2 rhs2)
97 dmdAnalTopBind sigs (Rec pairs)
99 (sigs', _, pairs') = dmdFix TopLevel sigs pairs
100 -- We get two iterations automatically
106 dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr)
107 -- Analyse the RHS and return
108 -- a) appropriate strictness info
109 -- b) the unfolding (decorated with stricntess info)
113 arity = exprArity rhs
114 (rhs_ty, rhs') = dmdAnal emptySigEnv (vanillaCall arity) rhs
115 sig = mkTopSigTy rhs rhs_ty
118 %************************************************************************
120 \subsection{The analyser itself}
122 %************************************************************************
125 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
127 dmdAnal sigs Abs e = (topDmdType, e)
130 | not (isStrictDmd dmd)
132 (res_ty, e') = dmdAnal sigs evalDmd e
134 (deferType res_ty, e')
135 -- It's important not to analyse e with a lazy demand because
136 -- a) When we encounter case s of (a,b) ->
137 -- we demand s with U(d1d2)... but if the overall demand is lazy
138 -- that is wrong, and we'd need to reduce the demand on s,
139 -- which is inconvenient
140 -- b) More important, consider
141 -- f (let x = R in x+x), where f is lazy
142 -- We still want to mark x as demanded, because it will be when we
143 -- enter the let. If we analyse f's arg with a Lazy demand, we'll
144 -- just mark x as Lazy
145 -- c) The application rule wouldn't be right either
146 -- Evaluating (f x) in a L demand does *not* cause
147 -- evaluation of f in a C(L) demand!
150 dmdAnal sigs dmd (Lit lit)
151 = (topDmdType, Lit lit)
153 dmdAnal sigs dmd (Var var)
154 = (dmdTransform sigs var dmd, Var var)
156 dmdAnal sigs dmd (Note n e)
157 = (dmd_ty, Note n e')
159 (dmd_ty, e') = dmdAnal sigs dmd' e
161 Coerce _ _ -> evalDmd -- This coerce usually arises from a recursive
162 other -> dmd -- newtype, and we don't want to look inside them
163 -- for exactly the same reason that we don't look
164 -- inside recursive products -- we might not reach
165 -- a fixpoint. So revert to a vanilla Eval demand
167 dmdAnal sigs dmd (App fun (Type ty))
168 = (fun_ty, App fun' (Type ty))
170 (fun_ty, fun') = dmdAnal sigs dmd fun
172 -- Lots of the other code is there to make this
173 -- beautiful, compositional, application rule :-)
174 dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
175 = let -- [Type arg handled above]
176 (fun_ty, fun') = dmdAnal sigs (Call dmd) fun
177 (arg_ty, arg') = dmdAnal sigs arg_dmd arg
178 (arg_dmd, res_ty) = splitDmdTy fun_ty
180 (res_ty `bothType` arg_ty, App fun' arg')
182 dmdAnal sigs dmd (Lam var body)
185 (body_ty, body') = dmdAnal sigs dmd body
187 (body_ty, Lam var body')
189 | Call body_dmd <- dmd -- A call demand: good!
191 (body_ty, body') = dmdAnal sigs body_dmd body
192 (lam_ty, var') = annotateLamIdBndr body_ty var
194 (lam_ty, Lam var' body')
196 | otherwise -- Not enough demand on the lambda; but do the body
197 = let -- anyway to annotate it and gather free var info
198 (body_ty, body') = dmdAnal sigs evalDmd body
199 (lam_ty, var') = annotateLamIdBndr body_ty var
201 (deferType lam_ty, Lam var' body')
203 dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
204 | let tycon = dataConTyCon dc,
205 isProductTyCon tycon,
206 not (isRecursiveTyCon tycon)
208 sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
209 (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt
210 (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
211 (_, bndrs', _) = alt'
212 case_bndr_sig = StrictSig (mkDmdType emptyVarEnv [] RetCPR)
213 -- Inside the alternative, the case binder has the CPR property.
214 -- Meaning that a case on it will successfully cancel.
216 -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
219 -- We want f to have the CPR property:
220 -- f b x = case fw b x of { r -> I# r }
221 -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
224 -- Figure out whether the demand on the case binder is used, and use
225 -- that to set the scrut_dmd. This is utterly essential.
226 -- Consider f x = case x of y { (a,b) -> k y a }
227 -- If we just take scrut_demand = U(L,A), then we won't pass x to the
228 -- worker, so the worker will rebuild
229 -- x = (a, absent-error)
230 -- and that'll crash.
231 -- So at one stage I had:
232 -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
233 -- keepity | dead_case_bndr = Drop
234 -- | otherwise = Keep
237 -- case x of y { (a,b) -> h y + a }
238 -- where h : U(LL) -> T
239 -- The above code would compute a Keep for x, since y is not Abs, which is silly
240 -- The insight is, of course, that a demand on y is a demand on the
241 -- scrutinee, so we need to `both` it with the scrut demand
243 scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
245 idNewDemandInfo case_bndr'
247 (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
249 (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
251 dmdAnal sigs dmd (Case scrut case_bndr alts)
253 (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
254 (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut
255 (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
257 -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
258 (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' alts')
260 dmdAnal sigs dmd (Let (NonRec id rhs) body)
262 (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel sigs (id, rhs)
263 (body_ty, body') = dmdAnal sigs' dmd body
264 (body_ty1, id2) = annotateBndr body_ty id1
265 body_ty2 = addLazyFVs body_ty1 lazy_fv
268 -- If the actual demand is better than the vanilla
269 -- demand, we might do better to re-analyse with the
271 (let vanilla_dmd = vanillaCall (idArity id)
272 actual_dmd = idNewDemandInfo id2
274 if actual_dmd `betterDemand` vanilla_dmd && actual_dmd /= vanilla_dmd then
275 pprTrace "dmdLet: better demand" (ppr id <+> vcat [text "vanilla" <+> ppr vanilla_dmd,
276 text "actual" <+> ppr actual_dmd])
279 (body_ty2, Let (NonRec id2 rhs') body')
281 dmdAnal sigs dmd (Let (Rec pairs) body)
283 bndrs = map fst pairs
284 (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs
285 (body_ty, body') = dmdAnal sigs' dmd body
286 body_ty1 = addLazyFVs body_ty lazy_fv
288 sigs' `seq` body_ty `seq`
290 (body_ty2, _) = annotateBndrs body_ty1 bndrs
291 -- Don't bother to add demand info to recursive
292 -- binders as annotateBndr does;
293 -- being recursive, we can't treat them strictly.
294 -- But we do need to remove the binders from the result demand env
296 (body_ty2, Let (Rec pairs') body')
299 dmdAnalAlt sigs dmd (con,bndrs,rhs)
301 (rhs_ty, rhs') = dmdAnal sigs dmd rhs
302 (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs
304 (alt_ty, (con, bndrs', rhs'))
307 %************************************************************************
309 \subsection{Bindings}
311 %************************************************************************
314 dmdFix :: TopLevelFlag
315 -> SigEnv -- Does not include bindings for this binding
318 [(Id,CoreExpr)]) -- Binders annotated with stricness info
320 dmdFix top_lvl sigs orig_pairs
321 = loop 1 initial_sigs orig_pairs
323 bndrs = map fst orig_pairs
324 initial_sigs = extendSigEnvList sigs [(id, (initial_sig id, top_lvl)) | id <- bndrs]
327 -> SigEnv -- Already contains the current sigs
329 -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
331 | all (same_sig sigs sigs') bndrs
332 = (sigs', lazy_fv, pairs')
333 -- Note: use pairs', not pairs. pairs' is the result of
334 -- processing the RHSs with sigs (= sigs'), whereas pairs
335 -- is the result of processing the RHSs with the *previous*
336 -- iteration of sigs.
337 | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat
338 [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
339 text "env:" <+> ppr (ufmToList sigs),
340 text "binds:" <+> pprCoreBinding (Rec pairs)]))
341 (emptySigEnv, emptyDmdEnv, orig_pairs) -- Safe output
342 | otherwise = loop (n+1) sigs' pairs'
344 -- Use the new signature to do the next pair
345 -- The occurrence analyser has arranged them in a good order
346 -- so this can significantly reduce the number of iterations needed
347 ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs
349 my_downRhs top_lvl (sigs,lazy_fv) (id,rhs)
350 = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig))
352 -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' )
353 ((sigs', lazy_fv'), pair')
356 (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl sigs (id,rhs)
357 lazy_fv' = plusUFM_C both lazy_fv lazy_fv1
358 -- old_sig = lookup sigs id
359 -- new_sig = lookup sigs' id
361 -- Get an initial strictness signature from the Id
362 -- itself. That way we make use of earlier iterations
363 -- of the fixpoint algorithm. (Cunning plan.)
364 -- Note that the cunning plan extends to the DmdEnv too,
365 -- since it is part of the strictness signature
366 initial_sig id = idNewStrictness_maybe id `orElse` botSig
368 same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
369 lookup sigs var = case lookupVarEnv sigs var of
372 dmdAnalRhs :: TopLevelFlag
373 -> SigEnv -> (Id, CoreExpr)
374 -> (SigEnv, DmdEnv, (Id, CoreExpr))
375 -- Process the RHS of the binding, add the strictness signature
376 -- to the Id, and augment the environment with the signature as well.
378 dmdAnalRhs top_lvl sigs (id, rhs)
379 = (sigs', lazy_fv, (id', rhs'))
381 arity = idArity id -- The idArity should be up to date
382 -- The simplifier was run just beforehand
383 (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
384 (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty, ppr id )
385 mkSigTy id rhs rhs_dmd_ty
386 id' = id `setIdNewStrictness` sig_ty
387 sigs' = extendSigEnv top_lvl sigs id sig_ty
390 %************************************************************************
392 \subsection{Strictness signatures and types}
394 %************************************************************************
397 mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
398 -- Take a DmdType and turn it into a StrictSig
399 -- NB: not used for never-inline things; hence False
400 mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
402 mkSigTy :: Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
403 mkSigTy id rhs dmd_ty = mk_sig_ty (isNeverActive (idInlinePragma id))
404 (isStrictDmd (idNewDemandInfo id))
407 mk_sig_ty never_inline strictly_demanded rhs (DmdType fv dmds res)
408 | never_inline && not (isBotRes res)
410 -- Don't strictness-analyse NOINLINE things. Why not? Because
411 -- the NOINLINE says "don't expose any of the inner workings at the call
412 -- site" and the strictness is certainly an inner working.
414 -- More concretely, the demand analyser discovers the following strictness
415 -- for unsafePerformIO: C(U(AV))
417 -- unsafePerformIO (\s -> let r = f x in
418 -- case writeIORef v r s of (# s1, _ #) ->
420 -- The strictness analyser will find that the binding for r is strict,
421 -- (becuase of uPIO's strictness sig), and so it'll evaluate it before
422 -- doing the writeIORef. This actually makes tests/lib/should_run/memo002
425 -- Solution: don't expose the strictness of unsafePerformIO.
427 -- But we do want to expose the strictness of error functions,
428 -- which are also often marked NOINLINE
429 -- {-# NOINLINE foo #-}
430 -- foo x = error ("wubble buggle" ++ x)
431 -- So (hack, hack) we only drop the strictness for non-bottom things
432 -- This is all very unsatisfactory.
433 = (deferEnv fv, topSig)
436 = (lazy_fv, mkStrictSig dmd_ty)
438 dmd_ty = DmdType strict_fv final_dmds res'
440 lazy_fv = filterUFM (not . isStrictDmd) fv
441 strict_fv = filterUFM isStrictDmd fv
442 -- We put the strict FVs in the DmdType of the Id, so
443 -- that at its call sites we unleash demands on its strict fvs.
444 -- An example is 'roll' in imaginary/wheel-sieve2
445 -- Something like this:
447 -- go y = if ... then roll (x-1) else x+1
450 -- We want to see that roll is strict in x, which is because
451 -- go is called. So we put the DmdEnv for x in go's DmdType.
454 -- f :: Int -> Int -> Int
455 -- f x y = let t = x+1
456 -- h z = if z==0 then t else
457 -- if z==1 then x+1 else
461 -- Calling h does indeed evaluate x, but we can only see
462 -- that if we unleash a demand on x at the call site for t.
464 -- Incidentally, here's a place where lambda-lifting h would
465 -- lose the cigar --- we couldn't see the joint strictness in t/x
468 -- We don't want to put *all* the fv's from the RHS into the
469 -- DmdType, because that makes fixpointing very slow --- the
470 -- DmdType gets full of lazy demands that are slow to converge.
472 final_dmds = setUnpackStrategy dmds
473 -- Set the unpacking strategy
476 RetCPR | ignore_cpr_info -> TopRes
478 ignore_cpr_info = is_thunk && not strictly_demanded
479 is_thunk = not (exprIsValue rhs)
480 -- If the rhs is a thunk, we forget the CPR info, because
481 -- it is presumably shared (else it would have been inlined, and
482 -- so we'd lose sharing if w/w'd it into a function.
484 -- Also, if the strictness analyser has figured out (in a previous iteration)
485 -- that it's strict, the let-to-case transformation will happen, so again
487 -- This made a big difference to PrelBase.modInt, which had something like
488 -- modInt = \ x -> let r = ... -> I# v in
489 -- ...body strict in r...
490 -- r's RHS isn't a value yet; but modInt returns r in various branches, so
491 -- if r doesn't have the CPR property then neither does modInt
492 -- Another case I found in practice (in Complex.magnitude), looks like this:
493 -- let k = if ... then I# a else I# b
494 -- in ... body strict in k ....
495 -- (For this example, it doesn't matter whether k is returned as part of
496 -- the overall result.) Left to itself, the simplifier will make a join
498 -- let $j k = ...body strict in k...
499 -- if ... then $j (I# a) else $j (I# b)
502 -- The difficulty with this is that we need the strictness type to
503 -- look at the body... but we now need the body to calculate the demand
504 -- on the variable, so we can decide whether its strictness type should
505 -- have a CPR in it or not. Simple solution:
506 -- a) use strictness info from the previous iteration
507 -- b) make sure we do at least 2 iterations, by doing a second
508 -- round for top-level non-recs. Top level recs will get at
509 -- least 2 iterations except for totally-bottom functions
510 -- which aren't very interesting anyway.
512 -- NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
515 The unpack strategy determines whether we'll *really* unpack the argument,
516 or whether we'll just remember its strictness. If unpacking would give
517 rise to a *lot* of worker args, we may decide not to unpack after all.
520 setUnpackStrategy :: [Demand] -> [Demand]
522 = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds)
524 go :: Int -- Max number of args available for sub-components of [Demand]
526 -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
528 go n (Eval (Prod cs) : ds)
529 | n' >= 0 = Eval (Prod cs') `cons` go n'' ds
530 | otherwise = Box (Eval (Prod cs)) `cons` go n ds
533 n' = n + 1 - non_abs_args
534 -- Add one to the budget 'cos we drop the top-level arg
535 non_abs_args = nonAbsentArgs cs
536 -- Delete # of non-absent args to which we'll now be committed
538 go n (d:ds) = d `cons` go n ds
541 cons d (n,ds) = (n, d:ds)
543 nonAbsentArgs :: [Demand] -> Int
545 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
546 nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
550 %************************************************************************
552 \subsection{Strictness signatures and types}
554 %************************************************************************
557 splitDmdTy :: DmdType -> (Demand, DmdType)
558 -- Split off one function argument
559 -- We already have a suitable demand on all
560 -- free vars, so no need to add more!
561 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
562 splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
566 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
568 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
569 | isTopLevel top_lvl = dmd_ty -- Don't record top level things
570 | otherwise = DmdType (extendVarEnv fv var dmd) ds res
572 addLazyFVs (DmdType fv ds res) lazy_fvs
573 = DmdType both_fv1 ds res
575 both_fv = (plusUFM_C both fv lazy_fvs)
576 both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv
577 -- This modifyEnv is vital. Consider
578 -- let f = \x -> (x,y)
580 -- Here, y is treated as a lazy-fv of f, but we must `both` that L
581 -- demand with the bottom coming up from 'error'
583 -- I got a loop in the fixpointer without this, due to an interaction
584 -- with the lazy_fv filtering in mkSigTy. Roughly, it was
586 -- = letrec g y = x `fatbar`
587 -- letrec h z = z + ...g...
590 -- In the initial iteration for f, f=Bot
591 -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
592 -- is lazy. Now consider the fixpoint iteration for g, esp the demands it
593 -- places on its free variables. Suppose it places none. Then the
594 -- x `fatbar` ...call to h...
595 -- will give a x->V demand for x. That turns into a L demand for x,
596 -- which floats out of the defn for h. Without the modifyEnv, that
597 -- L demand doesn't get both'd with the Bot coming up from the inner
598 -- call to f. So we just get an L demand for x for g.
600 -- A better way to say this is that the lazy-fv filtering should give the
601 -- same answer as putting the lazy fv demands in the function's type.
603 annotateBndr :: DmdType -> Var -> (DmdType, Var)
604 -- The returned env has the var deleted
605 -- The returned var is annotated with demand info
606 -- No effect on the argument demands
607 annotateBndr dmd_ty@(DmdType fv ds res) var
608 | isTyVar var = (dmd_ty, var)
609 | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)
611 (fv', dmd) = removeFV fv var res
613 annotateBndrs = mapAccumR annotateBndr
615 annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
616 -- For lambdas we add the demand to the argument demands
617 -- Only called for Ids
619 (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
621 (fv', dmd) = removeFV fv id res
622 hacked_dmd = argDemand dmd
623 -- This call to argDemand is vital, because otherwise we label
624 -- a lambda binder with demand 'B'. But in terms of calling
625 -- conventions that's Abs, because we don't pass it. But
626 -- when we do a w/w split we get
627 -- fw x = (\x y:B -> ...) x (error "oops")
628 -- And then the simplifier things the 'B' is a strict demand
629 -- and evaluates the (error "oops"). Sigh
631 removeFV fv id res = (fv', zapUnlifted id dmd)
633 fv' = fv `delVarEnv` id
634 dmd = lookupVarEnv fv id `orElse` deflt
635 deflt | isBotRes res = Bot
638 -- For unlifted-type variables, we are only
639 -- interested in Bot/Abs/Box Abs
640 zapUnlifted is Bot = Bot
641 zapUnlifted id Abs = Abs
642 zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
646 %************************************************************************
648 \subsection{Strictness signatures}
650 %************************************************************************
653 type SigEnv = VarEnv (StrictSig, TopLevelFlag)
654 -- We use the SigEnv to tell us whether to
655 -- record info about a variable in the DmdEnv
656 -- We do so if it's a LocalId, but not top-level
658 -- The DmdEnv gives the demand on the free vars of the function
659 -- when it is given enough args to satisfy the strictness signature
661 emptySigEnv = emptyVarEnv
663 extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
664 extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)
666 extendSigEnvList = extendVarEnvList
668 dmdTransform :: SigEnv -- The strictness environment
669 -> Id -- The function
670 -> Demand -- The demand on the function
671 -> DmdType -- The demand type of the function in this context
672 -- Returned DmdEnv includes the demand on
673 -- this function plus demand on its free variables
675 dmdTransform sigs var dmd
677 ------ DATA CONSTRUCTOR
678 | isDataConId var -- Data constructor
680 StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
681 DmdType _ _ con_res = dmd_ty
684 if arity == call_depth then -- Saturated, so unleash the demand
686 -- Important! If we Keep the constructor application, then
687 -- we need the demands the constructor places (always lazy)
688 -- If not, we don't need to. For example:
689 -- f p@(x,y) = (p,y) -- S(AL)
691 -- It's vital that we don't calculate Absent for a!
692 dmd_ds = case res_dmd of
693 Box (Eval ds) -> mapDmds box ds
697 -- ds can be empty, when we are just seq'ing the thing
698 -- If so we must make up a suitable bunch of demands
699 arg_ds = case dmd_ds of
700 Poly d -> replicate arity d
701 Prod ds -> ASSERT( ds `lengthIs` arity ) ds
704 mkDmdType emptyDmdEnv arg_ds con_res
705 -- Must remember whether it's a product, hence con_res, not TopRes
709 ------ IMPORTED FUNCTION
710 | isGlobalId var, -- Imported function
711 let StrictSig dmd_ty = idNewStrictness var
712 = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
717 ------ LOCAL LET/REC BOUND THING
718 | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
720 fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
721 | otherwise = deferType dmd_ty
722 -- NB: it's important to use deferType, and not just return topDmdType
723 -- Consider let { f x y = p + x } in f 1
724 -- The application isn't saturated, but we must nevertheless propagate
725 -- a lazy demand for p!
727 addVarDmd top_lvl fn_ty var dmd
729 ------ LOCAL NON-LET/REC BOUND THING
730 | otherwise -- Default case
734 (call_depth, res_dmd) = splitCallDmd dmd
738 %************************************************************************
742 %************************************************************************
745 splitCallDmd :: Demand -> (Int, Demand)
746 splitCallDmd (Call d) = case splitCallDmd d of
748 splitCallDmd d = (0, d)
750 vanillaCall :: Arity -> Demand
751 vanillaCall 0 = evalDmd
752 vanillaCall n = Call (vanillaCall (n-1))
754 deferType :: DmdType -> DmdType
755 deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
756 -- Notice that we throw away info about both arguments and results
757 -- For example, f = let ... in \x -> x
758 -- We don't want to get a stricness type V->T for f.
761 deferEnv :: DmdEnv -> DmdEnv
762 deferEnv fv = mapVarEnv defer fv
766 argDemand :: Demand -> Demand
767 -- The 'Defer' demands are just Lazy at function boundaries
768 -- Ugly! Ask John how to improve it.
769 argDemand Top = lazyDmd
770 argDemand (Defer d) = lazyDmd
771 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
772 argDemand (Box Bot) = evalDmd
773 argDemand (Box d) = box (argDemand d)
774 argDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
779 betterStrictness :: StrictSig -> StrictSig -> Bool
780 betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
782 betterDmdType t1 t2 = (t1 `lubType` t2) == t2
784 betterDemand :: Demand -> Demand -> Bool
785 -- If d1 `better` d2, and d2 `better` d2, then d1==d2
786 betterDemand d1 d2 = (d1 `lub` d2) == d2
790 -------------------------
791 -- Consider (if x then y else []) with demand V
792 -- Then the first branch gives {y->V} and the second
793 -- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
794 -- in the result env.
795 lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
796 = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
798 lub_fv = plusUFM_C lub fv1 fv2
799 lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv
800 lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1
801 -- lub is the identity for Bot
803 -- Extend the shorter argument list to match the longer
804 lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
806 lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1
807 lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2
809 -----------------------------------
810 -- (t1 `bothType` t2) takes the argument/result info from t1,
811 -- using t2 just for its free-var info
812 -- NB: Don't forget about r2! It might be BotRes, which is
813 -- a bottom demand on all the in-scope variables.
814 -- Peter: can this be done more neatly?
815 bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
816 = DmdType both_fv2 ds1 (r1 `bothRes` r2)
818 both_fv = plusUFM_C both fv1 fv2
819 both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv
820 both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1
821 -- both is the identity for Abs
828 lubRes RetCPR RetCPR = RetCPR
829 lubRes r1 r2 = TopRes
831 -- If either diverges, the whole thing does
832 -- Otherwise take CPR info from the first
833 bothRes r1 BotRes = BotRes
838 modifyEnv :: Bool -- No-op if False
839 -> (Demand -> Demand) -- The zapper
840 -> DmdEnv -> DmdEnv -- Env1 and Env2
841 -> DmdEnv -> DmdEnv -- Transform this env
842 -- Zap anything in Env1 but not in Env2
843 -- Assume: dom(env) includes dom(Env1) and dom(Env2)
845 modifyEnv need_to_modify zapper env1 env2 env
846 | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
849 zap uniq env = addToUFM_Directly env uniq (zapper current_val)
851 current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)
855 %************************************************************************
857 \subsection{LUB and BOTH}
859 %************************************************************************
862 lub :: Demand -> Demand -> Demand
865 lub Abs d2 = absLub d2
867 lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2)
869 lub (Call d1) (Call d2) = Call (d1 `lub` d2)
870 lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box
871 lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval
872 lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top
874 -- For the Eval case, we use these approximation rules
875 -- Box Bot <= Eval (Box Bot ...)
876 -- Box Top <= Defer (Box Bot ...)
877 -- Box (Eval ds) <= Eval (map Box ds)
878 lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2)
879 lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1)
880 lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2)
881 lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1)
882 lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer
884 lub (Box d1) (Box d2) = box (d1 `lub` d2)
885 lub d1@(Box _) d2 = d2 `lub` d1
887 lubs = zipWithDmds lub
889 ---------------------
890 -- box is the smart constructor for Box
891 -- It computes <B,bot> & d
892 -- INVARIANT: (Box d) => d = Bot, Abs, Eval
893 -- Seems to be no point in allowing (Box (Call d))
894 box (Call d) = Call d -- The odd man out. Why?
896 box (Defer _) = lazyDmd
897 box Top = lazyDmd -- Box Abs and Box Top
898 box Abs = lazyDmd -- are the same <B,L>
899 box d = Box d -- Bot, Eval
902 defer :: Demand -> Demand
904 -- defer is the smart constructor for Defer
905 -- The idea is that (Defer ds) = <U(ds), L>
907 -- It specifies what happens at a lazy function argument
908 -- or a lambda; the L* operator
909 -- Set the strictness part to L, but leave
910 -- the boxity side unaffected
911 -- It also ensures that Defer (Eval [LLLL]) = L
916 defer (Call _) = lazyDmd -- Approximation here?
917 defer (Box _) = lazyDmd
918 defer (Defer ds) = Defer ds
919 defer (Eval ds) = deferEval ds
921 -- deferEval ds = defer (Eval ds)
922 deferEval ds | allTop ds = Top
923 | otherwise = Defer ds
925 ---------------------
926 absLub :: Demand -> Demand
927 -- Computes (Abs `lub` d)
928 -- For the Bot case consider
929 -- f x y = if ... then x else error x
930 -- Then for y we get Abs `lub` Bot, and we really
935 absLub (Call _) = Top
937 absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)?
938 absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)?
940 absLubs = mapDmds absLub
943 both :: Demand -> Demand -> Demand
949 both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds)
952 -- From 'error' itself we get demand Bot on x
953 -- From the arg demand on x we get
954 -- x :-> evalDmd = Box (Eval (Poly Abs))
955 -- So we get Bot `both` Box (Eval (Poly Abs))
956 -- = Seq Keep (Poly Bot)
959 -- f x = if ... then error (fst x) else fst x
960 -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA))
962 -- which is what we want.
965 both Top Bot = errDmd
968 both Top (Box d) = Box d
969 both Top (Call d) = Call d
970 both Top (Eval ds) = Eval (mapDmds (`both` Top) ds)
971 both Top (Defer ds) -- = defer (Top `both` Eval ds)
972 -- = defer (Eval (mapDmds (`both` Top) ds))
973 = deferEval (mapDmds (`both` Top) ds)
976 both (Box d1) (Box d2) = box (d1 `both` d2)
977 both (Box d1) d2@(Call _) = box (d1 `both` d2)
978 both (Box d1) d2@(Eval _) = box (d1 `both` d2)
979 both (Box d1) (Defer d2) = Box d1
980 both d1@(Box _) d2 = d2 `both` d1
982 both (Call d1) (Call d2) = Call (d1 `both` d2)
983 both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)?
984 both (Call d1) (Defer ds2) = Call d1 -- Ditto
985 both d1@(Call _) d2 = d1 `both` d1
987 both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2)
988 both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2)
989 both d1@(Eval ds1) d2 = d2 `both` d1
991 both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2)
992 both d1@(Defer ds1) d2 = d2 `both` d1
994 boths = zipWithDmds both
999 %************************************************************************
1001 \subsection{Miscellaneous
1003 %************************************************************************
1008 get_changes binds = vcat (map get_changes_bind binds)
1010 get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
1011 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
1013 get_changes_pr (id,rhs)
1014 = get_changes_var id $$ get_changes_expr rhs
1017 | isId var = get_changes_str var $$ get_changes_dmd var
1020 get_changes_expr (Type t) = empty
1021 get_changes_expr (Var v) = empty
1022 get_changes_expr (Lit l) = empty
1023 get_changes_expr (Note n e) = get_changes_expr e
1024 get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
1025 get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
1026 get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
1027 get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
1029 get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
1032 | new_better && old_better = empty
1033 | new_better = message "BETTER"
1034 | old_better = message "WORSE"
1035 | otherwise = message "INCOMPARABLE"
1037 message word = text word <+> text "strictness for" <+> ppr id <+> info
1038 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1039 new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
1040 -- strictness analyser can't track
1041 old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
1042 old_better = old `betterStrictness` new
1043 new_better = new `betterStrictness` old
1046 | isUnLiftedType (idType id) = empty -- Not useful
1047 | new_better && old_better = empty
1048 | new_better = message "BETTER"
1049 | old_better = message "WORSE"
1050 | otherwise = message "INCOMPARABLE"
1052 message word = text word <+> text "demand for" <+> ppr id <+> info
1053 info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
1054 new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
1056 old = newDemand (idDemandInfo id)
1057 new_better = new `betterDemand` old
1058 old_better = old `betterDemand` new
1061 squashSig (StrictSig (DmdType fv ds res))
1062 = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
1064 -- squash just gets rid of call demands
1065 -- which the old analyser doesn't track
1066 squashDmd (Call d) = evalDmd
1067 squashDmd (Box d) = Box (squashDmd d)
1068 squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
1069 squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)