--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section[SaAbsInt]{Abstract interpreter for strictness analysis}
+
+\begin{code}
+#ifndef OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports
+module SaAbsInt () where
+
+#else
+module SaAbsInt (
+ findStrictness,
+ findDemand, findDemandAlts,
+ absEval,
+ widen,
+ fixpoint,
+ isBot
+ ) where
+
+#include "HsVersions.h"
+
+import StaticFlags ( opt_AllStrict, opt_NumbersStrict )
+import CoreSyn
+import CoreUnfold ( maybeUnfoldingTemplate )
+import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
+ idStrictness,
+ )
+import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
+import IdInfo ( StrictnessInfo(..) )
+import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
+ mkStrictnessInfo, isLazy
+ )
+import SaLib
+import TyCon ( isProductTyCon, isRecursiveTyCon )
+import Type ( splitTyConApp_maybe,
+ isUnLiftedType, Type )
+import TyCon ( tyConUnique )
+import PrelInfo ( numericTyKeys )
+import Util ( isIn, nOfThem, zipWithEqual, equalLength )
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[AbsVal-ops]{Operations on @AbsVals@}
+%* *
+%************************************************************************
+
+Least upper bound, greatest lower bound.
+
+\begin{code}
+lub, glb :: AbsVal -> AbsVal -> AbsVal
+
+lub AbsBot val2 = val2
+lub val1 AbsBot = val1
+
+lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
+
+lub _ _ = AbsTop -- Crude, but conservative
+ -- The crudity only shows up if there
+ -- are functions involved
+
+-- Slightly funny glb; for absence analysis only;
+-- AbsBot is the safe answer.
+--
+-- Using anyBot rather than just testing for AbsBot is important.
+-- Consider:
+--
+-- f = \a b -> ...
+--
+-- g = \x y z -> case x of
+-- [] -> f x
+-- (p:ps) -> f p
+--
+-- Now, the abstract value of the branches of the case will be an
+-- AbsFun, but when testing for z's absence we want to spot that it's
+-- an AbsFun which can't possibly return AbsBot. So when glb'ing we
+-- mustn't be too keen to bale out and return AbsBot; the anyBot test
+-- spots that (f x) can't possibly return AbsBot.
+
+-- We have also tripped over the following interesting case:
+-- case x of
+-- [] -> \y -> 1
+-- (p:ps) -> f
+--
+-- Now, suppose f is bound to AbsTop. Does this expression mention z?
+-- Obviously not. But the case will take the glb of AbsTop (for f) and
+-- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
+-- that would say that it *does* mention z (or anything else for that matter).
+-- Nor can we always return AbsTop, because the AbsFun might be something
+-- like (\y->z), which obviously does mention z. The point is that we're
+-- glbing two functions, and AbsTop is not actually the top of the function
+-- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns
+-- poison iff any of its arguments do.
+
+-- Deal with functions specially, because AbsTop isn't the
+-- top of their domain.
+
+glb v1 v2
+ | is_fun v1 || is_fun v2
+ = if not (anyBot v1) && not (anyBot v2)
+ then
+ AbsTop
+ else
+ AbsBot
+ where
+ is_fun (AbsFun _ _) = True
+ is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok
+ is_fun other = False
+
+-- The non-functional cases are quite straightforward
+
+glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
+
+glb AbsTop v2 = v2
+glb v1 AbsTop = v1
+
+glb _ _ = AbsBot -- Be pessimistic
+\end{code}
+
+@isBot@ returns True if its argument is (a representation of) bottom. The
+``representation'' part is because we need to detect the bottom {\em function}
+too. To detect the bottom function, bind its args to top, and see if it
+returns bottom.
+
+Used only in strictness analysis:
+\begin{code}
+isBot :: AbsVal -> Bool
+
+isBot AbsBot = True
+isBot other = False -- Functions aren't bottom any more
+\end{code}
+
+Used only in absence analysis:
+
+\begin{code}
+anyBot :: AbsVal -> Bool
+
+anyBot AbsBot = True -- poisoned!
+anyBot AbsTop = False
+anyBot (AbsProd vals) = any anyBot vals
+anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop)
+anyBot (AbsApproxFun _ val) = anyBot val
+\end{code}
+
+@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
+approximated by $val$. Furthermore, the result has no @AbsFun@s in
+it, so it can be compared for equality by @sameVal@.
+
+\begin{code}
+widen :: AnalysisKind -> AbsVal -> AbsVal
+
+-- Widening is complicated by the fact that funtions are lifted
+widen StrAnal the_fn@(AbsFun bndr_ty _)
+ = case widened_body of
+ AbsApproxFun ds val -> AbsApproxFun (d : ds) val
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ str_fn val = isBot (foldl (absApply StrAnal) the_fn
+ (val : [AbsTop | d <- ds]))
+
+ other -> AbsApproxFun [d] widened_body
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ str_fn val = isBot (absApply StrAnal the_fn val)
+ where
+ widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop)
+ abs_fn val = False -- Always says poison; so it looks as if
+ -- nothing is absent; safe
+
+{- OLD comment...
+ This stuff is now instead handled neatly by the fact that AbsApproxFun
+ contains an AbsVal inside it. SLPJ Jan 97
+
+ | isBot abs_body = AbsBot
+ -- It's worth checking for a function which is unconditionally
+ -- bottom. Consider
+ --
+ -- f x y = let g y = case x of ...
+ -- in (g ..) + (g ..)
+ --
+ -- Here, when we are considering strictness of f in x, we'll
+ -- evaluate the body of f with x bound to bottom. The current
+ -- strategy is to bind g to its *widened* value; without the isBot
+ -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
+ -- Top, not Bot as the value of f's rhs. The test spots the
+ -- unconditional bottom-ness of g when x is bottom. (Another
+ -- alternative here would be to bind g to its exact abstract
+ -- value, but that entails lots of potential re-computation, at
+ -- every application of g.)
+-}
+
+widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
+widen StrAnal other_val = other_val
+
+
+widen AbsAnal the_fn@(AbsFun bndr_ty _)
+ | anyBot widened_body = AbsBot
+ -- In the absence-analysis case it's *essential* to check
+ -- that the function has no poison in its body. If it does,
+ -- anywhere, then the whole function is poisonous.
+
+ | otherwise
+ = case widened_body of
+ AbsApproxFun ds val -> AbsApproxFun (d : ds) val
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn
+ (val : [AbsTop | d <- ds])))
+
+ other -> AbsApproxFun [d] widened_body
+ where
+ d = findRecDemand str_fn abs_fn bndr_ty
+ abs_fn val = not (anyBot (absApply AbsAnal the_fn val))
+ where
+ widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop)
+ str_fn val = True -- Always says non-termination;
+ -- that'll make findRecDemand peer into the
+ -- structure of the value.
+
+widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
+
+ -- It's desirable to do a good job of widening for product
+ -- values. Consider
+ --
+ -- let p = (x,y)
+ -- in ...(case p of (x,y) -> x)...
+ --
+ -- Now, is y absent in this expression? Currently the
+ -- analyser widens p before looking at p's scope, to avoid
+ -- lots of recomputation in the case where p is a function.
+ -- So if widening doesn't have a case for products, we'll
+ -- widen p to AbsBot (since when searching for absence in y we
+ -- bind y to poison ie AbsBot), and now we are lost.
+
+widen AbsAnal other_val = other_val
+
+-- WAS: if anyBot val then AbsBot else AbsTop
+-- Nowadays widen is doing a better job on functions for absence analysis.
+\end{code}
+
+@crudeAbsWiden@ is used just for absence analysis, and always
+returns AbsTop or AbsBot, so it widens to a two-point domain
+
+\begin{code}
+crudeAbsWiden :: AbsVal -> AbsVal
+crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
+\end{code}
+
+@sameVal@ compares two abstract values for equality. It can't deal with
+@AbsFun@, but that should have been removed earlier in the day by @widen@.
+
+\begin{code}
+sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
+
+#ifdef DEBUG
+sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
+sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
+#endif
+
+sameVal AbsBot AbsBot = True
+sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot
+
+sameVal AbsTop AbsTop = True
+sameVal AbsTop other = False -- Right?
+
+sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
+sameVal (AbsProd _) AbsTop = False
+sameVal (AbsProd _) AbsBot = False
+
+sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2
+sameVal (AbsApproxFun _ _) AbsTop = False
+sameVal (AbsApproxFun _ _) AbsBot = False
+
+sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
+\end{code}
+
+
+@evalStrictness@ compares a @Demand@ with an abstract value, returning
+@True@ iff the abstract value is {\em less defined} than the demand.
+(@True@ is the exciting answer; @False@ is always safe.)
+
+\begin{code}
+evalStrictness :: Demand
+ -> AbsVal
+ -> Bool -- True iff the value is sure
+ -- to be less defined than the Demand
+
+evalStrictness (WwLazy _) _ = False
+evalStrictness WwStrict val = isBot val
+evalStrictness WwEnum val = isBot val
+
+evalStrictness (WwUnpack _ demand_info) val
+ = case val of
+ AbsTop -> False
+ AbsBot -> True
+ AbsProd vals
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
+ False
+ | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
+
+ _ -> pprTrace "evalStrictness?" empty False
+
+evalStrictness WwPrim val
+ = case val of
+ AbsTop -> False
+ AbsBot -> True -- Can happen: consider f (g x), where g is a
+ -- recursive function returning an Int# that diverges
+
+ other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
+\end{code}
+
+For absence analysis, we're interested in whether "poison" in the
+argument (ie a bottom therein) can propagate to the result of the
+function call; that is, whether the specified demand can {\em
+possibly} hit poison.
+
+\begin{code}
+evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
+ -- with Absent demand
+
+evalAbsence (WwUnpack _ demand_info) val
+ = case val of
+ AbsTop -> False -- No poison in here
+ AbsBot -> True -- Pure poison
+ AbsProd vals
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
+ True
+ | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
+ _ -> pprTrace "TELL SIMON: evalAbsence"
+ (ppr demand_info $$ ppr val)
+ True
+
+evalAbsence other val = anyBot val
+ -- The demand is conservative; even "Lazy" *might* evaluate the
+ -- argument arbitrarily so we have to look everywhere for poison
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[absEval]{Evaluate an expression in the abstract domain}
+%* *
+%************************************************************************
+
+\begin{code}
+-- The isBottomingId stuf is now dealt with via the Id's strictness info
+-- absId anal var env | isBottomingId var
+-- = case anal of
+-- StrAnal -> AbsBot -- See discussion below
+-- AbsAnal -> AbsTop -- Just want to see if there's any poison in
+ -- error's arg
+
+absId anal var env
+ = case (lookupAbsValEnv env var,
+ isDataConWorkId_maybe var,
+ idStrictness var,
+ maybeUnfoldingTemplate (idUnfolding var)) of
+
+ (Just abs_val, _, _, _) ->
+ abs_val -- Bound in the environment
+
+ (_, Just data_con, _, _) | isProductTyCon tycon &&
+ not (isRecursiveTyCon tycon)
+ -> -- A product. We get infinite loops if we don't
+ -- check for recursive products!
+ -- The strictness info on the constructor
+ -- isn't expressive enough to contain its abstract value
+ productAbsVal (dataConRepArgTys data_con) []
+ where
+ tycon = dataConTyCon data_con
+
+ (_, _, NoStrictnessInfo, Just unfolding) ->
+ -- We have an unfolding for the expr
+ -- Assume the unfolding has no free variables since it
+ -- came from inside the Id
+ absEval anal unfolding env
+ -- Notice here that we only look in the unfolding if we don't
+ -- have strictness info (an unusual situation).
+ -- We could have chosen to look in the unfolding if it exists,
+ -- and only try the strictness info if it doesn't, and that would
+ -- give more accurate results, at the cost of re-abstract-interpreting
+ -- the unfolding every time.
+ -- We found only one place where the look-at-unfolding-first
+ -- method gave better results, which is in the definition of
+ -- showInt in the Prelude. In its defintion, fromIntegral is
+ -- not inlined (it's big) but ab-interp-ing its unfolding gave
+ -- a better result than looking at its strictness only.
+ -- showInt :: Integral a => a -> [Char] -> [Char]
+ -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
+ -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
+ -- --- 42,44 ----
+ -- showInt :: Integral a => a -> [Char] -> [Char]
+ -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
+ -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
+
+
+ (_, _, strictness_info, _) ->
+ -- Includes NoUnfolding
+ -- Try the strictness info
+ absValFromStrictness anal strictness_info
+
+productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args)
+productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args))
+\end{code}
+
+\begin{code}
+absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
+
+absEval anal (Type ty) env = AbsTop
+absEval anal (Var var) env = absId anal var env
+\end{code}
+
+Discussion about error (following/quoting Lennart): Any expression
+'error e' is regarded as bottom (with HBC, with the -ffail-strict
+flag, on with -O).
+
+Regarding it as bottom gives much better strictness properties for
+some functions. E.g.
+
+ f [x] y = x+y
+ f (x:xs) y = f xs (x+y)
+i.e.
+ f [] _ = error "no match"
+ f [x] y = x+y
+ f (x:xs) y = f xs (x+y)
+
+is strict in y, which you really want. But, it may lead to
+transformations that turn a call to \tr{error} into non-termination.
+(The odds of this happening aren't good.)
+
+Things are a little different for absence analysis, because we want
+to make sure that any poison (?????)
+
+\begin{code}
+absEval anal (Lit _) env = AbsTop
+ -- Literals terminate (strictness) and are not poison (absence)
+\end{code}
+
+\begin{code}
+absEval anal (Lam bndr body) env
+ | isTyVar bndr = absEval anal body env -- Type lambda
+ | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda
+ where
+ abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg)
+
+absEval anal (App expr (Type ty)) env
+ = absEval anal expr env -- Type appplication
+absEval anal (App f val_arg) env
+ = absApply anal (absEval anal f env) -- Value applicationn
+ (absEval anal val_arg env)
+\end{code}
+
+\begin{code}
+absEval anal expr@(Case scrut case_bndr alts) env
+ = let
+ scrut_val = absEval anal scrut env
+ alts_env = addOneToAbsValEnv env case_bndr scrut_val
+ in
+ case (scrut_val, alts) of
+ (AbsBot, _) -> AbsBot
+
+ (AbsProd arg_vals, [(con, bndrs, rhs)])
+ | con /= DEFAULT ->
+ -- The scrutinee is a product value, so it must be of a single-constr
+ -- type; so the constructor in this alternative must be the right one
+ -- so we can go ahead and bind the constructor args to the components
+ -- of the product value.
+ ASSERT(equalLength arg_vals val_bndrs)
+ absEval anal rhs rhs_env
+ where
+ val_bndrs = filter isId bndrs
+ rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals)
+
+ other -> absEvalAlts anal alts alts_env
+\end{code}
+
+For @Lets@ we widen the value we get. This is nothing to
+do with fixpointing. The reason is so that we don't get an explosion
+in the amount of computation. For example, consider:
+\begin{verbatim}
+ let
+ g a = case a of
+ q1 -> ...
+ q2 -> ...
+ f x = case x of
+ p1 -> ...g r...
+ p2 -> ...g s...
+ in
+ f e
+\end{verbatim}
+If we bind @f@ and @g@ to their exact abstract value, then we'll
+``execute'' one call to @f@ and {\em two} calls to @g@. This can blow
+up exponentially. Widening cuts it off by making a fixed
+approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
+not evaluated again at all when they are called.
+
+Of course, this can lose useful joint strictness, which is sad. An
+alternative approach would be to try with a certain amount of ``fuel''
+and be prepared to bale out.
+
+\begin{code}
+absEval anal (Let (NonRec binder e1) e2) env
+ = let
+ new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
+ in
+ -- The binder of a NonRec should *not* be of unboxed type,
+ -- hence no need to strictly evaluate the Rhs.
+ absEval anal e2 new_env
+
+absEval anal (Let (Rec pairs) body) env
+ = let
+ (binders,rhss) = unzip pairs
+ rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values
+ new_env = growAbsValEnvList env (binders `zip` rhs_vals)
+ in
+ absEval anal body new_env
+
+absEval anal (Note (Coerce _ _) expr) env = AbsTop
+ -- Don't look inside coerces, becuase they
+ -- are usually recursive newtypes
+ -- (Could improve, for the error case, but we're about
+ -- to kill this analyser anyway.)
+absEval anal (Note note expr) env = absEval anal expr env
+\end{code}
+
+\begin{code}
+absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
+absEvalAlts anal alts env
+ = combine anal (map go alts)
+ where
+ combine StrAnal = foldr1 lub -- Diverge only if all diverge
+ combine AbsAnal = foldr1 glb -- Find any poison
+
+ go (con, bndrs, rhs)
+ = absEval anal rhs rhs_env
+ where
+ rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[absApply]{Apply an abstract function to an abstract argument}
+%* *
+%************************************************************************
+
+Easy ones first:
+
+\begin{code}
+absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
+
+absApply anal AbsBot arg = AbsBot
+ -- AbsBot represents the abstract bottom *function* too
+
+absApply StrAnal AbsTop arg = AbsTop
+absApply AbsAnal AbsTop arg = if anyBot arg
+ then AbsBot
+ else AbsTop
+ -- To be conservative, we have to assume that a function about
+ -- which we know nothing (AbsTop) might look at some part of
+ -- its argument
+\end{code}
+
+An @AbsFun@ with only one more argument needed---bind it and eval the
+result. A @Lam@ with two or more args: return another @AbsFun@ with
+an augmented environment.
+
+\begin{code}
+absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
+\end{code}
+
+\begin{code}
+absApply StrAnal (AbsApproxFun (d:ds) val) arg
+ = case ds of
+ [] -> val'
+ other -> AbsApproxFun ds val' -- Result is non-bot if there are still args
+ where
+ val' | evalStrictness d arg = AbsBot
+ | otherwise = val
+
+absApply AbsAnal (AbsApproxFun (d:ds) val) arg
+ = if evalAbsence d arg
+ then AbsBot -- Poison in arg means poison in the application
+ else case ds of
+ [] -> val
+ other -> AbsApproxFun ds val
+
+#ifdef DEBUG
+absApply anal f@(AbsProd _) arg
+ = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
+#endif
+\end{code}
+
+
+
+
+%************************************************************************
+%* *
+\subsection[findStrictness]{Determine some binders' strictness}
+%* *
+%************************************************************************
+
+\begin{code}
+findStrictness :: Id
+ -> AbsVal -- Abstract strictness value of function
+ -> AbsVal -- Abstract absence value of function
+ -> StrictnessInfo -- Resulting strictness annotation
+
+findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _)
+ -- You might think there's really no point in describing detailed
+ -- strictness for a divergent function;
+ -- If it's fully applied we get bottom regardless of the
+ -- argument. If it's not fully applied we don't get bottom.
+ -- Finally, we don't want to regard the args of a divergent function
+ -- as 'interesting' for inlining purposes (see Simplify.prepareArgs)
+ --
+ -- HOWEVER, if we make diverging functions appear lazy, they
+ -- don't get wrappers, and then we get dreadful reboxing.
+ -- See notes with WwLib.worthSplitting
+ = find_strictness id str_ds str_res abs_ds
+
+findStrictness id str_val abs_val
+ | isBot str_val = mkStrictnessInfo ([], True)
+ | otherwise = NoStrictnessInfo
+
+-- The list of absence demands passed to combineDemands
+-- can be shorter than the list of absence demands
+--
+-- lookup = \ dEq -> letrec {
+-- lookup = \ key ds -> ...lookup...
+-- }
+-- in lookup
+-- Here the strictness value takes three args, but the absence value
+-- takes only one, for reasons I don't quite understand (see cheapFixpoint)
+
+find_strictness id orig_str_ds orig_str_res orig_abs_ds
+ = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
+ where
+ res_bot = isBot orig_str_res
+
+ go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
+
+ mk_dmd str_dmd (WwLazy True)
+ = WARN( not (res_bot || isLazy str_dmd),
+ ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
+ -- If the arg isn't used we jolly well don't expect the function
+ -- to be strict in it. Unless the function diverges.
+ WwLazy True -- Best of all
+
+ mk_dmd (WwUnpack u str_ds)
+ (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
+
+ mk_dmd str_dmd abs_dmd = str_dmd
+\end{code}
+
+
+\begin{code}
+findDemand dmd str_env abs_env expr binder
+ = findRecDemand str_fn abs_fn (idType binder)
+ where
+ str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val))
+ abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)))
+
+findDemandAlts dmd str_env abs_env alts binder
+ = findRecDemand str_fn abs_fn (idType binder)
+ where
+ str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val))
+ abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val)))
+\end{code}
+
+@findRecDemand@ is where we finally convert strictness/absence info
+into ``Demands'' which we can pin on Ids (etc.).
+
+NOTE: What do we do if something is {\em both} strict and absent?
+Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
+strict (because of bottoming effect of \tr{error}) or all absent
+(because they're not used)?
+
+Well, for practical reasons, we prefer absence over strictness. In
+particular, it makes the ``default defaults'' for class methods (the
+ones that say \tr{defm.foo dict = error "I don't exist"}) come out
+nicely [saying ``the dict isn't used''], rather than saying it is
+strict in every component of the dictionary [massive gratuitious
+casing to take the dict apart].
+
+But you could have examples where going for strictness would be better
+than absence. Consider:
+\begin{verbatim}
+ let x = something big
+ in
+ f x y z + g x
+\end{verbatim}
+
+If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
+lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict,
+then we'd let-to-case it:
+\begin{verbatim}
+ case something big of
+ x -> f x y z + g x
+\end{verbatim}
+Ho hum.
+
+\begin{code}
+findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot
+ -> (AbsVal -> Bool) -- True => function applied to this value yields no poison
+ -> Type -- The type of the argument
+ -> Demand
+
+findRecDemand str_fn abs_fn ty
+ = if isUnLiftedType ty then -- It's a primitive type!
+ wwPrim
+
+ else if abs_fn AbsBot then -- It's absent
+ -- We prefer absence over strictness: see NOTE above.
+ WwLazy True
+
+ else if not (opt_AllStrict ||
+ (opt_NumbersStrict && is_numeric_type ty) ||
+ str_fn AbsBot) then
+ WwLazy False -- It's not strict and we're not pretending
+
+ else -- It's strict (or we're pretending it is)!
+
+ case splitProductType_maybe ty of
+
+ Nothing -> wwStrict -- Could have a test for wwEnum, but
+ -- we don't exploit it yet, so don't bother
+
+ Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case
+ | isRecursiveTyCon tycon -- Recursive data type; don't unpack
+ -> wwStrict -- (this applies to newtypes too:
+ -- e.g. data Void = MkVoid Void)
+
+ | null compt_strict_infos -- A nullary data type
+ -> wwStrict
+
+ | otherwise -- Some other data type
+ -> wwUnpack compt_strict_infos
+
+ where
+ prod_len = length cmpnt_tys
+ compt_strict_infos
+ = [ findRecDemand
+ (\ cmpnt_val ->
+ str_fn (mkMainlyTopProd prod_len i cmpnt_val)
+ )
+ (\ cmpnt_val ->
+ abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
+ )
+ cmpnt_ty
+ | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
+
+ where
+ is_numeric_type ty
+ = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
+ Nothing -> False
+ Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
+ where
+ is_elem = isIn "is_numeric_type"
+
+ -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
+ -- them) except for a given value in the "i"th position.
+
+ mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
+
+ mkMainlyTopProd n i val
+ = let
+ befores = nOfThem (i-1) AbsTop
+ afters = nOfThem (n-i) AbsTop
+ in
+ AbsProd (befores ++ (val : afters))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[fixpoint]{Fixpointer for the strictness analyser}
+%* *
+%************************************************************************
+
+The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
+environment, and returns the abstract value of each binder.
+
+The @cheapFixpoint@ function makes a conservative approximation,
+by binding each of the variables to Top in their own right hand sides.
+That allows us to make rapid progress, at the cost of a less-than-wonderful
+approximation.
+
+\begin{code}
+cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
+
+cheapFixpoint AbsAnal [id] [rhs] env
+ = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
+ where
+ new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point!
+ -- In the just-one-binding case, we guarantee to
+ -- find a fixed point in just one iteration,
+ -- because we are using only a two-point domain.
+ -- This improves matters in cases like:
+ --
+ -- f x y = letrec g = ...g...
+ -- in g x
+ --
+ -- Here, y isn't used at all, but if g is bound to
+ -- AbsBot we simply get AbsBot as the next
+ -- iteration too.
+
+cheapFixpoint anal ids rhss env
+ = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
+ -- We do just one iteration, starting from a safe
+ -- approximation. This won't do a good job in situations
+ -- like:
+ -- \x -> letrec f = ...g...
+ -- g = ...f...x...
+ -- in
+ -- ...f...
+ -- Here, f will end up bound to Top after one iteration,
+ -- and hence we won't spot the strictness in x.
+ -- (A second iteration would solve this. ToDo: try the effect of
+ -- really searching for a fixed point.)
+ where
+ new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
+
+ safe_val
+ = case anal of -- The safe starting point
+ StrAnal -> AbsTop
+ AbsAnal -> AbsBot
+\end{code}
+
+\begin{code}
+fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
+
+fixpoint anal [] _ env = []
+
+fixpoint anal ids rhss env
+ = fix_loop initial_vals
+ where
+ initial_val id
+ = case anal of -- The (unsafe) starting point
+ AbsAnal -> AbsTop
+ StrAnal -> AbsBot
+ -- At one stage for StrAnal we said:
+ -- if (returnsRealWorld (idType id))
+ -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
+ -- but no one has the foggiest idea what this hack did,
+ -- and returnsRealWorld was a stub that always returned False
+ -- So this comment is all that is left of the hack!
+
+ initial_vals = [ initial_val id | id <- ids ]
+
+ fix_loop :: [AbsVal] -> [AbsVal]
+
+ fix_loop current_widened_vals
+ = let
+ new_env = growAbsValEnvList env (ids `zip` current_widened_vals)
+ new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
+ new_widened_vals = map (widen anal) new_vals
+ in
+ if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
+ current_widened_vals
+
+ -- NB: I was too chicken to make that a zipWithEqual,
+ -- lest I jump into a black hole. WDP 96/02
+
+ -- Return the widened values. We might get a slightly
+ -- better value by returning new_vals (which we used to
+ -- do, see below), but alas that means that whenever the
+ -- function is called we have to re-execute it, which is
+ -- expensive.
+
+ -- OLD VERSION
+ -- new_vals
+ -- Return the un-widened values which may be a bit better
+ -- than the widened ones, and are guaranteed safe, since
+ -- they are one iteration beyond current_widened_vals,
+ -- which itself is a fixed point.
+ else
+ fix_loop new_widened_vals
+\end{code}
+
+For absence analysis, we make do with a very very simple approach:
+look for convergence in a two-point domain.
+
+We used to use just one iteration, starting with the variables bound
+to @AbsBot@, which is safe.
+
+Prior to that, we used one iteration starting from @AbsTop@ (which
+isn't safe). Why isn't @AbsTop@ safe? Consider:
+\begin{verbatim}
+ letrec
+ x = ...p..d...
+ d = (x,y)
+ in
+ ...
+\end{verbatim}
+Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
+point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is
+safe because it gives poison more often than really necessary, and
+thus may miss some absence, but will never claim absence when it ain't
+so.
+
+Anyway, one iteration starting with everything bound to @AbsBot@ give
+bad results for
+
+ f = \ x -> ...f...
+
+Here, f would always end up bound to @AbsBot@, which ain't very
+clever, because then it would introduce poison whenever it was
+applied. Much better to start with f bound to @AbsTop@, and widen it
+to @AbsBot@ if any poison shows up. In effect we look for convergence
+in the two-point @AbsTop@/@AbsBot@ domain.
+
+What we miss (compared with the cleverer strictness analysis) is
+spotting that in this case
+
+ f = \ x y -> ...y...(f x y')...
+
+\tr{x} is actually absent, since it is only passed round the loop, never
+used. But who cares about missing that?
+
+NB: despite only having a two-point domain, we may still have many
+iterations, because there are several variables involved at once.
+
+\begin{code}
+#endif /* OLD_STRICTNESS */
+\end{code}
projects / ghc-hetmet.git / blobdiff