X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=3cd9ba434b6533661886c1f0293f7c32433e7d20;hb=3f5e4368fd4e87e116ce34be4cf9dd0f9f96726d;hp=aa0820572103b90e54b75433f7a895629a5c808e;hpb=01e93cefd831b314a2c7ff6d109d5019db5f0608;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index aa08205..3cd9ba4 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 OLD_STRICTNESS +-- If OLD_STRICTNESS is off, omit all exports +module SaAbsInt () where + +#else module SaAbsInt ( findStrictness, findDemand, findDemandAlts, @@ -17,22 +22,22 @@ module SaAbsInt ( import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn -import CoreUnfold ( Unfolding, maybeUnfoldingTemplate ) -import PrimOp ( primOpStrictness ) -import Id ( Id, idType, getIdStrictness, getIdUnfolding ) -import Const ( Con(..) ) -import DataCon ( dataConTyCon, splitProductType_maybe ) +import CoreUnfold ( maybeUnfoldingTemplate ) +import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe, + idStrictness, + ) +import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, 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 \end{code} @@ -47,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) @@ -102,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 @@ -127,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 @@ -149,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... @@ -193,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, @@ -204,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. @@ -254,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 @@ -290,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 @@ -318,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 @@ -348,12 +352,25 @@ evalAbsence other val = anyBot val -- error's arg absId anal var env - = case (lookupAbsValEnv env var, getIdStrictness var, maybeUnfoldingTemplate (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, Just 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 @@ -378,10 +395,13 @@ absId anal var env -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} - (Nothing, strictness_info, _) -> + (_, _, 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} @@ -413,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 @@ -475,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 @@ -525,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} @@ -570,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} @@ -591,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} @@ -604,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 tys str_val abs_val - = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops)) +findStrictness id str_val abs_val + | isBot str_val = mkStrictnessInfo ([], True) + | otherwise = NoStrictnessInfo + +-- The list of absence demands passed to combineDemands +-- can be shorter than the list of absence demands +-- +-- lookup = \ dEq -> letrec { +-- lookup = \ key ds -> ...lookup... +-- } +-- in lookup +-- Here the strictness value takes three args, but the absence value +-- takes only one, for reasons I don't quite understand (see cheapFixpoint) + +find_strictness id orig_str_ds orig_str_res orig_abs_ds + = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot) where - tys_w_index = tys `zip` [(1::Int) ..] + 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 @@ -692,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 @@ -701,13 +710,13 @@ 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)! @@ -717,19 +726,16 @@ findRecDemand str_fn abs_fn ty Nothing -> wwStrict -- Could have a test for wwEnum, but -- we don't exploit it yet, so don't bother - Just (tycon,_,data_con,cmpnt_tys) -- Non-recursive, single constructor case - | isNewTyCon tycon -- A newtype! - -> ASSERT( null (tail cmpnt_tys) ) - let - demand = findRecDemand str_fn abs_fn (head cmpnt_tys) - in - wwUnpackNew demand + 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 + | null compt_strict_infos -- A nullary data type -> wwStrict | otherwise -- Some other data type - -> wwUnpackData compt_strict_infos + -> wwUnpack compt_strict_infos where prod_len = length cmpnt_tys @@ -746,12 +752,9 @@ findRecDemand str_fn abs_fn ty 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" @@ -823,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] @@ -929,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}