From eca2da2e802226a176012ca51f131e8185580ebf Mon Sep 17 00:00:00 2001 From: kglynn Date: Tue, 29 Jun 1999 06:26:38 +0000 Subject: [PATCH] [project @ 1999-06-29 06:26:37 by kglynn] CPR Analysis Mark 2. Slightly more elegant, and (I believe) now copes correctly with references to CAFS and non-top level function bindings. --- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 309 +++++++++++++++++++------------ ghc/compiler/stranal/WwLib.lhs | 13 +- 2 files changed, 200 insertions(+), 122 deletions(-) diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index c9dc48d..23dd460 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -10,15 +10,16 @@ import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal ) import CoreLint ( beginPass, endPass ) import CoreSyn import CoreUtils ( coreExprType ) +import CoreUnfold ( maybeUnfoldingTemplate ) import Var ( Var, Id, TyVar, idType, varName, varType ) -import Id ( setIdCprInfo, getIdCprInfo ) +import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding ) import IdInfo ( CprInfo(..) ) import VarEnv -import Type ( Type, splitFunTys, splitForAllTys, splitTyConApp_maybe, +import Type ( Type(..), splitFunTys, splitForAllTys, splitTyConApp_maybe, splitAlgTyConApp_maybe ) -import TyCon ( maybeTyConSingleCon, isProductTyCon, isNewTyCon ) +import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon ) import DataCon ( dataConTyCon, dataConArgTys ) -import Const +import Const ( Con(DataCon), isWHNFCon ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -27,39 +28,48 @@ import UniqFM (ufmToList) \end{code} This module performs an analysis of a set of Core Bindings for the -Constructed Product Result (CPR) transformation. +Constructed Product Result (CPR) transformation. It detects functions that always explicitly (manifestly?) construct a result value with a product type. A product type is a type which has only one constructor. For example, tuples and boxed primitive values have product type. -We must also ensure that the function's body starts with sufficient manifest -lambdas otherwise loss of sharing can occur. See the comment in -@StrictAnal.lhs@ - +We must also ensure that the function's body starts with sufficient +manifest lambdas otherwise loss of sharing can occur. See the comment +in @StrictAnal.lhs@. + The transformation of bindings to worker/wrapper pairs is done by the -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. +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. 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 -required for calculating fixpoints. +useful for calculating fixpoints. + Since functions abstract to constant functions we can just represent their result. It is not necessary to model functions -directly. +directly. This is more efficient, but unfortunately it both +simplifies and pbscures the code in places. \begin{code} data AbsVal = Top -- Not a constructed product | Tuple [AbsVal] -- A constructed product of values - | Bot + | Bot -- Bot'tom included for convenience + -- we could use appropriate Tuple Vals deriving Show +-- For pretty debugging instance Outputable AbsVal where ppr Top = ptext SLIT("Top") ppr (Tuple la) = ptext SLIT("Tuple ") <> text "[" <> @@ -73,10 +83,11 @@ 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 l r = pprPanic "CPR lub:" $ hsep [ppr l, ppr r] \end{code} +The environment maps Ids to their abstract CPR value. + \begin{code} type CPREnv = VarEnv AbsVal @@ -89,7 +100,7 @@ Programs ~~~~~~~~ Take a list of core bindings and return a new list with CPR function -ids decorated with their CprInfo pragmas. +ids decorated with their CprInfo pragmas. \begin{code} @@ -106,29 +117,14 @@ cprAnalyse binds where do_prog :: [CoreBind] -> [CoreBind] do_prog binds - = fin_binds - where - (fin_cprenv, fin_binds) - = foldl cprAnalBinds (initCPREnv, []) binds - - cprAnalBinds :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind]) - cprAnalBinds (rho,done_binds) bind - = (rho', done_binds ++ [bind']) + = snd $ foldl analBind (initCPREnv, []) binds + where + analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind]) + analBind (rho,done_binds) bind + = (extendVarEnvList rho env, done_binds ++ [bind']) where - bind' = cprAnalBind rho bind - -- Need to add CPR info to the environment for the top level - -- vars we just processed. It seems a waste to go back in - -- and transform the decoration back to a absval, but maybe its - -- not so bad .... - rho' = addTopBindsInfo rho bind' - - addTopBindsInfo :: CPREnv -> CoreBind -> CPREnv - addTopBindsInfo rho (NonRec v e) - = extendVarEnv rho v $ ( cprInfoToAbs . getIdCprInfo ) v - addTopBindsInfo rho (Rec bounders) - = extendVarEnvList rho $ map (\(v,e) -> - (v, (cprInfoToAbs . getIdCprInfo) v)) - bounders + (env, bind') = cprAnalTopBind rho bind + \end{code} The cprAnal functions take binds/expressions and an environment which @@ -137,37 +133,47 @@ with ids decorated with their CPR info. \begin{code} -- Return environment updated with info from this binding -cprAnalBind :: CPREnv -> CoreBind -> CoreBind -cprAnalBind rho (NonRec v e) - = NonRec (addCpr v e_pluscpr e_absval) e_pluscpr +cprAnalTopBind :: CPREnv -> CoreBind -> ([(Var, AbsVal)], CoreBind) +cprAnalTopBind rho (NonRec v e) + = ([(v', e_absval')], NonRec v' e_pluscpr) where (e_pluscpr, e_absval) = cprAnalExpr rho e + (v', e_absval') = pinCPR v e e_absval -- When analyzing mutually recursive bindings the iterations to find -- a fixpoint is bounded by the number of bindings in the group. -- for simplicity we just iterate that number of times. -cprAnalBind rho (Rec bounders) - = Rec (map (addRecBindsInfo fin_rho) fin_bounders) +cprAnalTopBind rho (Rec bounders) + = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders', + Rec fin_bounders') where - init_rho = rho `extendVarEnvList` - (zip (map fst bounders) (repeat Bot)) + init_rho = rho `extendVarEnvList` (zip binders (repeat Bot)) + binders = map fst bounders + (fin_rho, fin_bounders) = ntimes (length bounders) do_one_pass (init_rho, bounders) - --- Updates a binder's CprInfo -addRecBindsInfo :: CPREnv -> (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr) -addRecBindsInfo rho (b,e) - = (addCpr b e (lookupVarEnv_NF rho b), e) - + fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e)) + fin_bounders cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) --- Check in rho, if not there it must be imported, so check the var's idinfo +-- 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 -> (cprInfoToAbs . getIdCprInfo) v) + Nothing -> getCprPragInfo v) + 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 + case (maybeUnfoldingTemplate.getIdUnfolding) v of + Just e -> if isCon e then snd $ cprAnalExpr rho e + else ids_inf + _other -> ids_inf + _other -> ids_inf -- Return constructor with decorated arguments. If constructor -- has product type then this is a manifest constructor (hooray!) @@ -199,31 +205,36 @@ cprAnalExpr rho (App fun arg) (arg_cpr, arg_aval) = cprAnalExpr rho arg -- 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) where (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body cprAnalExpr rho (Let (NonRec binder rhs) body) - = (Let (NonRec (addCpr binder rhs_cpr rhs_aval) rhs_cpr) body_cpr, body_aval) + = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval) where (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs - (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval) body + (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval + (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body cprAnalExpr rho (Let (Rec bounders) body) - = (Let (Rec $ map (addRecBindsInfo rhs_rho) fin_bounders) body_cpr, body_aval) + = (Let (Rec fin_bounders) body_cpr, body_aval) where (rhs_rho, fin_bounders) = ntimes (length bounders) do_one_pass (init_rho, bounders) + (body_cpr, body_aval) = cprAnalExpr rhs_rho body - init_rho = rho `extendVarEnvList` - zip (map fst bounders) (repeat Bot) + init_rho = rho `extendVarEnvList` zip binders (repeat Bot) + binders = map fst bounders + cprAnalExpr rho (Case scrut bndr alts) - = (Case scrut_cpr (addCpr bndr scrut_cpr scrut_aval) alts_cpr, alts_aval) + = (Case scrut_cpr bndr alts_cpr, alts_aval) where (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts @@ -251,31 +262,79 @@ cprAnalCaseAlts rho alts -- Does one analysis pass through a list of mutually recursive bindings. do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)]) do_one_pass (i_rho,bounders) - = foldl (\(c_rho,done) (b,e) -> - let (e', e_absval) = cprAnalExpr c_rho e in - (modifyVarEnv (const e_absval) c_rho b, done ++ [(b,e')])) - (i_rho, []) bounders - -cprDecorate :: Id -> AbsVal -> Id -cprDecorate v aval = setIdCprInfo v $ absToCprInfo aval - --- Decorate var with CPR info only if: --- . It has a CPR value, and --- . It is a function with correct number of explicit lambdas --- at the head of its body (so that laziness isn't lost) -addCpr :: Var -> CoreExpr -> AbsVal -> Var -addCpr v e aval - | isCprVal aval = case argtys of - [] -> v - _ -> - if length argtys == length val_binders - then cprDecorate v $ cprFilter (aval,resty) - else v - | otherwise = v + = foldl anal_bind (i_rho, []) bounders + where + anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b, + done ++ [(b,e')]) + where (e', e_absval) = cprAnalExpr c_rho e + e_absval' = snd (pinCPR b e e_absval) + + +-- 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 + +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 + -- 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 + -- 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 + -- 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) where - (_, argtys, resty) = splitTypeToFunArgAndRes (varType v) - -- val_binders are the explicit lambdas at the head of the expression - (_,val_binders,_) = collectTyAndValBinders e + -- 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, _result_type) = splitTypeToFunArgAndRes v_type + v_is_fn = argtys /= [] + -- val_binders are the explicit lambdas at the head of the expression + (binders,_stripped_exp) = collectBinders e + val_binders = filter (not.isTyVar) binders + +filterAbsTuple :: (AbsVal, Type) -> AbsVal +filterAbsTuple (av@(Tuple args), ty) + = case split_ty of + Nothing -> Top + Just (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) -> + if isNewTyCon tycon then + ASSERT ( null $ tail inst_con_arg_tys ) + filterAbsTuple (av, head inst_con_arg_tys) + else + Tuple $ map filterAbsTuple $ zipEqual "cprFilter" args inst_con_arg_tys + where + split_ty = case splitAlgTyConApp_maybe ty of + Just (arg_tycon, tycon_arg_tys, [data_con]) -> + -- The main event: a single-constructor data type + Just (data_con, arg_tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys) + Just (_, _, data_cons) -> + pprPanic "cprFilter:" (text "not one constructor" $$ ppr ty) + -- hmmm, Isn't this a panic too? + Nothing -> Nothing +filterAbsTuple (av, _) = av absToCprInfo :: AbsVal -> CprInfo absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args @@ -284,57 +343,69 @@ absToCprInfo _ = NoCPRInfo cprInfoToAbs :: CprInfo -> AbsVal cprInfoToAbs NoCPRInfo = Top cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args - --- If a CPR component is actually a function then map it to NoCPRInfo -cprFilter :: (AbsVal, Type) -> AbsVal -cprFilter (aval@(Tuple args),ty) - = case split_ty of - Nothing -> Top - Just (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) -> - if isNewTyCon tycon then - ASSERT ( null $ tail inst_con_arg_tys ) - cprFilter (aval, head inst_con_arg_tys) - else - Tuple $ map cprFilter $ zipEqual "cprFilter" args inst_con_arg_tys - where - split_ty = case (splitAlgTyConApp_maybe ty) of - Just (arg_tycon, tycon_arg_tys, [data_con]) -> - -- The main event: a single-constructor data type - Just (data_con, arg_tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys) - - Just (_, _, data_cons) -> - pprPanic ("cprFilter:") - (text "not one constructor" - $$ ppr ty) - Nothing -> - Nothing - -cprFilter (v, _) = v +\end{code} +%************************************************************************ +%* * +\subsection{Utilities} +%* * +%************************************************************************ --- Returns True iff abstract value shows a constructed product -isCprVal :: AbsVal -> Bool -isCprVal (Tuple _) = True -isCprVal _ = False -\end{code} +Now we define a couple of functions that split up types, they should +be moved to Type.lhs if it is agreed that they are doing something +that is sensible. \begin{code} -- Split a function type into forall tyvars, argument types and result type. -- If the type isn't a function type then tyvars and argument types will be --- empty lists +-- empty lists. + +-- Experimental, look through new types. I have given up on this for now, +-- if the target of a function is a new type which is a function (see monadic +-- functions for examples) we could look into these. However, it turns out that +-- the (necessary) coercions in the code stop the beneficial simplifications. splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type) -splitTypeToFunArgAndRes ty = (tyvars, {- pprTrace "splitTypeToFunArgAndRes" (ppr tyvars <> ppr argtys <> ppr resty) -} argtys, resty) +splitTypeToFunArgAndRes ty = (tyvars, argtys, resty) where (tyvars, funty) = splitForAllTys ty - (argtys, resty) = splitFunTys funty + (argtys, resty) = splitFunTysIgnoringNewTypes funty +-- (argtys, resty) = splitFunTys funty + +-- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes +-- Should move to Type.lhs if it is doing something sensible. +splitFunTysIgnoringNewTypes :: Type -> ([Type], Type) +splitFunTysIgnoringNewTypes ty = split [] ty ty + where + split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty ty + = case splitAlgTyConApp_maybe ty of + Just (arg_tycon, tycon_arg_tys, [data_con]) -> + let [inst_con_arg_ty] = dataConArgTys data_con tycon_arg_tys in + if (isNewTyCon arg_tycon) then + {- pprTrace "splitFunTysIgnoringNewTypes:" + (ppr arg_tycon <+> text "from type" <+> ppr inst_con_arg_ty) + -} + (split args orig_ty inst_con_arg_ty) + else + (reverse args, orig_ty) + Nothing -> (reverse args, orig_ty) + -- Is this the constructor for a product type (i.e. algebraic, single constructor) isConProdType :: Con -> Bool -isConProdType (DataCon con) = isProductTyCon (dataConTyCon con) +isConProdType (DataCon con) = isProductTyCon tycon && not (isUnLiftedTyCon tycon) + where + tycon = dataConTyCon con isConProdType _ = False +-- returns True iff head of expression is a constructor +-- Should I look through notes? +isCon :: CoreExpr -> Bool +isCon (Con c _) = isWHNFCon c -- is this the right test? +isCon _ = False \end{code} \begin{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index de7f7d2..7d68fc9 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -25,7 +25,7 @@ import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon ) import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys, - splitForAllTys, splitFunTysN, + splitForAllTys, splitFunTys, splitFunTysN, splitAlgTyConApp_maybe, mkTyConApp, Type ) @@ -440,7 +440,7 @@ mk_cpr_case (ty, cpr_info@(CPRInfo ci_args)) | isNewTyCon tycon -- a new type: under the coercions must be a -- constructed product = ASSERT ( null $ tail inst_con_arg_tys ) - mk_cpr_case (head inst_con_arg_tys, cpr_info) + mk_cpr_case (target_of_from_type, cpr_info) `thenUs` \(arg, tup, exp) -> getUniqueUs `thenUs` \id_uniq -> let id_id = mk_ww_local id_uniq ty @@ -466,6 +466,9 @@ mk_cpr_case (ty, cpr_info@(CPRInfo ci_args)) returnUs (id_id, new_tup, new_exp_case) where (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_case" ty + from_type = head inst_con_arg_tys + -- if coerced from a function 'look through' to find result type + target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type \end{code} @@ -499,7 +502,7 @@ mk_cpr_let (ty, NoCPRInfo) mk_cpr_let (ty, cpr_info@(CPRInfo ci_args)) | isNewTyCon tycon -- a new type: must coerce the argument to this type = ASSERT ( null $ tail inst_con_arg_tys ) - mk_cpr_let (head inst_con_arg_tys, cpr_info) + mk_cpr_let (target_of_from_type, cpr_info) `thenUs` \(arg, tup, exp) -> getUniqueUs `thenUs` \id_uniq -> let id_id = mk_ww_local id_uniq ty @@ -521,6 +524,10 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args)) returnUs (id_id, new_tup, new_exp) where (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_let" ty + from_type = head inst_con_arg_tys + -- if coerced from a function 'look through' to find result type + target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type + splitType :: String -> Type -> (DataCon, TyCon, [Type], [Type]) splitType fname ty = (data_con, tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys) -- 1.7.10.4