X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=a6a79ec16696dd11c6cbfa5a3cd205664d071562;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=1020b6726b084d7068f81151ed9b3d3234977100;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 1020b67..a6a79ec 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -1,51 +1,44 @@ % -% (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} %************************************************************************ @@ -59,12 +52,10 @@ Least upper bound, greatest lower bound. \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 @@ -114,79 +105,18 @@ glb v1 v2 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 @@ -198,26 +128,20 @@ Used only in strictness analysis: \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 @@ -227,12 +151,29 @@ it, so it can be compared for equality by @sameVal@. \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 -- @@ -248,20 +189,35 @@ widen StrAnal (AbsFun args body env) -- 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) @@ -299,8 +255,8 @@ crudeAbsWiden val = if anyBot val then AbsBot else AbsTop 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 @@ -309,13 +265,13 @@ 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 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} @@ -335,20 +291,24 @@ evalStrictness (WwLazy _) _ = False 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 @@ -360,12 +320,17 @@ possibly} hit poison. 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 @@ -387,25 +352,29 @@ evalAbsence other val = anyBot val -- 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, @@ -426,147 +395,84 @@ absId anal var env -- "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 @@ -610,48 +516,26 @@ absEval anal (Let (Rec pairs) body) env 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} %************************************************************************ @@ -682,32 +566,28 @@ result. A @Lam@ with two or more args: return another @AbsFun@ with 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} @@ -720,69 +600,72 @@ absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." %* * %************************************************************************ -@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 @@ -818,41 +701,46 @@ then we'd let-to-case it: 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) ) @@ -861,36 +749,12 @@ findRecDemand strflags seen str_fn abs_fn ty ) 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" @@ -962,19 +826,6 @@ cheapFixpoint anal ids rhss env 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] @@ -985,10 +836,14 @@ fixpoint anal ids rhss env 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 ] @@ -1064,3 +919,7 @@ 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}