From c380ee7955d1346b10964972979be09ae242d731 Mon Sep 17 00:00:00 2001 From: kglynn Date: Tue, 5 Oct 1999 09:04:30 +0000 Subject: [PATCH] [project @ 1999-10-05 09:04:30 by kglynn] (keving) Much simplified and beautified CPR analysis code. (And also much shorter, we'd better write this up before it disappears). Added (constant) functions to the abstract domain. Note that Fun^n Bot (n >= 1) == Bot and likewise for Top Treats divergent computations as Bot (rather than Top as previous) so non-divergent paths dominate which allows us to generate more accurate CPR info (see e.g. chr). We use the result of strictness analysis to tell us if an Id is divergent (when applied to sufficient args), therefore we should run after the strictness analysis pass. --- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 266 ++++++++++++++++++------------- 1 file changed, 157 insertions(+), 109 deletions(-) diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 6ad58cd..933c829 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -12,18 +12,20 @@ import CoreSyn import CoreUtils ( coreExprType ) import CoreUnfold ( maybeUnfoldingTemplate ) import Var ( Var, Id, TyVar, idType, varName, varType ) -import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding ) -import IdInfo ( CprInfo(..) ) +import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding, getIdArity, + isBottomingId ) +import IdInfo ( CprInfo(..), arityLowerBound ) import VarEnv -import Type ( Type, splitFunTys, splitForAllTys, splitNewType_maybe ) +import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys, splitNewType_maybe ) import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon ) -import DataCon ( dataConTyCon, splitProductType_maybe ) -import Const ( Con(DataCon), isWHNFCon ) +import DataCon ( dataConTyCon, splitProductType_maybe, dataConRawArgTys ) +import Const ( Con(DataCon), isDataCon, isWHNFCon ) import Util ( zipEqual, zipWithEqual ) import Outputable import UniqFM (ufmToList) - +import Maybe +import PprType( pprType ) -- Only called in debug messages \end{code} This module performs an analysis of a set of Core Bindings for the @@ -43,45 +45,80 @@ worker-wrapper pass. The worker-wrapper pass splits bindings on the basis of both strictness and CPR info. If an id has both then it can combine the transformations so that only one pair is produced. +The analysis here detects nested CPR information. For example, if a +function returns a constructed pair, the first element of which is a +constructed int, then the analysis will detect nested CPR information +for the int as well. Unfortunately, the current transformations can't +take advantage of the nested CPR information. They have (broken now, +I think) code which will flatten out nested CPR components and rebuild +them in the wrapper, but enabling this would lose laziness. It is +possible to make use of the nested info: if we knew that a caller was +strict in that position then we could create a specialized version of +the function which flattened/reconstructed that position. + +It is not known whether this optimisation would be worthwhile. + +So we generate and carry round nested CPR information, but before +using this info to guide the creation of workers and wrappers we map +all components of a CPRInfo to NoCprInfo. + + Data types ~~~~~~~~~~ Within this module Id's CPR information is represented by ``AbsVal''. When adding this information to the Id's pragma info field -we convert the Absval to a ``CprInfo'' value. The two are almost -isomorphic, CprInfo doesn't have a represenation for Bot. - -Abstract domains consist of a `no information' value (Top) and -for tuple types, a corresponding length tuple of abstract values. -Bot is not a proper abstract value but a generic bottom is -useful for calculating fixpoints. - -Since functions abstract to constant functions we can just -represent their result. It is not necessary to model functions -directly. This is more efficient, but unfortunately it both -simplifies and pbscures the code in places. +we convert the ``Absval'' to a ``CprInfo'' value. + +Abstract domains consist of a `no information' value (Top), a function +value (Fun) which when applied to an argument returns a new AbsVal +(note the argument is not used in any way), , for product types, a +corresponding length tuple (Tuple) of abstract values. And finally, +Bot. Bot is not a proper abstract value but a generic bottom is +useful for calculating fixpoints and representing divergent +computations. Note that we equate Bot and Fun^n Bot (n > 0), and +likewise for Top. This saves a lot of delving in types to keep +everything exactly correct. + +Since functions abstract to constant functions we could just +represent them by the abstract value of their result. However, it +turns out (I know - I tried!) that this requires a lot of type +manipulation and the code is more straightforward if we represent +functions by an abstract constant function. \begin{code} data AbsVal = Top -- Not a constructed product + | Fun AbsVal -- A function that takes an argument + -- and gives AbsVal as result. | Tuple [AbsVal] -- A constructed product of values | Bot -- Bot'tom included for convenience -- we could use appropriate Tuple Vals - deriving Show + deriving (Eq,Show) + +isFun :: AbsVal -> Bool +isFun (Fun _) = True +isFun _ = False -- For pretty debugging instance Outputable AbsVal where ppr Top = ptext SLIT("Top") + ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r ppr (Tuple la) = ptext SLIT("Tuple ") <> text "[" <> (hsep (punctuate comma (map ppr la))) <> text "]" ppr Bot = ptext SLIT("Bot") + +-- lub takes the lowest upper bound of two abstract values, standard. lub :: AbsVal -> AbsVal -> AbsVal lub Bot a = a lub a Bot = a lub Top a = Top lub a Top = Top lub (Tuple l) (Tuple r) = Tuple (zipWithEqual "CPR: lub" lub l r) +lub (Fun l) (Fun r) = Fun (lub l r) +lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple" + \end{code} @@ -149,7 +186,7 @@ cprAnalTopBind rho (Rec bounders) init_rho = rho `extendVarEnvList` (zip binders (repeat Bot)) binders = map fst bounders - (fin_rho, fin_bounders) = ntimes (length bounders) + (fin_rho, fin_bounders) = nTimes (length bounders) do_one_pass (init_rho, bounders) fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e)) @@ -157,57 +194,71 @@ cprAnalTopBind rho (Rec bounders) cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) + +-- If Id will always diverge when given sufficient arguments then +-- we can just set its abs val to Bot. Any other CPR info +-- from other paths will then dominate, which is what we want. -- Check in rho, if not there it must be imported, so check -- the var's idinfo. cprAnalExpr rho e@(Var v) - = (e, case lookupVarEnv rho v of - Just a_val -> a_val - Nothing -> getCprPragInfo v) + | isBottomingId v = (e, Bot) + | otherwise = (e, case lookupVarEnv rho v of + Just a_val -> a_val + Nothing -> cpr_prag_a_val) where - getCprPragInfo v = let ids_inf = (cprInfoToAbs . getIdCprInfo) v in - case ids_inf of - Top -> -- if we can inline this var, then - -- analyse the unfolding + ids_inf = (cprInfoToAbs.getIdCprInfo) v + ids_arity = (arityLowerBound.getIdArity) v + cpr_prag_a_val = case ids_inf of + Top -> -- if we can inline this var, and its a constructor app + -- then analyse the unfolding case (maybeUnfoldingTemplate.getIdUnfolding) v of - Just e -> if isCon e then snd $ cprAnalExpr rho e - else ids_inf - zz_other -> ids_inf - zz_other -> ids_inf + Just e | isCon e -> snd $ cprAnalExpr rho e + zz_other -> Top + zz_other -> -- Unfortunately, cprinfo doesn't store the # of args + nTimes ids_arity Fun ids_inf -- Return constructor with decorated arguments. If constructor -- has product type then this is a manifest constructor (hooray!) cprAnalExpr rho (Con con args) = (Con con args_cpr, - -- Don't need to do this here, since we will filter out later - -- but it isn't expensive and will reduce returned abs vals. - if isConProdType con - then Tuple args_avals + if isConProdType con + then Tuple args_aval_filt_funs else Top) where - (args_cpr, args_avals) = foldl anal_arg ([], []) args - - anal_arg :: ([CoreExpr], [AbsVal]) -> CoreExpr -> ([CoreExpr], [AbsVal]) - anal_arg (done_args, avs) arg - | isValArg arg = cprAnalExpr rho arg `end_cons` (done_args, avs) - | otherwise = (done_args ++ [arg], avs) - where - end_cons :: (a,b) -> ([a],[b]) -> ([a],[b]) - end_cons (x,y) (xs,ys) = (xs ++ [x], ys ++ [y]) - --- For apps we ignore the argument. This app will return a constructed --- product if the function does (we check that result type is not a fn when --- we come to decorate a binder). + anal_con_args = map (cprAnalExpr rho) args + args_cpr = map fst anal_con_args + + args_aval_filt_funs = if (not.isDataCon) con then + map snd anal_con_args + else + map (ifApply isFun (const Top)) $ + map snd $ + filter (not.isTypeArg.fst) anal_con_args + +-- For apps we don't care about the argument's abs val. This +-- app will return a constructed product if the function does. We strip +-- a Fun from the functions abs val, unless the argument is a type argument +-- or it is already Top or Bot. +cprAnalExpr rho (App fun arg@(Type _)) + = (App fun_cpr arg, fun_res) + where + (fun_cpr, fun_res) = cprAnalExpr rho fun + cprAnalExpr rho (App fun arg) - = (App fun_cpr arg_cpr, res_aval) + = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot + then fun_res + else res_res) where - (fun_cpr, res_aval) = cprAnalExpr rho fun - (arg_cpr, arg_aval) = cprAnalExpr rho arg + (fun_cpr, fun_res) = cprAnalExpr rho fun + (arg_cpr, _) = cprAnalExpr rho arg + Fun res_res = fun_res -- Map arguments to Top (we aren't constructing them) -- Return the abstract value of the body, since functions --- are represented by the CPR value of their result. -cprAnalExpr rho (Lam b body) - = (Lam b body_cpr, body_aval) +-- are represented by the CPR value of their result, and +-- add a Fun for this lambda.. +cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval) + | otherwise = (Lam b body_cpr, Fun body_aval) where (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body @@ -221,7 +272,7 @@ cprAnalExpr rho (Let (NonRec binder rhs) body) cprAnalExpr rho (Let (Rec bounders) body) = (Let (Rec fin_bounders) body_cpr, body_aval) where - (rhs_rho, fin_bounders) = ntimes + (rhs_rho, fin_bounders) = nTimes (length bounders) do_one_pass (init_rho, bounders) @@ -239,9 +290,9 @@ cprAnalExpr rho (Case scrut bndr alts) (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts cprAnalExpr rho (Note n exp) - = (Note n exp_cpr, note_aval) + = (Note n exp_cpr, expr_aval) where - (exp_cpr, note_aval) = cprAnalExpr rho exp + (exp_cpr, expr_aval) = cprAnalExpr rho exp cprAnalExpr rho (Type t) = (Type t, Top) @@ -271,67 +322,63 @@ do_one_pass (i_rho,bounders) -- take a binding pair and the abs val calculated from the rhs and -- calculate a new absval taking into account sufficient manifest --- lambda condition and that product arguments must be non-functional --- to have CPR property. --- Also we pin the var's CPR property to it. This only has the CPR property if --- its a function +-- lambda condition +-- Also we pin the var's CPR property to it. A var only has the CPR property if +-- it is a function pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal) pinCPR v e av = case av of - Tuple _ -> - -- v is function with sufficent lambdas? - if v_is_fn then - if {- pprTrace "pinCPR:" (ppr v <+> text "type args:" <+> - ppr argtys <+> text "lambda bound vars" <+> - ppr val_binders) -} (length argtys == length val_binders) then - (addCpr av, av) - else (addCpr Top, Top) - else + -- is v a function with insufficent lambdas? + Fun _ | length argtys /= length val_binders -> + -- argtys must be greater than val_binders. So stripped_exp + -- has a function type. The head of this expr can't be lambda + -- a note, because we stripped them off before. It can't be a + -- Con because it has a function type. It can't be a Type. + -- If its an app, let or case then there is work to get the + -- and we can't do anything because we may lose laziness. *But* + -- if its a var (i.e. a function name) then we are fine. Note + -- that I don't think this case is at all interesting, but I have + -- a test program that generates it. + + -- UPDATE: 20 Jul 1999 + -- I've decided not to allow this (useless) optimisation. It will make + -- the w/w split more complex. + -- if isVar stripped_exp then + -- (addCpr av, av) + -- else + (addCpr Top, Top) + Tuple _ -> -- not a function. -- Pin NoInfo to v. If v appears in the interface file then an -- importing module will check to see if it has an unfolding - -- with a constructor at its head. If it does it will re-analyse + -- with a constructor at its head (WHNF). If it does it will re-analyse -- the folding. I could do the check here, but I don't know if -- the current unfolding info is final. (addCpr Top, - -- OK, not a function but retain CPR info if it has a constructor + -- Retain CPR info if it has a constructor -- at its head, and thus will be inlined and simplified by -- case of a known constructor - if isCon e then - -- Need to filter out functions from nested results - filterAbsTuple (av, v_type) - else Top) - _ -> (addCpr av, av) + if isCon e then av else Top) + _ -> (addCpr av, av) where -- func to pin CPR info on a var addCpr :: AbsVal -> Var addCpr = (setIdCprInfo v).absToCprInfo - v_type = varType v + -- Split argument types and result type from v's type - (_, argtys, zz_result_type) = splitTypeToFunArgAndRes v_type - v_is_fn = argtys /= [] + (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v + -- val_binders are the explicit lambdas at the head of the expression - (binders,zz_stripped_exp) = collectBinders e - val_binders = filter (not.isTyVar) binders - -filterAbsTuple :: (AbsVal, Type) -> AbsVal -filterAbsTuple (av@(Tuple args), ty) - = case splitProductType_maybe ty of - Nothing -> WARN( True, text "filterAbsTuple" <+> ppr ty) -- Or should it be a panic? - Top - Just (tycon, _, data_con, inst_con_arg_tys) - | isNewTyCon tycon - -> ASSERT ( null $ tail inst_con_arg_tys ) - filterAbsTuple (av, head inst_con_arg_tys) - | otherwise - -> Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys - -filterAbsTuple (av, _) = av + (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e' + absToCprInfo :: AbsVal -> CprInfo absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args -absToCprInfo _ = NoCPRInfo +absToCprInfo (Fun r) = absToCprInfo r +absToCprInfo _ = NoCPRInfo +-- Cpr Info doesn't store the number of arguments a function has, so the caller +-- must take care to add the appropriate number of Funs. cprInfoToAbs :: CprInfo -> AbsVal cprInfoToAbs NoCPRInfo = Top cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args @@ -383,24 +430,25 @@ splitFunTysIgnoringNewTypes ty = split ty -- Is this the constructor for a product type (i.e. algebraic, single constructor) -- NB: isProductTyCon replies 'False' for unboxed tuples isConProdType :: Con -> Bool -isConProdType (DataCon con) = isProductTyCon tycon - where - tycon = dataConTyCon con +isConProdType (DataCon con) = isProductTyCon . dataConTyCon $ con isConProdType _ = False -- returns True iff head of expression is a constructor --- Should I look through notes? +-- Should I look through notes? I think so ... isCon :: CoreExpr -> Bool isCon (Con c _) = isWHNFCon c -- is this the right test? +isCon (Note _n e) = isCon e isCon _ = False -\end{code} -\begin{code} --- Compose a function with itself n times. This must be in a library --- somewhere, but where! -ntimes :: Int -> (a -> a) -> (a -> a) -ntimes 0 f = id -ntimes 1 f = f -ntimes n f = f . ntimes (n-1) f +-- Compose a function with itself n times. (nth rather than twice) +-- This must/should be in a library somewhere, but where! +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +-- Only apply f to argument if it satisfies p +ifApply :: (a -> Bool) -> (a -> a) -> (a -> a) +ifApply p f x = if p x then f x else x \end{code} -- 1.7.10.4