%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
-#include "HsVersions.h"
+#ifndef OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports
+module SaAbsInt () where
+#else
module SaAbsInt (
findStrictness,
- findDemand,
+ findDemand, findDemandAlts,
absEval,
widen,
fixpoint,
isBot
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
+import StaticFlags ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), FormSummary )
-import CoreUtils ( unTagBinders )
-import Id ( idType, getIdStrictness, getIdUnfolding,
- dataConSig
- )
-import IdInfo ( StrictnessInfo(..), Demand(..),
- wwPrim, wwStrict, wwEnum, wwUnpack
+import CoreUnfold ( maybeUnfoldingTemplate )
+import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
+ idStrictness,
)
-import MagicUFs ( MagicUnfoldingFun )
-import Maybes ( maybeToBool )
-import Outputable ( Outputable(..){-instance * []-} )
-import PprStyle ( PprStyle(..) )
-import PrelInfo ( intTyCon, integerTyCon, doubleTyCon,
- floatTyCon, wordTyCon, addrTyCon
+import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
+import IdInfo ( StrictnessInfo(..) )
+import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
+ mkStrictnessInfo, isLazy
)
-import Pretty ( ppStr )
-import PrimOp ( PrimOp(..) )
import SaLib
-import TyCon ( maybeTyConSingleCon, isEnumerationTyCon,
- TyCon{-instance Eq-}
- )
-import Type ( maybeAppDataTyCon, isPrimType )
-import Util ( isIn, isn'tIn, nOfThem, zipWithEqual,
- pprTrace, panic, pprPanic, assertPanic
- )
-
-getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)"
-returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)"
+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}
%************************************************************************
\begin{code}
lub, glb :: AbsVal -> AbsVal -> AbsVal
-lub val1 val2 | isBot val1 = val2 -- The isBot test includes the case where
-lub val1 val2 | isBot val2 = val1 -- one of the val's is a function which
- -- always returns bottom, such as \y.x,
- -- when x is bound to bottom.
+lub AbsBot val2 = val2
+lub val1 AbsBot = val1
-lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual lub xs ys)
+lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys)
lub _ _ = AbsTop -- Crude, but conservative
-- The crudity only shows up if there
else
AbsBot
where
- is_fun (AbsFun _ _ _) = True
- is_fun (AbsApproxFun _) = True -- Not used, but the glb works ok
- is_fun other = False
+ 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 xs ys)
+glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys)
glb AbsTop v2 = v2
glb v1 AbsTop = v1
glb _ _ = AbsBot -- Be pessimistic
-
-
-
-combineCaseValues
- :: AnalysisKind
- -> AbsVal -- Value of scrutinee
- -> [AbsVal] -- Value of branches (at least one)
- -> AbsVal -- Result
-
--- For strictness analysis, see if the scrutinee is bottom; if so
--- return bottom; otherwise, the lub of the branches.
-
-combineCaseValues StrAnal AbsBot branches = AbsBot
-combineCaseValues StrAnal other_scrutinee branches
- -- Scrutinee can only be AbsBot, AbsProd or AbsTop
- = ASSERT(ok_scrutinee)
- foldr1 lub branches
- where
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., cool
- AbsProd _ -> True; -- ditto
- _ -> False -- party over
- }
-
--- For absence analysis, check if the scrutinee is all poison (isBot)
--- If so, return poison (AbsBot); otherwise, any nested poison will come
--- out from looking at the branches, so just glb together the branches
--- to get the worst one.
-
-combineCaseValues AbsAnal AbsBot branches = AbsBot
-combineCaseValues AbsAnal other_scrutinee branches
- -- Scrutinee can only be AbsBot, AbsProd or AbsTop
- = ASSERT(ok_scrutinee)
- let
- result = foldr1 glb branches
-
- tracer = if at_least_one_AbsFun && at_least_one_AbsTop
- && no_AbsBots then
- pprTrace "combineCase:" (ppr PprDebug branches)
- else
- id
- in
--- tracer (
- result
--- )
- where
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., cool
- AbsProd _ -> True; -- ditto
- _ -> False -- party over
- }
-
- at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches
- at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches
- no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches
-
- is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False }
- is_AbsTop x = case x of { AbsTop -> True; _ -> False }
- is_not_AbsBot x = case x of { AbsBot -> False; _ -> True }
\end{code}
@isBot@ returns True if its argument is (a representation of) bottom. The
\begin{code}
isBot :: AbsVal -> Bool
-isBot AbsBot = True
-isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
- -- Don't bother to extend the envt because
- -- unbound variables default to AbsTop anyway
-isBot other = False
+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 args body env) = anyBot (absEval AbsAnal body env)
-anyBot (AbsApproxFun demands) = False
-
- -- AbsApproxFun can only arise in absence analysis from the Demand
- -- info of an imported value; whatever it is we're looking for is
- -- certainly not present over in the imported value.
+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
\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal
-widen StrAnal (AbsFun args body env)
- | isBot (absEval StrAnal body env) = AbsBot
- | otherwise
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandStrOnly env body) args)
+-- 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
--
-- 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 (AbsFun args body env)
- | anyBot (absEval AbsAnal body env) = AbsBot
+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
- = ASSERT (not (null args))
- AbsApproxFun (map (findDemandAbsOnly env body) args)
+ = 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)
sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun!
#ifdef DEBUG
-sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1"
-sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2"
+sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1"
+sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2"
#endif
sameVal AbsBot AbsBot = True
sameVal AbsTop AbsTop = True
sameVal AbsTop other = False -- Right?
-sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual sameVal vals1 vals2)
+sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2)
sameVal (AbsProd _) AbsTop = False
sameVal (AbsProd _) AbsBot = False
-sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2
-sameVal (AbsApproxFun _) AbsTop = False
-sameVal (AbsApproxFun _) 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 WwStrict val = isBot val
evalStrictness WwEnum val = isBot val
-evalStrictness (WwUnpack demand_info) val
+evalStrictness (WwUnpack _ demand_info) val
= case val of
AbsTop -> False
AbsBot -> True
- AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals)
- _ -> trace "evalStrictness?" False
+ 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 -> -- A primitive value should be defined, never bottom;
- -- hence this paranoia check
- pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other)
+ other -> pprPanic "evalStrictness: WwPrim:" (ppr other)
\end{code}
For absence analysis, we're interested in whether "poison" in the
evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
-- with Absent demand
-evalAbsence (WwUnpack demand_info) val
+evalAbsence (WwUnpack _ demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
- AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals)
- _ -> panic "evalAbsence: other"
+ 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
-- error's arg
absId anal var env
- = let
- result =
- case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
+ = case (lookupAbsValEnv env var,
+ isDataConWorkId_maybe var,
+ idStrictness var,
+ maybeUnfoldingTemplate (idUnfolding var)) of
- (Just abs_val, _, _) ->
+ (Just abs_val, _, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, LitForm _) ->
- AbsTop -- Literals all terminate, and have no poison
-
- (Nothing, NoStrictnessInfo, ConForm _ _) ->
- AbsTop -- An imported constructor won't have
- -- bottom components, nor poison!
-
- (Nothing, NoStrictnessInfo, GenForm _ _ unfolding _) ->
+ (_, 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 (unTagBinders unfolding) env
+ 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,
-- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
- (Nothing, strictness_info, _) ->
- -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
+ (_, _, strictness_info, _) ->
+ -- Includes NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
-
- -- Done via strictness now
- -- GenForm _ BottomForm _ _ -> AbsBot
- in
- -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
- result
- -- )
- where
- pp_anal StrAnal = ppStr "STR"
- pp_anal AbsAnal = ppStr "ABS"
-
-absEvalAtom anal (VarArg v) env = absId anal v env
-absEvalAtom anal (LitArg _) env = AbsTop
+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
-
-absEval anal (Lit _) env = AbsTop
- -- What if an unboxed literal? That's OK: it terminates, so its
- -- abstract value is AbsTop.
-
- -- For absence analysis, a literal certainly isn't the "poison" variable
\end{code}
-Discussion about \tr{error} (following/quoting Lennart): Any expression
-\tr{error e} is regarded as bottom (with HBC, with the
-\tr{-ffail-strict} flag, on with \tr{-O}).
+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.
-\begin{verbatim}
+
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)
-\end{verbatim}
-is strict in \tr{y}, which you really want. But, it may lead to
+
+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 StrAnal (Prim SeqOp [TyArg _, e]) env
- = ASSERT(isValArg e)
- if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
- -- This is a special case to ensure that seq# is strict in its argument.
- -- The comments below (for most normal PrimOps) do not apply.
-
-absEval StrAnal (Prim op es) env = AbsTop
- -- The arguments are all of unboxed type, so they will already
- -- have been eval'd. If the boxed version was bottom, we'll
- -- already have returned bottom.
-
- -- Actually, I believe we are saying that either (1) the
- -- primOp uses unboxed args and they've been eval'ed, so
- -- there's no need to force strictness here, _or_ the primOp
- -- uses boxed args and we don't know whether or not it's
- -- strict, so we assume laziness. (JSM)
-
-absEval AbsAnal (Prim op as) env
- = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
- then AbsBot
- else AbsTop
- -- For absence analysis, we want to see if the poison shows up...
-
-absEval anal (Con con as) env
- | has_single_con
- = AbsProd [absEvalAtom anal a env | a <- as, isValArg a]
-
- | otherwise -- Not single-constructor
- = case anal of
- StrAnal -> -- Strictness case: it's easy: it certainly terminates
- AbsTop
- AbsAnal -> -- In the absence case we need to be more
- -- careful: look to see if there's any
- -- poison in the components
- if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a]
- then AbsBot
- else AbsTop
- where
- (_,_,_, tycon) = dataConSig con
- has_single_con = maybeToBool (maybeTyConSingleCon tycon)
+absEval anal (Lit _) env = AbsTop
+ -- Literals terminate (strictness) and are not poison (absence)
\end{code}
\begin{code}
-absEval anal (Lam (ValBinder binder) body) env
- = AbsFun [binder] body env
-absEval anal (Lam other_binder expr) env
- = absEval anal expr env
-absEval anal (App f a) env | isValArg a
- = absApply anal (absEval anal f env) (absEvalAtom anal a env)
-absEval anal (App expr _) env
- = absEval anal expr env
-\end{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)
-For primitive cases, just GLB the branches, then LUB with the expr part.
+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 (Case expr (PrimAlts alts deflt)) env
+absEval anal expr@(Case scrut case_bndr alts) env
= let
- expr_val = absEval anal expr env
- abs_alts = [ absEval anal rhs env | (_, rhs) <- alts ]
- -- Don't bother to extend envt, because unbound vars
- -- default to the conservative AbsTop
-
- abs_deflt = absEvalDefault anal expr_val deflt env
+ scrut_val = absEval anal scrut env
+ alts_env = addOneToAbsValEnv env case_bndr scrut_val
in
- combineCaseValues anal expr_val
- (abs_deflt ++ abs_alts)
+ 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)
-absEval anal (Case expr (AlgAlts alts deflt)) env
- = let
- expr_val = absEval anal expr env
- abs_alts = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
- abs_deflt = absEvalDefault anal expr_val deflt env
- in
- let
- result =
- combineCaseValues anal expr_val
- (abs_deflt ++ abs_alts)
- in
-{-
- (case anal of
- StrAnal -> id
- _ -> pprTrace "absCase:ABS:" (ppAbove (ppCat [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env)))
- )
--}
- result
+ other -> absEvalAlts anal alts alts_env
\end{code}
For @Lets@ we widen the value we get. This is nothing to
in
absEval anal body new_env
-absEval anal (SCC cc expr) env = absEval anal expr 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}
-absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
-
-absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
- = -- 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(length arg_vals == length args)
- let
- new_env = growAbsValEnvList env (args `zip` arg_vals)
- in
- absEval anal rhs new_env
-
-absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
- = -- Scrutinised value is Top or Bot (it can't be a function!)
- -- So just evaluate the rhs with all constr args bound to Top.
- -- (If the scrutinee is Top we'll never evaluated this function
- -- call anyway!)
- ASSERT(ok_scrutinee)
- absEval anal rhs env
+absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal
+absEvalAlts anal alts env
+ = combine anal (map go alts)
where
- ok_scrutinee
- = case other_scrutinee of {
- AbsTop -> True; -- i.e., OK
- AbsBot -> True; -- ditto
- _ -> False -- party over
- }
-
-
-absEvalDefault :: AnalysisKind
- -> AbsVal -- Value of scrutinee
- -> CoreCaseDefault
- -> AbsValEnv
- -> [AbsVal] -- Empty or singleton
-
-absEvalDefault anal scrut_val NoDefault env = []
-absEvalDefault anal scrut_val (BindDefault binder expr) env
- = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
+ 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}
%************************************************************************
an augmented environment.
\begin{code}
-absApply anal (AbsFun [binder] body env) arg
- = absEval anal body (addOneToAbsValEnv env binder arg)
-
-absApply anal (AbsFun (binder:bs) body env) arg
- = AbsFun bs body (addOneToAbsValEnv env binder arg)
+absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg
\end{code}
\begin{code}
-absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg
- = if evalStrictness arg1_demand arg
- then AbsBot
- else case ds of
- [] -> AbsTop
- other -> AbsApproxFun ds
+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 (arg1_demand:ds)) arg
- = if evalAbsence arg1_demand arg
- then AbsBot
+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
- [] -> AbsTop
- other -> AbsApproxFun ds
+ [] -> val
+ other -> AbsApproxFun ds val
#ifdef DEBUG
-absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal)
-absApply anal (AbsFun [] _ _) arg = panic ("absApply: Duff function: AbsFun." ++ show anal)
-absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." ++ show anal)
+absApply anal f@(AbsProd _) arg
+ = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg))
#endif
\end{code}
%* *
%************************************************************************
-@findStrictness@ applies the function \tr{\ ids -> expr} to
-\tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once
-with @AbsBot@ in each argument position), and evaluates the resulting
-abstract value; it returns a vector of @Demand@s saying whether the
-result of doing this is guaranteed to be bottom. This tells the
-strictness of the function in each of the arguments.
-
-If an argument is of unboxed type, then we declare that function to be
-strict in that argument.
+\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
-We don't really have to make up all those lists of mostly-@AbsTops@;
-unbound variables in an @AbsValEnv@ are implicitly mapped to that.
+findStrictness id str_val abs_val
+ | isBot str_val = mkStrictnessInfo ([], True)
+ | otherwise = NoStrictnessInfo
-See notes on @addStrictnessInfoToId@.
+-- 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
-\begin{code}
-findStrictness :: StrAnalFlags
- -> [Type] -- Types of args in which strictness is wanted
- -> AbsVal -- Abstract strictness value of function
- -> AbsVal -- Abstract absence value of function
- -> [Demand] -- Resulting strictness annotation
+ go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
-findStrictness strflags [] str_val abs_val = []
+ 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
-findStrictness strflags (ty:tys) str_val abs_val
- = let
- demand = findRecDemand strflags [] str_fn abs_fn ty
- str_fn val = absApply StrAnal str_val val
- abs_fn val = absApply AbsAnal abs_val val
+ mk_dmd (WwUnpack u str_ds)
+ (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
- demands = findStrictness strflags tys
- (absApply StrAnal str_val AbsTop)
- (absApply AbsAnal abs_val AbsTop)
- in
- demand : demands
+ mk_dmd str_dmd abs_dmd = str_dmd
\end{code}
\begin{code}
-findDemandStrOnly str_env expr binder -- Only strictness environment available
- = findRecDemand strflags [] str_fn abs_fn (idType binder)
+findDemand dmd str_env abs_env expr binder
+ = findRecDemand str_fn abs_fn (idType binder)
where
- str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
- abs_fn val = AbsBot -- Always says poison; so it looks as if
- -- nothing is absent; safe
- strflags = getStrAnalFlags str_env
+ 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)))
-findDemandAbsOnly abs_env expr binder -- Only absence environment available
- = findRecDemand strflags [] str_fn abs_fn (idType binder)
+findDemandAlts dmd str_env abs_env alts binder
+ = findRecDemand str_fn abs_fn (idType binder)
where
- str_fn val = AbsBot -- Always says non-termination;
- -- that'll make findRecDemand peer into the
- -- structure of the value.
- abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
- strflags = getStrAnalFlags abs_env
-
-
-findDemand str_env abs_env expr binder
- = findRecDemand strflags [] str_fn abs_fn (idType binder)
- where
- str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
- abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
- strflags = getStrAnalFlags str_env
+ 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
Ho hum.
\begin{code}
-findRecDemand :: StrAnalFlags
- -> [TyCon] -- TyCons already seen; used to avoid
- -- zooming into recursive types
- -> (AbsVal -> AbsVal) -- The strictness function
- -> (AbsVal -> AbsVal) -- The absence function
+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 strflags seen str_fn abs_fn ty
- = if isPrimType ty then -- It's a primitive type!
+findRecDemand str_fn abs_fn ty
+ = if isUnLiftedType ty then -- It's a primitive type!
wwPrim
- else if not (anyBot (abs_fn AbsBot)) then -- It's absent
+ else if abs_fn AbsBot then -- It's absent
-- We prefer absence over strictness: see NOTE above.
WwLazy True
- else if not (all_strict ||
- (num_strict && is_numeric_type ty) ||
- (isBot (str_fn AbsBot))) then
+ 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 maybeAppDataTyCon ty of
+ case splitProductType_maybe ty of
- Nothing -> wwStrict
+ Nothing -> wwStrict -- Could have a test for wwEnum, but
+ -- we don't exploit it yet, so don't bother
- Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen ->
- -- Single constructor case, tycon not already seen higher up
- let
- (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys
- prod_len = length cmpnt_tys
+ 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 strflags (tycon:seen)
+ = [ findRecDemand
(\ cmpnt_val ->
str_fn (mkMainlyTopProd prod_len i cmpnt_val)
)
)
cmpnt_ty
| (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
- in
- if null compt_strict_infos then
- if isEnumerationTyCon tycon then wwEnum else wwStrict
- else
- wwUnpack compt_strict_infos
- where
- not_elem = isn'tIn "findRecDemand"
-
- Just (tycon,_,_) ->
- -- Multi-constr data types, *or* an abstract data
- -- types, *or* things we don't have a way of conveying
- -- the info over module boundaries (class ops,
- -- superdict sels, dfns).
- if isEnumerationTyCon tycon then
- wwEnum
- else
- wwStrict
- where
- (all_strict, num_strict) = strflags
+ where
is_numeric_type ty
- = case (maybeAppDataTyCon ty) of -- NB: duplicates stuff done above
- Nothing -> False
- Just (tycon, _, _)
- | tycon `is_elem`
- [intTyCon, integerTyCon,
- doubleTyCon, floatTyCon,
- wordTyCon, addrTyCon]
- -> True
- _{-something else-} -> False
+ = 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"
AbsAnal -> AbsBot
\end{code}
-\begin{verbatim}
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> (key -> key -> Bool) -- Less-than predicate
- -> [(key,val)] -- The assoc list
- -> key -- The key
- -> Maybe val -- The corresponding value
-
-mkLookupFun eq lt alist s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> Nothing
- (a:_) -> Just a
-\end{verbatim}
-
\begin{code}
fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
where
initial_val id
= case anal of -- The (unsafe) starting point
- StrAnal -> if (returnsRealWorld (idType id))
- then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
- else AbsBot
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 ]
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