X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=d2a8b3d17401289f916a8bd9ca6bc7e3af18a392;hb=8295d9ca0f3e72e545b35c43a4a2e1e4ec582fb6;hp=60c943ecb593ec12f1857a87a5bc5055aea7202e;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 60c943e..d2a8b3d 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -1,50 +1,41 @@ % -% (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" - module SaAbsInt ( findStrictness, - findDemand, + findDemand, findDemandAlts, absEval, widen, fixpoint, isBot ) where -import Ubiq{-uitous-} +#include "HsVersions.h" +import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), FormSummary ) -import CoreUtils ( unTagBinders ) -import Id ( idType, getIdStrictness, getIdUnfolding, - dataConSig, dataConArgTys - ) -import IdInfo ( StrictnessInfo(..), Demand(..), - wwPrim, wwStrict, wwEnum, wwUnpack - ) -import MagicUFs ( MagicUnfoldingFun ) -import Maybes ( maybeToBool ) -import Outputable ( Outputable(..){-instance * []-} ) -import PprStyle ( PprStyle(..) ) -import PrelInfo ( intTyCon, integerTyCon, doubleTyCon, - floatTyCon, wordTyCon, addrTyCon - ) -import Pretty ( ppStr ) -import PrimOp ( PrimOp(..) ) +import CoreUnfold ( Unfolding(..) ) +import PrimOp ( primOpStrictness ) +import Id ( Id, idType, getIdStrictness, getIdUnfolding ) +import Const ( Con(..) ) +import DataCon ( dataConTyCon, dataConArgTys ) +import IdInfo ( StrictnessInfo(..) ) +import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, + wwUnpackNew ) import SaLib -import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, - TyCon{-instance Eq-} - ) -import Type ( maybeAppDataTyCon, isPrimType ) -import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, - pprTrace, panic, pprPanic, assertPanic - ) - -returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)" +import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon ) +import BasicTypes ( NewOrData(..) ) +import Type ( splitAlgTyConApp_maybe, + isUnLiftedType, Type ) +import TyCon ( tyConUnique ) +import PrelInfo ( numericTyKeys ) +import Util ( isIn, nOfThem, zipWithEqual ) +import Outputable + +returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} %************************************************************************ @@ -63,7 +54,7 @@ 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 (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 @@ -113,79 +104,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 @@ -197,11 +127,9 @@ 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: @@ -211,12 +139,8 @@ 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 (AbsFun bndr body env) = anyBot (absEval AbsAnal body (addOneToAbsValEnv env bndr AbsTop)) +anyBot (AbsApproxFun _ val) = anyBot val \end{code} @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is @@ -226,12 +150,30 @@ 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 body env) + = case widened_body of + AbsApproxFun ds val -> AbsApproxFun (d : ds) val + where + d = findRecDemand str_fn abs_fn bndr_ty + str_fn val = 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 = absApply StrAnal the_fn val + where + bndr_ty = idType bndr + widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop) + abs_fn val = AbsBot -- 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 -- @@ -247,20 +189,36 @@ 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 body env) + | 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 = 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 = absApply AbsAnal the_fn val + where + bndr_ty = idType bndr + widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop) + str_fn val = AbsBot -- Always says non-termination; + -- that'll make findRecDemand peer into the + -- structure of the value. widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) @@ -308,13 +266,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} @@ -334,20 +292,23 @@ evalStrictness (WwLazy _) _ = False evalStrictness WwStrict val = isBot val evalStrictness WwEnum val = isBot val -evalStrictness (WwUnpack demand_info) val +evalStrictness (WwUnpack NewType _ (demand:_)) val + = evalStrictness demand val + +evalStrictness (WwUnpack DataType _ demand_info) val = case val of AbsTop -> False AbsBot -> True - AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals) - _ -> trace "evalStrictness?" False + AbsProd vals -> 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 @@ -359,11 +320,14 @@ possibly} hit poison. evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison -- with Absent demand -evalAbsence (WwUnpack demand_info) val +evalAbsence (WwUnpack NewType _ (demand:_)) val + = evalAbsence demand val + +evalAbsence (WwUnpack DataType _ demand_info) val = case val of AbsTop -> False -- No poison in here AbsBot -> True -- Pure poison - AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals) + AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals) _ -> panic "evalAbsence: other" evalAbsence other val = anyBot val @@ -386,25 +350,16 @@ 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, getIdStrictness var, getIdUnfolding var) of (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 _) -> + (Nothing, NoStrictnessInfo, CoreUnfolding _ _ 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,86 +381,62 @@ absId anal var env (Nothing, strictness_info, _) -> - -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails + -- Includes MagicUnfolding, 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 \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] +absEval anal (Con (Literal _) args) env + = -- Literals terminate (strictness) and are not poison (absence) + AbsTop + +absEval anal (Con (PrimOp op) args) env + = -- Not all PrimOps evaluate all their arguments + if or (zipWith (check_arg anal) + [absEval anal arg env | arg <- args] + arg_demands) then AbsBot - else AbsTop - -- For absence analysis, we want to see if the poison shows up... + else case anal of + StrAnal | result_bot -> AbsBot + other -> AbsTop + where + (arg_demands, result_bot) = primOpStrictness op + check_arg StrAnal arg dmd = evalStrictness dmd arg + check_arg AbsAnal arg dmd = evalAbsence dmd arg -absEval anal (Con con as) env - | has_single_con - = AbsProd [absEvalAtom anal a env | a <- as, isValArg a] +absEval anal (Con (DataCon con) args) env + | isProductTyCon (dataConTyCon con) + = -- Products; filter out type arguments + AbsProd [absEval anal a env | a <- args, isValArg a] | otherwise -- Not single-constructor = case anal of @@ -514,58 +445,45 @@ absEval anal (Con con as) env 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] + if any anyBot [absEval AbsAnal arg env | arg <- args] then AbsBot else AbsTop - where - (_,_,_, tycon) = dataConSig con - has_single_con = maybeToBool (maybeTyConSingleCon tycon) \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 +absEval anal (Lam bndr body) env + | isTyVar bndr = absEval anal body env -- Type lambda + | otherwise = AbsFun bndr body env -- Value lambda + +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} -For primitive cases, just GLB the branches, then LUB with the expr part. - \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(length arg_vals == length 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 @@ -609,49 +527,21 @@ 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 (Coerce c ty expr) env = absEval anal expr env +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 +572,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 +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) \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} @@ -736,53 +622,43 @@ unbound variables in an @AbsValEnv@ are implicitly mapped to that. See notes on @addStrictnessInfoToId@. \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 +findStrictness :: [Type] -- Types of args in which strictness is wanted + -> AbsVal -- Abstract strictness value of function + -> AbsVal -- Abstract absence value of function + -> ([Demand], Bool) -- Resulting strictness annotation -findStrictness strflags [] str_val abs_val = [] +findStrictness tys str_val abs_val + = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops)) + where + tys_w_index = tys `zip` [1..] -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 + find_str (ty,n) = findRecDemand str_fn abs_fn ty + where + str_fn val = foldl (absApply StrAnal) str_val + (map (mk_arg val n) tys_w_index) - demands = findStrictness strflags tys - (absApply StrAnal str_val AbsTop) - (absApply AbsAnal abs_val AbsTop) - in - demand : demands + abs_fn val = foldl (absApply AbsAnal) abs_val + (map (mk_arg val n) tys_w_index) + + mk_arg val n (_,m) | m==n = val + | otherwise = AbsTop + + all_tops = [AbsTop | _ <- tys] \end{code} \begin{code} -findDemandStrOnly str_env expr binder -- Only strictness environment available - = findRecDemand strflags [] str_fn abs_fn (idType binder) +findDemand 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 - -findDemandAbsOnly abs_env expr binder -- Only absence environment available - = findRecDemand strflags [] 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) +findDemandAlts str_env abs_env alts binder + = findRecDemand 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 = absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val) + abs_fn val = absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val) \end{code} @findRecDemand@ is where we finally convert strictness/absence info @@ -818,41 +694,47 @@ 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 +findRecDemand :: (AbsVal -> AbsVal) -- The strictness function -> (AbsVal -> AbsVal) -- The absence function -> 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 -- 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) || + (isBot (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 (splitAlgTyConApp_maybe ty) of Nothing -> wwStrict - Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen -> - -- Single constructor case, tycon not already seen higher up + Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon -> + -- Non-recursive, single constructor case let cmpnt_tys = dataConArgTys data_con tycon_arg_tys prod_len = length cmpnt_tys + in + if isNewTyCon tycon then -- A newtype! + ASSERT( null (tail cmpnt_tys) ) + let + demand = findRecDemand str_fn abs_fn (head cmpnt_tys) + in + wwUnpackNew demand + else -- A data type! + let compt_strict_infos - = [ findRecDemand strflags (tycon:seen) + = [ findRecDemand (\ cmpnt_val -> str_fn (mkMainlyTopProd prod_len i cmpnt_val) ) @@ -865,9 +747,7 @@ findRecDemand strflags seen str_fn abs_fn ty if null compt_strict_infos then if isEnumerationTyCon tycon then wwEnum else wwStrict else - wwUnpack compt_strict_infos - where - not_elem = isn'tIn "findRecDemand" + wwUnpackData compt_strict_infos Just (tycon,_,_) -> -- Multi-constr data types, *or* an abstract data @@ -879,16 +759,11 @@ findRecDemand strflags seen str_fn abs_fn ty else wwStrict where - (all_strict, num_strict) = strflags - is_numeric_type ty - = case (maybeAppDataTyCon ty) of -- NB: duplicates stuff done above + = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above Nothing -> False Just (tycon, _, _) - | tycon `is_elem` - [intTyCon, integerTyCon, - doubleTyCon, floatTyCon, - wordTyCon, addrTyCon] + | tyConUnique tycon `is_elem` numericTyKeys -> True _{-something else-} -> False where