2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
8 -- If OLD_STRICTNESS is off, omit all exports
9 module SaAbsInt () where
14 findDemand, findDemandAlts,
21 #include "HsVersions.h"
23 import StaticFlags ( opt_AllStrict, opt_NumbersStrict )
25 import CoreUnfold ( maybeUnfoldingTemplate )
26 import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
29 import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
30 import IdInfo ( StrictnessInfo(..) )
31 import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
32 mkStrictnessInfo, isLazy
35 import TyCon ( isProductTyCon, isRecursiveTyCon )
36 import Type ( splitTyConApp_maybe,
37 isUnLiftedType, Type )
38 import TyCon ( tyConUnique )
39 import PrelInfo ( numericTyKeys )
40 import Util ( isIn, nOfThem, zipWithEqual, equalLength )
44 %************************************************************************
46 \subsection[AbsVal-ops]{Operations on @AbsVals@}
48 %************************************************************************
50 Least upper bound, greatest lower bound.
53 lub, glb :: AbsVal -> AbsVal -> AbsVal
55 lub AbsBot val2 = val2
56 lub val1 AbsBot = val1
58 lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
60 lub _ _ = AbsTop -- Crude, but conservative
61 -- The crudity only shows up if there
62 -- are functions involved
64 -- Slightly funny glb; for absence analysis only;
65 -- AbsBot is the safe answer.
67 -- Using anyBot rather than just testing for AbsBot is important.
72 -- g = \x y z -> case x of
76 -- Now, the abstract value of the branches of the case will be an
77 -- AbsFun, but when testing for z's absence we want to spot that it's
78 -- an AbsFun which can't possibly return AbsBot. So when glb'ing we
79 -- mustn't be too keen to bale out and return AbsBot; the anyBot test
80 -- spots that (f x) can't possibly return AbsBot.
82 -- We have also tripped over the following interesting case:
87 -- Now, suppose f is bound to AbsTop. Does this expression mention z?
88 -- Obviously not. But the case will take the glb of AbsTop (for f) and
89 -- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
90 -- that would say that it *does* mention z (or anything else for that matter).
91 -- Nor can we always return AbsTop, because the AbsFun might be something
92 -- like (\y->z), which obviously does mention z. The point is that we're
93 -- glbing two functions, and AbsTop is not actually the top of the function
94 -- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns
95 -- poison iff any of its arguments do.
97 -- Deal with functions specially, because AbsTop isn't the
98 -- top of their domain.
101 | is_fun v1 || is_fun v2
102 = if not (anyBot v1) && not (anyBot v2)
108 is_fun (AbsFun _ _) = True
109 is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
112 -- The non-functional cases are quite straightforward
114 glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
119 glb _ _ = AbsBot -- Be pessimistic
122 @isBot@ returns True if its argument is (a representation of) bottom. The
123 ``representation'' part is because we need to detect the bottom {\em function}
124 too. To detect the bottom function, bind its args to top, and see if it
127 Used only in strictness analysis:
129 isBot :: AbsVal -> Bool
132 isBot other = False -- Functions aren't bottom any more
135 Used only in absence analysis:
138 anyBot :: AbsVal -> Bool
140 anyBot AbsBot = True -- poisoned!
141 anyBot AbsTop = False
142 anyBot (AbsProd vals) = any anyBot vals
143 anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
144 anyBot (AbsApproxFun _ val) = anyBot val
147 @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
148 approximated by $val$. Furthermore, the result has no @AbsFun@s in
149 it, so it can be compared for equality by @sameVal@.
152 widen :: AnalysisKind -> AbsVal -> AbsVal
154 -- Widening is complicated by the fact that funtions are lifted
155 widen StrAnal the_fn@(AbsFun bndr_ty _)
156 = case widened_body of
157 AbsApproxFun ds val -> AbsApproxFun (d : ds) val
159 d = findRecDemand str_fn abs_fn bndr_ty
160 str_fn val = isBot (foldl (absApply StrAnal) the_fn
161 (val : [AbsTop | d <- ds]))
163 other -> AbsApproxFun [d] widened_body
165 d = findRecDemand str_fn abs_fn bndr_ty
166 str_fn val = isBot (absApply StrAnal the_fn val)
168 widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
169 abs_fn val = False -- Always says poison; so it looks as if
170 -- nothing is absent; safe
173 This stuff is now instead handled neatly by the fact that AbsApproxFun
174 contains an AbsVal inside it. SLPJ Jan 97
176 | isBot abs_body = AbsBot
177 -- It's worth checking for a function which is unconditionally
180 -- f x y = let g y = case x of ...
181 -- in (g ..) + (g ..)
183 -- Here, when we are considering strictness of f in x, we'll
184 -- evaluate the body of f with x bound to bottom. The current
185 -- strategy is to bind g to its *widened* value; without the isBot
186 -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
187 -- Top, not Bot as the value of f's rhs. The test spots the
188 -- unconditional bottom-ness of g when x is bottom. (Another
189 -- alternative here would be to bind g to its exact abstract
190 -- value, but that entails lots of potential re-computation, at
191 -- every application of g.)
194 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
195 widen StrAnal other_val = other_val
198 widen AbsAnal the_fn@(AbsFun bndr_ty _)
199 | anyBot widened_body = AbsBot
200 -- In the absence-analysis case it's *essential* to check
201 -- that the function has no poison in its body. If it does,
202 -- anywhere, then the whole function is poisonous.
205 = case widened_body of
206 AbsApproxFun ds val -> AbsApproxFun (d : ds) val
208 d = findRecDemand str_fn abs_fn bndr_ty
209 abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn
210 (val : [AbsTop | d <- ds])))
212 other -> AbsApproxFun [d] widened_body
214 d = findRecDemand str_fn abs_fn bndr_ty
215 abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
217 widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
218 str_fn val = True -- Always says non-termination;
219 -- that'll make findRecDemand peer into the
220 -- structure of the value.
222 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
224 -- It's desirable to do a good job of widening for product
228 -- in ...(case p of (x,y) -> x)...
230 -- Now, is y absent in this expression? Currently the
231 -- analyser widens p before looking at p's scope, to avoid
232 -- lots of recomputation in the case where p is a function.
233 -- So if widening doesn't have a case for products, we'll
234 -- widen p to AbsBot (since when searching for absence in y we
235 -- bind y to poison ie AbsBot), and now we are lost.
237 widen AbsAnal other_val = other_val
239 -- WAS: if anyBot val then AbsBot else AbsTop
240 -- Nowadays widen is doing a better job on functions for absence analysis.
243 @crudeAbsWiden@ is used just for absence analysis, and always
244 returns AbsTop or AbsBot, so it widens to a two-point domain
247 crudeAbsWiden :: AbsVal -> AbsVal
248 crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
251 @sameVal@ compares two abstract values for equality. It can't deal with
252 @AbsFun@, but that should have been removed earlier in the day by @widen@.
255 sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
258 sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
259 sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
262 sameVal AbsBot AbsBot = True
263 sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot
265 sameVal AbsTop AbsTop = True
266 sameVal AbsTop other = False -- Right?
268 sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
269 sameVal (AbsProd _) AbsTop = False
270 sameVal (AbsProd _) AbsBot = False
272 sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
273 sameVal (AbsApproxFun _ _) AbsTop = False
274 sameVal (AbsApproxFun _ _) AbsBot = False
276 sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
280 @evalStrictness@ compares a @Demand@ with an abstract value, returning
281 @True@ iff the abstract value is {\em less defined} than the demand.
282 (@True@ is the exciting answer; @False@ is always safe.)
285 evalStrictness :: Demand
287 -> Bool -- True iff the value is sure
288 -- to be less defined than the Demand
290 evalStrictness (WwLazy _) _ = False
291 evalStrictness WwStrict val = isBot val
292 evalStrictness WwEnum val = isBot val
294 evalStrictness (WwUnpack _ demand_info) val
299 | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
301 | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
303 _ -> pprTrace "evalStrictness?" empty False
305 evalStrictness WwPrim val
308 AbsBot -> True -- Can happen: consider f (g x), where g is a
309 -- recursive function returning an Int# that diverges
311 other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
314 For absence analysis, we're interested in whether "poison" in the
315 argument (ie a bottom therein) can propagate to the result of the
316 function call; that is, whether the specified demand can {\em
317 possibly} hit poison.
320 evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
321 -- with Absent demand
323 evalAbsence (WwUnpack _ demand_info) val
325 AbsTop -> False -- No poison in here
326 AbsBot -> True -- Pure poison
328 | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
330 | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
331 _ -> pprTrace "TELL SIMON: evalAbsence"
332 (ppr demand_info $$ ppr val)
335 evalAbsence other val = anyBot val
336 -- The demand is conservative; even "Lazy" *might* evaluate the
337 -- argument arbitrarily so we have to look everywhere for poison
340 %************************************************************************
342 \subsection[absEval]{Evaluate an expression in the abstract domain}
344 %************************************************************************
347 -- The isBottomingId stuf is now dealt with via the Id's strictness info
348 -- absId anal var env | isBottomingId var
350 -- StrAnal -> AbsBot -- See discussion below
351 -- AbsAnal -> AbsTop -- Just want to see if there's any poison in
355 = case (lookupAbsValEnv env var,
356 isDataConWorkId_maybe var,
358 maybeUnfoldingTemplate (idUnfolding var)) of
360 (Just abs_val, _, _, _) ->
361 abs_val -- Bound in the environment
363 (_, Just data_con, _, _) | isProductTyCon tycon &&
364 not (isRecursiveTyCon tycon)
365 -> -- A product. We get infinite loops if we don't
366 -- check for recursive products!
367 -- The strictness info on the constructor
368 -- isn't expressive enough to contain its abstract value
369 productAbsVal (dataConRepArgTys data_con) []
371 tycon = dataConTyCon data_con
373 (_, _, NoStrictnessInfo, Just unfolding) ->
374 -- We have an unfolding for the expr
375 -- Assume the unfolding has no free variables since it
376 -- came from inside the Id
377 absEval anal unfolding env
378 -- Notice here that we only look in the unfolding if we don't
379 -- have strictness info (an unusual situation).
380 -- We could have chosen to look in the unfolding if it exists,
381 -- and only try the strictness info if it doesn't, and that would
382 -- give more accurate results, at the cost of re-abstract-interpreting
383 -- the unfolding every time.
384 -- We found only one place where the look-at-unfolding-first
385 -- method gave better results, which is in the definition of
386 -- showInt in the Prelude. In its defintion, fromIntegral is
387 -- not inlined (it's big) but ab-interp-ing its unfolding gave
388 -- a better result than looking at its strictness only.
389 -- showInt :: Integral a => a -> [Char] -> [Char]
390 -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
391 -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
393 -- showInt :: Integral a => a -> [Char] -> [Char]
394 -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
395 -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
398 (_, _, strictness_info, _) ->
399 -- Includes NoUnfolding
400 -- Try the strictness info
401 absValFromStrictness anal strictness_info
403 productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args)
404 productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
408 absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
410 absEval anal (Type ty) env = AbsTop
411 absEval anal (Var var) env = absId anal var env
414 Discussion about error (following/quoting Lennart): Any expression
415 'error e' is regarded as bottom (with HBC, with the -ffail-strict
418 Regarding it as bottom gives much better strictness properties for
422 f (x:xs) y = f xs (x+y)
424 f [] _ = error "no match"
426 f (x:xs) y = f xs (x+y)
428 is strict in y, which you really want. But, it may lead to
429 transformations that turn a call to \tr{error} into non-termination.
430 (The odds of this happening aren't good.)
432 Things are a little different for absence analysis, because we want
433 to make sure that any poison (?????)
436 absEval anal (Lit _) env = AbsTop
437 -- Literals terminate (strictness) and are not poison (absence)
441 absEval anal (Lam bndr body) env
442 | isTyVar bndr = absEval anal body env -- Type lambda
443 | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda
445 abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
447 absEval anal (App expr (Type ty)) env
448 = absEval anal expr env -- Type appplication
449 absEval anal (App f val_arg) env
450 = absApply anal (absEval anal f env) -- Value applicationn
451 (absEval anal val_arg env)
455 absEval anal expr@(Case scrut case_bndr alts) env
457 scrut_val = absEval anal scrut env
458 alts_env = addOneToAbsValEnv env case_bndr scrut_val
460 case (scrut_val, alts) of
461 (AbsBot, _) -> AbsBot
463 (AbsProd arg_vals, [(con, bndrs, rhs)])
465 -- The scrutinee is a product value, so it must be of a single-constr
466 -- type; so the constructor in this alternative must be the right one
467 -- so we can go ahead and bind the constructor args to the components
468 -- of the product value.
469 ASSERT(equalLength arg_vals val_bndrs)
470 absEval anal rhs rhs_env
472 val_bndrs = filter isId bndrs
473 rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
475 other -> absEvalAlts anal alts alts_env
478 For @Lets@ we widen the value we get. This is nothing to
479 do with fixpointing. The reason is so that we don't get an explosion
480 in the amount of computation. For example, consider:
492 If we bind @f@ and @g@ to their exact abstract value, then we'll
493 ``execute'' one call to @f@ and {\em two} calls to @g@. This can blow
494 up exponentially. Widening cuts it off by making a fixed
495 approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
496 not evaluated again at all when they are called.
498 Of course, this can lose useful joint strictness, which is sad. An
499 alternative approach would be to try with a certain amount of ``fuel''
500 and be prepared to bale out.
503 absEval anal (Let (NonRec binder e1) e2) env
505 new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
507 -- The binder of a NonRec should *not* be of unboxed type,
508 -- hence no need to strictly evaluate the Rhs.
509 absEval anal e2 new_env
511 absEval anal (Let (Rec pairs) body) env
513 (binders,rhss) = unzip pairs
514 rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values
515 new_env = growAbsValEnvList env (binders `zip` rhs_vals)
517 absEval anal body new_env
519 absEval anal (Note (Coerce _ _) expr) env = AbsTop
520 -- Don't look inside coerces, becuase they
521 -- are usually recursive newtypes
522 -- (Could improve, for the error case, but we're about
523 -- to kill this analyser anyway.)
524 absEval anal (Note note expr) env = absEval anal expr env
528 absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
529 absEvalAlts anal alts env
530 = combine anal (map go alts)
532 combine StrAnal = foldr1 lub -- Diverge only if all diverge
533 combine AbsAnal = foldr1 glb -- Find any poison
536 = absEval anal rhs rhs_env
538 rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
541 %************************************************************************
543 \subsection[absApply]{Apply an abstract function to an abstract argument}
545 %************************************************************************
550 absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
552 absApply anal AbsBot arg = AbsBot
553 -- AbsBot represents the abstract bottom *function* too
555 absApply StrAnal AbsTop arg = AbsTop
556 absApply AbsAnal AbsTop arg = if anyBot arg
559 -- To be conservative, we have to assume that a function about
560 -- which we know nothing (AbsTop) might look at some part of
564 An @AbsFun@ with only one more argument needed---bind it and eval the
565 result. A @Lam@ with two or more args: return another @AbsFun@ with
566 an augmented environment.
569 absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
573 absApply StrAnal (AbsApproxFun (d:ds) val) arg
576 other -> AbsApproxFun ds val' -- Result is non-bot if there are still args
578 val' | evalStrictness d arg = AbsBot
581 absApply AbsAnal (AbsApproxFun (d:ds) val) arg
582 = if evalAbsence d arg
583 then AbsBot -- Poison in arg means poison in the application
586 other -> AbsApproxFun ds val
589 absApply anal f@(AbsProd _) arg
590 = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
597 %************************************************************************
599 \subsection[findStrictness]{Determine some binders' strictness}
601 %************************************************************************
605 -> AbsVal -- Abstract strictness value of function
606 -> AbsVal -- Abstract absence value of function
607 -> StrictnessInfo -- Resulting strictness annotation
609 findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
610 -- You might think there's really no point in describing detailed
611 -- strictness for a divergent function;
612 -- If it's fully applied we get bottom regardless of the
613 -- argument. If it's not fully applied we don't get bottom.
614 -- Finally, we don't want to regard the args of a divergent function
615 -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
617 -- HOWEVER, if we make diverging functions appear lazy, they
618 -- don't get wrappers, and then we get dreadful reboxing.
619 -- See notes with WwLib.worthSplitting
620 = find_strictness id str_ds str_res abs_ds
622 findStrictness id str_val abs_val
623 | isBot str_val = mkStrictnessInfo ([], True)
624 | otherwise = NoStrictnessInfo
626 -- The list of absence demands passed to combineDemands
627 -- can be shorter than the list of absence demands
629 -- lookup = \ dEq -> letrec {
630 -- lookup = \ key ds -> ...lookup...
633 -- Here the strictness value takes three args, but the absence value
634 -- takes only one, for reasons I don't quite understand (see cheapFixpoint)
636 find_strictness id orig_str_ds orig_str_res orig_abs_ds
637 = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
639 res_bot = isBot orig_str_res
641 go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
643 mk_dmd str_dmd (WwLazy True)
644 = WARN( not (res_bot || isLazy str_dmd),
645 ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
646 -- If the arg isn't used we jolly well don't expect the function
647 -- to be strict in it. Unless the function diverges.
648 WwLazy True -- Best of all
650 mk_dmd (WwUnpack u str_ds)
651 (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
653 mk_dmd str_dmd abs_dmd = str_dmd
658 findDemand dmd str_env abs_env expr binder
659 = findRecDemand str_fn abs_fn (idType binder)
661 str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
662 abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
664 findDemandAlts dmd str_env abs_env alts binder
665 = findRecDemand str_fn abs_fn (idType binder)
667 str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
668 abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
671 @findRecDemand@ is where we finally convert strictness/absence info
672 into ``Demands'' which we can pin on Ids (etc.).
674 NOTE: What do we do if something is {\em both} strict and absent?
675 Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
676 strict (because of bottoming effect of \tr{error}) or all absent
677 (because they're not used)?
679 Well, for practical reasons, we prefer absence over strictness. In
680 particular, it makes the ``default defaults'' for class methods (the
681 ones that say \tr{defm.foo dict = error "I don't exist"}) come out
682 nicely [saying ``the dict isn't used''], rather than saying it is
683 strict in every component of the dictionary [massive gratuitious
684 casing to take the dict apart].
686 But you could have examples where going for strictness would be better
687 than absence. Consider:
689 let x = something big
694 If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
695 lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict,
696 then we'd let-to-case it:
698 case something big of
704 findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot
705 -> (AbsVal -> Bool) -- True => function applied to this value yields no poison
706 -> Type -- The type of the argument
709 findRecDemand str_fn abs_fn ty
710 = if isUnLiftedType ty then -- It's a primitive type!
713 else if abs_fn AbsBot then -- It's absent
714 -- We prefer absence over strictness: see NOTE above.
717 else if not (opt_AllStrict ||
718 (opt_NumbersStrict && is_numeric_type ty) ||
720 WwLazy False -- It's not strict and we're not pretending
722 else -- It's strict (or we're pretending it is)!
724 case splitProductType_maybe ty of
726 Nothing -> wwStrict -- Could have a test for wwEnum, but
727 -- we don't exploit it yet, so don't bother
729 Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
730 | isRecursiveTyCon tycon -- Recursive data type; don't unpack
731 -> wwStrict -- (this applies to newtypes too:
732 -- e.g. data Void = MkVoid Void)
734 | null compt_strict_infos -- A nullary data type
737 | otherwise -- Some other data type
738 -> wwUnpack compt_strict_infos
741 prod_len = length cmpnt_tys
745 str_fn (mkMainlyTopProd prod_len i cmpnt_val)
748 abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
751 | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
755 = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
757 Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
759 is_elem = isIn "is_numeric_type"
761 -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
762 -- them) except for a given value in the "i"th position.
764 mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
766 mkMainlyTopProd n i val
768 befores = nOfThem (i-1) AbsTop
769 afters = nOfThem (n-i) AbsTop
771 AbsProd (befores ++ (val : afters))
774 %************************************************************************
776 \subsection[fixpoint]{Fixpointer for the strictness analyser}
778 %************************************************************************
780 The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
781 environment, and returns the abstract value of each binder.
783 The @cheapFixpoint@ function makes a conservative approximation,
784 by binding each of the variables to Top in their own right hand sides.
785 That allows us to make rapid progress, at the cost of a less-than-wonderful
789 cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
791 cheapFixpoint AbsAnal [id] [rhs] env
792 = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
794 new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point!
795 -- In the just-one-binding case, we guarantee to
796 -- find a fixed point in just one iteration,
797 -- because we are using only a two-point domain.
798 -- This improves matters in cases like:
800 -- f x y = letrec g = ...g...
803 -- Here, y isn't used at all, but if g is bound to
804 -- AbsBot we simply get AbsBot as the next
807 cheapFixpoint anal ids rhss env
808 = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
809 -- We do just one iteration, starting from a safe
810 -- approximation. This won't do a good job in situations
812 -- \x -> letrec f = ...g...
816 -- Here, f will end up bound to Top after one iteration,
817 -- and hence we won't spot the strictness in x.
818 -- (A second iteration would solve this. ToDo: try the effect of
819 -- really searching for a fixed point.)
821 new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
824 = case anal of -- The safe starting point
830 fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
832 fixpoint anal [] _ env = []
834 fixpoint anal ids rhss env
835 = fix_loop initial_vals
838 = case anal of -- The (unsafe) starting point
841 -- At one stage for StrAnal we said:
842 -- if (returnsRealWorld (idType id))
843 -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
844 -- but no one has the foggiest idea what this hack did,
845 -- and returnsRealWorld was a stub that always returned False
846 -- So this comment is all that is left of the hack!
848 initial_vals = [ initial_val id | id <- ids ]
850 fix_loop :: [AbsVal] -> [AbsVal]
852 fix_loop current_widened_vals
854 new_env = growAbsValEnvList env (ids `zip` current_widened_vals)
855 new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
856 new_widened_vals = map (widen anal) new_vals
858 if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
861 -- NB: I was too chicken to make that a zipWithEqual,
862 -- lest I jump into a black hole. WDP 96/02
864 -- Return the widened values. We might get a slightly
865 -- better value by returning new_vals (which we used to
866 -- do, see below), but alas that means that whenever the
867 -- function is called we have to re-execute it, which is
872 -- Return the un-widened values which may be a bit better
873 -- than the widened ones, and are guaranteed safe, since
874 -- they are one iteration beyond current_widened_vals,
875 -- which itself is a fixed point.
877 fix_loop new_widened_vals
880 For absence analysis, we make do with a very very simple approach:
881 look for convergence in a two-point domain.
883 We used to use just one iteration, starting with the variables bound
884 to @AbsBot@, which is safe.
886 Prior to that, we used one iteration starting from @AbsTop@ (which
887 isn't safe). Why isn't @AbsTop@ safe? Consider:
895 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
896 point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is
897 safe because it gives poison more often than really necessary, and
898 thus may miss some absence, but will never claim absence when it ain't
901 Anyway, one iteration starting with everything bound to @AbsBot@ give
906 Here, f would always end up bound to @AbsBot@, which ain't very
907 clever, because then it would introduce poison whenever it was
908 applied. Much better to start with f bound to @AbsTop@, and widen it
909 to @AbsBot@ if any poison shows up. In effect we look for convergence
910 in the two-point @AbsTop@/@AbsBot@ domain.
912 What we miss (compared with the cleverer strictness analysis) is
913 spotting that in this case
915 f = \ x y -> ...y...(f x y')...
917 \tr{x} is actually absent, since it is only passed round the loop, never
918 used. But who cares about missing that?
920 NB: despite only having a two-point domain, we may still have many
921 iterations, because there are several variables involved at once.
924 #endif /* OLD_STRICTNESS */