X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=eabc35eab5146adb121a83f8f66886b728818afe;hb=ad552fe28f05107378eec34e13d30b5318339567;hp=dc1efe4a45c5e8bcdfbdf4e60618383f046a331f;hpb=67afaea627d683193f408fac2cc5216b5d4a11d2;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index dc1efe4..eabc35e 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -4,6 +4,11 @@ \section[SaAbsInt]{Abstract interpreter for strictness analysis} \begin{code} +#ifndef DEBUG +-- If DEBUG is off, omit all exports +module SaAbsInt () where + +#else module SaAbsInt ( findStrictness, findDemand, findDemandAlts, @@ -17,25 +22,23 @@ module SaAbsInt ( import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn -import CoreUnfold ( Unfolding(..) ) -import PrimOp ( primOpStrictness ) -import Id ( Id, idType, getIdStrictness, getIdUnfolding ) -import Const ( Con(..) ) -import DataCon ( dataConTyCon, dataConArgTys ) +import CoreUnfold ( maybeUnfoldingTemplate ) +import Id ( Id, idType, idUnfolding, isDataConId_maybe, + idStrictness, + ) +import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, - wwUnpackNew ) +import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy, + mkStrictnessInfo, isLazy + ) import SaLib -import TyCon ( isProductTyCon, isEnumerationTyCon, isNewTyCon ) -import BasicTypes ( NewOrData(..) ) -import Type ( splitAlgTyConApp_maybe, +import TyCon ( isProductTyCon, isRecursiveTyCon ) +import Type ( splitTyConApp_maybe, isUnLiftedType, Type ) import TyCon ( tyConUnique ) import PrelInfo ( numericTyKeys ) -import Util ( isIn, nOfThem, zipWithEqual ) +import Util ( isIn, nOfThem, zipWithEqual, equalLength ) import Outputable - -returnsRealWorld x = False -- ToDo: panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} %************************************************************************ @@ -49,10 +52,8 @@ 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" lub xs ys) @@ -104,7 +105,7 @@ glb v1 v2 else AbsBot where - is_fun (AbsFun _ _ _) = True + is_fun (AbsFun _ _) = True is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok is_fun other = False @@ -129,18 +130,18 @@ isBot :: AbsVal -> Bool isBot AbsBot = True isBot other = False -- Functions aren't bottom any more - \end{code} Used only in absence analysis: + \begin{code} anyBot :: AbsVal -> Bool -anyBot AbsBot = True -- poisoned! -anyBot AbsTop = False -anyBot (AbsProd vals) = any anyBot vals -anyBot (AbsFun bndr body env) = anyBot (absEval AbsAnal body (addOneToAbsValEnv env bndr AbsTop)) -anyBot (AbsApproxFun _ val) = anyBot val +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 @@ -151,22 +152,21 @@ it, so it can be compared for equality by @sameVal@. widen :: AnalysisKind -> AbsVal -> AbsVal -- Widening is complicated by the fact that funtions are lifted -widen StrAnal the_fn@(AbsFun bndr body env) +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 = foldl (absApply StrAnal) the_fn - (val : [AbsTop | d <- ds]) + 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 = absApply StrAnal the_fn val + str_fn val = isBot (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 + abs_fn val = False -- Always says poison; so it looks as if -- nothing is absent; safe {- OLD comment... @@ -195,7 +195,7 @@ widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals) widen StrAnal other_val = other_val -widen AbsAnal the_fn@(AbsFun bndr body env) +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, @@ -206,17 +206,16 @@ widen AbsAnal the_fn@(AbsFun bndr body env) 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]) + 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 = absApply AbsAnal the_fn val + abs_fn val = not (anyBot (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; + str_fn val = True -- Always says non-termination; -- that'll make findRecDemand peer into the -- structure of the value. @@ -256,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 @@ -292,15 +291,16 @@ evalStrictness (WwLazy _) _ = False evalStrictness WwStrict val = isBot val evalStrictness WwEnum val = isBot val -evalStrictness (WwUnpack NewType _ (demand:_)) val - = evalStrictness demand val - -evalStrictness (WwUnpack DataType _ demand_info) val +evalStrictness (WwUnpack _ demand_info) val = case val of AbsTop -> False AbsBot -> True - AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals) - _ -> pprTrace "evalStrictness?" empty 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 @@ -320,15 +320,17 @@ possibly} hit poison. evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison -- with Absent demand -evalAbsence (WwUnpack NewType _ (demand:_)) val - = evalAbsence demand val - -evalAbsence (WwUnpack DataType _ 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" 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 @@ -350,12 +352,25 @@ evalAbsence other val = anyBot val -- error's arg absId anal var env - = case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of + = case (lookupAbsValEnv env var, + isDataConId_maybe var, + idStrictness var, + maybeUnfoldingTemplate (idUnfolding var)) of - (Just abs_val, _, _) -> + (Just abs_val, _, _, _) -> abs_val -- Bound in the environment - (Nothing, NoStrictnessInfo, CoreUnfolding _ _ 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 @@ -380,10 +395,13 @@ absId anal var env -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} - (Nothing, strictness_info, _) -> - -- Includes MagicUnfolding, NoUnfolding + (_, _, strictness_info, _) -> + -- Includes NoUnfolding -- Try the strictness info absValFromStrictness anal strictness_info + +productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args) +productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args)) \end{code} \begin{code} @@ -415,45 +433,16 @@ Things are a little different for absence analysis, because we want to make sure that any poison (?????) \begin{code} -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, isValArg arg] - arg_demands) - then AbsBot - 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 (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 - 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 [absEval AbsAnal arg env | arg <- args] - then AbsBot - else AbsTop +absEval anal (Lit _) env = AbsTop + -- Literals terminate (strictness) and are not poison (absence) \end{code} \begin{code} absEval anal (Lam bndr body) env | isTyVar bndr = absEval anal body env -- Type lambda - | otherwise = AbsFun bndr body env -- Value lambda + | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda + where + abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg) absEval anal (App expr (Type ty)) env = absEval anal expr env -- Type appplication @@ -477,7 +466,7 @@ absEval anal expr@(Case scrut case_bndr alts) env -- 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) + ASSERT(equalLength arg_vals val_bndrs) absEval anal rhs rhs_env where val_bndrs = filter isId bndrs @@ -527,6 +516,11 @@ absEval anal (Let (Rec pairs) body) env in absEval anal body new_env +absEval anal (Note (Coerce _ _) expr) env = AbsTop + -- Don't look inside coerces, becuase they + -- are usually recursive newtypes + -- (Could improve, for the error case, but we're about + -- to kill this analyser anyway.) absEval anal (Note note expr) env = absEval anal expr env \end{code} @@ -572,8 +566,7 @@ 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 bndr_ty abs_fn) arg = abs_fn arg \end{code} \begin{code} @@ -593,7 +586,8 @@ absApply AbsAnal (AbsApproxFun (d:ds) val) arg other -> AbsApproxFun ds val #ifdef DEBUG -absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) +absApply anal f@(AbsProd _) arg + = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) #endif \end{code} @@ -606,59 +600,72 @@ absApply anal f@(AbsProd _) arg = pprPanic ("absApply: Duff function: AbsP %* * %************************************************************************ -@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. - -We don't really have to make up all those lists of mostly-@AbsTops@; -unbound variables in an @AbsValEnv@ are implicitly mapped to that. - -See notes on @addStrictnessInfoToId@. - \begin{code} -findStrictness :: [Type] -- Types of args in which strictness is wanted +findStrictness :: Id -> AbsVal -- Abstract strictness value of function -> AbsVal -- Abstract absence value of function - -> ([Demand], Bool) -- Resulting strictness annotation + -> StrictnessInfo -- Resulting strictness annotation + +findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) + -- You might think there's really no point in describing detailed + -- strictness for a divergent function; + -- If it's fully applied we get bottom regardless of the + -- argument. If it's not fully applied we don't get bottom. + -- Finally, we don't want to regard the args of a divergent function + -- as 'interesting' for inlining purposes (see Simplify.prepareArgs) + -- + -- HOWEVER, if we make diverging functions appear lazy, they + -- don't get wrappers, and then we get dreadful reboxing. + -- See notes with WwLib.worthSplitting + = find_strictness id str_ds str_res abs_ds + +findStrictness id str_val abs_val + | isBot str_val = mkStrictnessInfo ([], True) + | otherwise = NoStrictnessInfo -findStrictness tys str_val abs_val - = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops)) +-- 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 - tys_w_index = tys `zip` [1..] + res_bot = isBot orig_str_res - 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) + go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) - abs_fn val = foldl (absApply AbsAnal) abs_val - (map (mk_arg val n) tys_w_index) + mk_dmd str_dmd (WwLazy True) + = WARN( not (res_bot || isLazy str_dmd), + ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) + -- If the arg isn't used we jolly well don't expect the function + -- to be strict in it. Unless the function diverges. + WwLazy True -- Best of all - mk_arg val n (_,m) | m==n = val - | otherwise = AbsTop + mk_dmd (WwUnpack u str_ds) + (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds) - all_tops = [AbsTop | _ <- tys] + mk_dmd str_dmd abs_dmd = str_dmd \end{code} \begin{code} -findDemand str_env abs_env expr 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 = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val) + str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val)) + abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val))) -findDemandAlts str_env abs_env alts binder +findDemandAlts dmd str_env abs_env alts binder = findRecDemand str_fn abs_fn (idType binder) where - str_fn val = absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val) - abs_fn val = absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val) + 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 @@ -694,8 +701,8 @@ then we'd let-to-case it: Ho hum. \begin{code} -findRecDemand :: (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 @@ -703,36 +710,35 @@ 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 (opt_AllStrict || - (opt_NumbersStrict && is_numeric_type ty) || - (isBot (str_fn AbsBot))) then + (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 (splitAlgTyConApp_maybe ty) of + case splitProductType_maybe ty of + + Nothing -> wwStrict -- Could have a test for wwEnum, but + -- we don't exploit it yet, so don't bother - Nothing -> wwStrict + 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) - Just (tycon,tycon_arg_tys,[data_con]) | isProductTyCon tycon -> - -- Non-recursive, single constructor case - let - cmpnt_tys = dataConArgTys data_con tycon_arg_tys + | null compt_strict_infos -- A nullary data type + -> wwStrict + + | otherwise -- Some other data type + -> wwUnpack compt_strict_infos + + where 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 (\ cmpnt_val -> @@ -743,29 +749,12 @@ findRecDemand 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 - wwUnpackData compt_strict_infos - - 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 is_numeric_type ty - = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above - Nothing -> False - Just (tycon, _, _) - | tyConUnique tycon `is_elem` numericTyKeys - -> 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" @@ -837,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] @@ -860,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 ] @@ -939,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 /* DEBUG */ +\end{code}