2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
8 -- If DEBUG is off, omit all exports
9 module SaAbsInt () where
14 findDemand, findDemandAlts,
21 #include "HsVersions.h"
23 import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
25 import CoreUnfold ( maybeUnfoldingTemplate )
26 import Id ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
27 import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
28 import IdInfo ( StrictnessInfo(..) )
29 import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
30 mkStrictnessInfo, isLazy
33 import TyCon ( isProductTyCon, isRecursiveTyCon )
34 import Type ( splitTyConApp_maybe,
35 isUnLiftedType, Type )
36 import TyCon ( tyConUnique )
37 import PrelInfo ( numericTyKeys )
38 import Util ( isIn, nOfThem, zipWithEqual )
42 %************************************************************************
44 \subsection[AbsVal-ops]{Operations on @AbsVals@}
46 %************************************************************************
48 Least upper bound, greatest lower bound.
51 lub, glb :: AbsVal -> AbsVal -> AbsVal
53 lub AbsBot val2 = val2
54 lub val1 AbsBot = val1
56 lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
58 lub _ _ = AbsTop -- Crude, but conservative
59 -- The crudity only shows up if there
60 -- are functions involved
62 -- Slightly funny glb; for absence analysis only;
63 -- AbsBot is the safe answer.
65 -- Using anyBot rather than just testing for AbsBot is important.
70 -- g = \x y z -> case x of
74 -- Now, the abstract value of the branches of the case will be an
75 -- AbsFun, but when testing for z's absence we want to spot that it's
76 -- an AbsFun which can't possibly return AbsBot. So when glb'ing we
77 -- mustn't be too keen to bale out and return AbsBot; the anyBot test
78 -- spots that (f x) can't possibly return AbsBot.
80 -- We have also tripped over the following interesting case:
85 -- Now, suppose f is bound to AbsTop. Does this expression mention z?
86 -- Obviously not. But the case will take the glb of AbsTop (for f) and
87 -- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
88 -- that would say that it *does* mention z (or anything else for that matter).
89 -- Nor can we always return AbsTop, because the AbsFun might be something
90 -- like (\y->z), which obviously does mention z. The point is that we're
91 -- glbing two functions, and AbsTop is not actually the top of the function
92 -- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns
93 -- poison iff any of its arguments do.
95 -- Deal with functions specially, because AbsTop isn't the
96 -- top of their domain.
99 | is_fun v1 || is_fun v2
100 = if not (anyBot v1) && not (anyBot v2)
106 is_fun (AbsFun _ _) = True
107 is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
110 -- The non-functional cases are quite straightforward
112 glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
117 glb _ _ = AbsBot -- Be pessimistic
120 @isBot@ returns True if its argument is (a representation of) bottom. The
121 ``representation'' part is because we need to detect the bottom {\em function}
122 too. To detect the bottom function, bind its args to top, and see if it
125 Used only in strictness analysis:
127 isBot :: AbsVal -> Bool
130 isBot other = False -- Functions aren't bottom any more
133 Used only in absence analysis:
136 anyBot :: AbsVal -> Bool
138 anyBot AbsBot = True -- poisoned!
139 anyBot AbsTop = False
140 anyBot (AbsProd vals) = any anyBot vals
141 anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
142 anyBot (AbsApproxFun _ val) = anyBot val
145 @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
146 approximated by $val$. Furthermore, the result has no @AbsFun@s in
147 it, so it can be compared for equality by @sameVal@.
150 widen :: AnalysisKind -> AbsVal -> AbsVal
152 -- Widening is complicated by the fact that funtions are lifted
153 widen StrAnal the_fn@(AbsFun bndr_ty _)
154 = case widened_body of
155 AbsApproxFun ds val -> AbsApproxFun (d : ds) val
157 d = findRecDemand str_fn abs_fn bndr_ty
158 str_fn val = isBot (foldl (absApply StrAnal) the_fn
159 (val : [AbsTop | d <- ds]))
161 other -> AbsApproxFun [d] widened_body
163 d = findRecDemand str_fn abs_fn bndr_ty
164 str_fn val = isBot (absApply StrAnal the_fn val)
166 widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
167 abs_fn val = False -- Always says poison; so it looks as if
168 -- nothing is absent; safe
171 This stuff is now instead handled neatly by the fact that AbsApproxFun
172 contains an AbsVal inside it. SLPJ Jan 97
174 | isBot abs_body = AbsBot
175 -- It's worth checking for a function which is unconditionally
178 -- f x y = let g y = case x of ...
179 -- in (g ..) + (g ..)
181 -- Here, when we are considering strictness of f in x, we'll
182 -- evaluate the body of f with x bound to bottom. The current
183 -- strategy is to bind g to its *widened* value; without the isBot
184 -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
185 -- Top, not Bot as the value of f's rhs. The test spots the
186 -- unconditional bottom-ness of g when x is bottom. (Another
187 -- alternative here would be to bind g to its exact abstract
188 -- value, but that entails lots of potential re-computation, at
189 -- every application of g.)
192 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
193 widen StrAnal other_val = other_val
196 widen AbsAnal the_fn@(AbsFun bndr_ty _)
197 | anyBot widened_body = AbsBot
198 -- In the absence-analysis case it's *essential* to check
199 -- that the function has no poison in its body. If it does,
200 -- anywhere, then the whole function is poisonous.
203 = case widened_body of
204 AbsApproxFun ds val -> AbsApproxFun (d : ds) val
206 d = findRecDemand str_fn abs_fn bndr_ty
207 abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn
208 (val : [AbsTop | d <- ds])))
210 other -> AbsApproxFun [d] widened_body
212 d = findRecDemand str_fn abs_fn bndr_ty
213 abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
215 widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
216 str_fn val = True -- Always says non-termination;
217 -- that'll make findRecDemand peer into the
218 -- structure of the value.
220 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
222 -- It's desirable to do a good job of widening for product
226 -- in ...(case p of (x,y) -> x)...
228 -- Now, is y absent in this expression? Currently the
229 -- analyser widens p before looking at p's scope, to avoid
230 -- lots of recomputation in the case where p is a function.
231 -- So if widening doesn't have a case for products, we'll
232 -- widen p to AbsBot (since when searching for absence in y we
233 -- bind y to poison ie AbsBot), and now we are lost.
235 widen AbsAnal other_val = other_val
237 -- WAS: if anyBot val then AbsBot else AbsTop
238 -- Nowadays widen is doing a better job on functions for absence analysis.
241 @crudeAbsWiden@ is used just for absence analysis, and always
242 returns AbsTop or AbsBot, so it widens to a two-point domain
245 crudeAbsWiden :: AbsVal -> AbsVal
246 crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
249 @sameVal@ compares two abstract values for equality. It can't deal with
250 @AbsFun@, but that should have been removed earlier in the day by @widen@.
253 sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
256 sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
257 sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
260 sameVal AbsBot AbsBot = True
261 sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot
263 sameVal AbsTop AbsTop = True
264 sameVal AbsTop other = False -- Right?
266 sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
267 sameVal (AbsProd _) AbsTop = False
268 sameVal (AbsProd _) AbsBot = False
270 sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
271 sameVal (AbsApproxFun _ _) AbsTop = False
272 sameVal (AbsApproxFun _ _) AbsBot = False
274 sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
278 @evalStrictness@ compares a @Demand@ with an abstract value, returning
279 @True@ iff the abstract value is {\em less defined} than the demand.
280 (@True@ is the exciting answer; @False@ is always safe.)
283 evalStrictness :: Demand
285 -> Bool -- True iff the value is sure
286 -- to be less defined than the Demand
288 evalStrictness (WwLazy _) _ = False
289 evalStrictness WwStrict val = isBot val
290 evalStrictness WwEnum val = isBot val
292 evalStrictness (WwUnpack _ demand_info) val
297 | length vals /= length demand_info -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
299 | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
301 _ -> pprTrace "evalStrictness?" empty False
303 evalStrictness WwPrim val
306 AbsBot -> True -- Can happen: consider f (g x), where g is a
307 -- recursive function returning an Int# that diverges
309 other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
312 For absence analysis, we're interested in whether "poison" in the
313 argument (ie a bottom therein) can propagate to the result of the
314 function call; that is, whether the specified demand can {\em
315 possibly} hit poison.
318 evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
319 -- with Absent demand
321 evalAbsence (WwUnpack _ demand_info) val
323 AbsTop -> False -- No poison in here
324 AbsBot -> True -- Pure poison
326 | length vals /= length demand_info -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
328 | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
329 _ -> pprTrace "TELL SIMON: evalAbsence"
330 (ppr demand_info $$ ppr val)
333 evalAbsence other val = anyBot val
334 -- The demand is conservative; even "Lazy" *might* evaluate the
335 -- argument arbitrarily so we have to look everywhere for poison
338 %************************************************************************
340 \subsection[absEval]{Evaluate an expression in the abstract domain}
342 %************************************************************************
345 -- The isBottomingId stuf is now dealt with via the Id's strictness info
346 -- absId anal var env | isBottomingId var
348 -- StrAnal -> AbsBot -- See discussion below
349 -- AbsAnal -> AbsTop -- Just want to see if there's any poison in
353 = case (lookupAbsValEnv env var,
354 isDataConId_maybe var,
356 maybeUnfoldingTemplate (idUnfolding var)) of
358 (Just abs_val, _, _, _) ->
359 abs_val -- Bound in the environment
361 (_, Just data_con, _, _) | isProductTyCon tycon &&
362 not (isRecursiveTyCon tycon)
363 -> -- A product. We get infinite loops if we don't
364 -- check for recursive products!
365 -- The strictness info on the constructor
366 -- isn't expressive enough to contain its abstract value
367 productAbsVal (dataConRepArgTys data_con) []
369 tycon = dataConTyCon data_con
371 (_, _, NoStrictnessInfo, Just unfolding) ->
372 -- We have an unfolding for the expr
373 -- Assume the unfolding has no free variables since it
374 -- came from inside the Id
375 absEval anal unfolding env
376 -- Notice here that we only look in the unfolding if we don't
377 -- have strictness info (an unusual situation).
378 -- We could have chosen to look in the unfolding if it exists,
379 -- and only try the strictness info if it doesn't, and that would
380 -- give more accurate results, at the cost of re-abstract-interpreting
381 -- the unfolding every time.
382 -- We found only one place where the look-at-unfolding-first
383 -- method gave better results, which is in the definition of
384 -- showInt in the Prelude. In its defintion, fromIntegral is
385 -- not inlined (it's big) but ab-interp-ing its unfolding gave
386 -- a better result than looking at its strictness only.
387 -- showInt :: Integral a => a -> [Char] -> [Char]
388 -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
389 -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
391 -- showInt :: Integral a => a -> [Char] -> [Char]
392 -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
393 -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
396 (_, _, strictness_info, _) ->
397 -- Includes NoUnfolding
398 -- Try the strictness info
399 absValFromStrictness anal strictness_info
401 productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args)
402 productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
406 absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
408 absEval anal (Type ty) env = AbsTop
409 absEval anal (Var var) env = absId anal var env
412 Discussion about error (following/quoting Lennart): Any expression
413 'error e' is regarded as bottom (with HBC, with the -ffail-strict
416 Regarding it as bottom gives much better strictness properties for
420 f (x:xs) y = f xs (x+y)
422 f [] _ = error "no match"
424 f (x:xs) y = f xs (x+y)
426 is strict in y, which you really want. But, it may lead to
427 transformations that turn a call to \tr{error} into non-termination.
428 (The odds of this happening aren't good.)
430 Things are a little different for absence analysis, because we want
431 to make sure that any poison (?????)
434 absEval anal (Lit _) env = AbsTop
435 -- Literals terminate (strictness) and are not poison (absence)
439 absEval anal (Lam bndr body) env
440 | isTyVar bndr = absEval anal body env -- Type lambda
441 | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda
443 abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
445 absEval anal (App expr (Type ty)) env
446 = absEval anal expr env -- Type appplication
447 absEval anal (App f val_arg) env
448 = absApply anal (absEval anal f env) -- Value applicationn
449 (absEval anal val_arg env)
453 absEval anal expr@(Case scrut case_bndr alts) env
455 scrut_val = absEval anal scrut env
456 alts_env = addOneToAbsValEnv env case_bndr scrut_val
458 case (scrut_val, alts) of
459 (AbsBot, _) -> AbsBot
461 (AbsProd arg_vals, [(con, bndrs, rhs)])
463 -- The scrutinee is a product value, so it must be of a single-constr
464 -- type; so the constructor in this alternative must be the right one
465 -- so we can go ahead and bind the constructor args to the components
466 -- of the product value.
467 ASSERT(length arg_vals == length val_bndrs)
468 absEval anal rhs rhs_env
470 val_bndrs = filter isId bndrs
471 rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
473 other -> absEvalAlts anal alts alts_env
476 For @Lets@ we widen the value we get. This is nothing to
477 do with fixpointing. The reason is so that we don't get an explosion
478 in the amount of computation. For example, consider:
490 If we bind @f@ and @g@ to their exact abstract value, then we'll
491 ``execute'' one call to @f@ and {\em two} calls to @g@. This can blow
492 up exponentially. Widening cuts it off by making a fixed
493 approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
494 not evaluated again at all when they are called.
496 Of course, this can lose useful joint strictness, which is sad. An
497 alternative approach would be to try with a certain amount of ``fuel''
498 and be prepared to bale out.
501 absEval anal (Let (NonRec binder e1) e2) env
503 new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
505 -- The binder of a NonRec should *not* be of unboxed type,
506 -- hence no need to strictly evaluate the Rhs.
507 absEval anal e2 new_env
509 absEval anal (Let (Rec pairs) body) env
511 (binders,rhss) = unzip pairs
512 rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values
513 new_env = growAbsValEnvList env (binders `zip` rhs_vals)
515 absEval anal body new_env
517 absEval anal (Note (Coerce _ _) expr) env = AbsTop
518 -- Don't look inside coerces, becuase they
519 -- are usually recursive newtypes
520 -- (Could improve, for the error case, but we're about
521 -- to kill this analyser anyway.)
522 absEval anal (Note note expr) env = absEval anal expr env
526 absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
527 absEvalAlts anal alts env
528 = combine anal (map go alts)
530 combine StrAnal = foldr1 lub -- Diverge only if all diverge
531 combine AbsAnal = foldr1 glb -- Find any poison
534 = absEval anal rhs rhs_env
536 rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
539 %************************************************************************
541 \subsection[absApply]{Apply an abstract function to an abstract argument}
543 %************************************************************************
548 absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
550 absApply anal AbsBot arg = AbsBot
551 -- AbsBot represents the abstract bottom *function* too
553 absApply StrAnal AbsTop arg = AbsTop
554 absApply AbsAnal AbsTop arg = if anyBot arg
557 -- To be conservative, we have to assume that a function about
558 -- which we know nothing (AbsTop) might look at some part of
562 An @AbsFun@ with only one more argument needed---bind it and eval the
563 result. A @Lam@ with two or more args: return another @AbsFun@ with
564 an augmented environment.
567 absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
571 absApply StrAnal (AbsApproxFun (d:ds) val) arg
574 other -> AbsApproxFun ds val' -- Result is non-bot if there are still args
576 val' | evalStrictness d arg = AbsBot
579 absApply AbsAnal (AbsApproxFun (d:ds) val) arg
580 = if evalAbsence d arg
581 then AbsBot -- Poison in arg means poison in the application
584 other -> AbsApproxFun ds val
587 absApply anal f@(AbsProd _) arg
588 = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
595 %************************************************************************
597 \subsection[findStrictness]{Determine some binders' strictness}
599 %************************************************************************
603 -> AbsVal -- Abstract strictness value of function
604 -> AbsVal -- Abstract absence value of function
605 -> StrictnessInfo -- Resulting strictness annotation
607 findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
608 -- You might think there's really no point in describing detailed
609 -- strictness for a divergent function;
610 -- If it's fully applied we get bottom regardless of the
611 -- argument. If it's not fully applied we don't get bottom.
612 -- Finally, we don't want to regard the args of a divergent function
613 -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
615 -- HOWEVER, if we make diverging functions appear lazy, they
616 -- don't get wrappers, and then we get dreadful reboxing.
617 -- See notes with WwLib.worthSplitting
618 = find_strictness id str_ds str_res abs_ds
620 findStrictness id str_val abs_val
621 | isBot str_val = mkStrictnessInfo ([], True)
622 | otherwise = NoStrictnessInfo
624 -- The list of absence demands passed to combineDemands
625 -- can be shorter than the list of absence demands
627 -- lookup = \ dEq -> letrec {
628 -- lookup = \ key ds -> ...lookup...
631 -- Here the strictness value takes three args, but the absence value
632 -- takes only one, for reasons I don't quite understand (see cheapFixpoint)
634 find_strictness id orig_str_ds orig_str_res orig_abs_ds
635 = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
637 res_bot = isBot orig_str_res
639 go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
641 mk_dmd str_dmd (WwLazy True)
642 = WARN( not (res_bot || isLazy str_dmd),
643 ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
644 -- If the arg isn't used we jolly well don't expect the function
645 -- to be strict in it. Unless the function diverges.
646 WwLazy True -- Best of all
648 mk_dmd (WwUnpack u str_ds)
649 (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
651 mk_dmd str_dmd abs_dmd = str_dmd
656 findDemand dmd str_env abs_env expr binder
657 = findRecDemand str_fn abs_fn (idType binder)
659 str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
660 abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
662 findDemandAlts dmd str_env abs_env alts binder
663 = findRecDemand str_fn abs_fn (idType binder)
665 str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
666 abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
669 @findRecDemand@ is where we finally convert strictness/absence info
670 into ``Demands'' which we can pin on Ids (etc.).
672 NOTE: What do we do if something is {\em both} strict and absent?
673 Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
674 strict (because of bottoming effect of \tr{error}) or all absent
675 (because they're not used)?
677 Well, for practical reasons, we prefer absence over strictness. In
678 particular, it makes the ``default defaults'' for class methods (the
679 ones that say \tr{defm.foo dict = error "I don't exist"}) come out
680 nicely [saying ``the dict isn't used''], rather than saying it is
681 strict in every component of the dictionary [massive gratuitious
682 casing to take the dict apart].
684 But you could have examples where going for strictness would be better
685 than absence. Consider:
687 let x = something big
692 If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
693 lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict,
694 then we'd let-to-case it:
696 case something big of
702 findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot
703 -> (AbsVal -> Bool) -- True => function applied to this value yields no poison
704 -> Type -- The type of the argument
707 findRecDemand str_fn abs_fn ty
708 = if isUnLiftedType ty then -- It's a primitive type!
711 else if abs_fn AbsBot then -- It's absent
712 -- We prefer absence over strictness: see NOTE above.
715 else if not (opt_AllStrict ||
716 (opt_NumbersStrict && is_numeric_type ty) ||
718 WwLazy False -- It's not strict and we're not pretending
720 else -- It's strict (or we're pretending it is)!
722 case splitProductType_maybe ty of
724 Nothing -> wwStrict -- Could have a test for wwEnum, but
725 -- we don't exploit it yet, so don't bother
727 Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
728 | isRecursiveTyCon tycon -- Recursive data type; don't unpack
729 -> wwStrict -- (this applies to newtypes too:
730 -- e.g. data Void = MkVoid Void)
732 | null compt_strict_infos -- A nullary data type
735 | otherwise -- Some other data type
736 -> wwUnpack compt_strict_infos
739 prod_len = length cmpnt_tys
743 str_fn (mkMainlyTopProd prod_len i cmpnt_val)
746 abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
749 | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
753 = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
755 Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
757 is_elem = isIn "is_numeric_type"
759 -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
760 -- them) except for a given value in the "i"th position.
762 mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
764 mkMainlyTopProd n i val
766 befores = nOfThem (i-1) AbsTop
767 afters = nOfThem (n-i) AbsTop
769 AbsProd (befores ++ (val : afters))
772 %************************************************************************
774 \subsection[fixpoint]{Fixpointer for the strictness analyser}
776 %************************************************************************
778 The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
779 environment, and returns the abstract value of each binder.
781 The @cheapFixpoint@ function makes a conservative approximation,
782 by binding each of the variables to Top in their own right hand sides.
783 That allows us to make rapid progress, at the cost of a less-than-wonderful
787 cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
789 cheapFixpoint AbsAnal [id] [rhs] env
790 = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
792 new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point!
793 -- In the just-one-binding case, we guarantee to
794 -- find a fixed point in just one iteration,
795 -- because we are using only a two-point domain.
796 -- This improves matters in cases like:
798 -- f x y = letrec g = ...g...
801 -- Here, y isn't used at all, but if g is bound to
802 -- AbsBot we simply get AbsBot as the next
805 cheapFixpoint anal ids rhss env
806 = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
807 -- We do just one iteration, starting from a safe
808 -- approximation. This won't do a good job in situations
810 -- \x -> letrec f = ...g...
814 -- Here, f will end up bound to Top after one iteration,
815 -- and hence we won't spot the strictness in x.
816 -- (A second iteration would solve this. ToDo: try the effect of
817 -- really searching for a fixed point.)
819 new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
822 = case anal of -- The safe starting point
828 fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
830 fixpoint anal [] _ env = []
832 fixpoint anal ids rhss env
833 = fix_loop initial_vals
836 = case anal of -- The (unsafe) starting point
839 -- At one stage for StrAnal we said:
840 -- if (returnsRealWorld (idType id))
841 -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
842 -- but no one has the foggiest idea what this hack did,
843 -- and returnsRealWorld was a stub that always returned False
844 -- So this comment is all that is left of the hack!
846 initial_vals = [ initial_val id | id <- ids ]
848 fix_loop :: [AbsVal] -> [AbsVal]
850 fix_loop current_widened_vals
852 new_env = growAbsValEnvList env (ids `zip` current_widened_vals)
853 new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
854 new_widened_vals = map (widen anal) new_vals
856 if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
859 -- NB: I was too chicken to make that a zipWithEqual,
860 -- lest I jump into a black hole. WDP 96/02
862 -- Return the widened values. We might get a slightly
863 -- better value by returning new_vals (which we used to
864 -- do, see below), but alas that means that whenever the
865 -- function is called we have to re-execute it, which is
870 -- Return the un-widened values which may be a bit better
871 -- than the widened ones, and are guaranteed safe, since
872 -- they are one iteration beyond current_widened_vals,
873 -- which itself is a fixed point.
875 fix_loop new_widened_vals
878 For absence analysis, we make do with a very very simple approach:
879 look for convergence in a two-point domain.
881 We used to use just one iteration, starting with the variables bound
882 to @AbsBot@, which is safe.
884 Prior to that, we used one iteration starting from @AbsTop@ (which
885 isn't safe). Why isn't @AbsTop@ safe? Consider:
893 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
894 point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is
895 safe because it gives poison more often than really necessary, and
896 thus may miss some absence, but will never claim absence when it ain't
899 Anyway, one iteration starting with everything bound to @AbsBot@ give
904 Here, f would always end up bound to @AbsBot@, which ain't very
905 clever, because then it would introduce poison whenever it was
906 applied. Much better to start with f bound to @AbsTop@, and widen it
907 to @AbsBot@ if any poison shows up. In effect we look for convergence
908 in the two-point @AbsTop@/@AbsBot@ domain.
910 What we miss (compared with the cleverer strictness analysis) is
911 spotting that in this case
913 f = \ x y -> ...y...(f x y')...
915 \tr{x} is actually absent, since it is only passed round the loop, never
916 used. But who cares about missing that?
918 NB: despite only having a two-point domain, we may still have many
919 iterations, because there are several variables involved at once.