constructed product result}
\begin{code}
+#ifndef OLD_STRICTNESS
+module CprAnalyse ( ) where
+
+#else
+
module CprAnalyse ( cprAnalyse ) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal )
-import CoreLint ( beginPass, endPass )
+import DynFlags ( DynFlags, DynFlag(..) )
+import CoreLint ( showPass, endPass )
import CoreSyn
-import CoreUtils ( coreExprType )
-import CoreUnfold ( maybeUnfoldingTemplate )
-import Var ( Var, Id, TyVar, idType, varName, varType )
-import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding )
+import CoreUtils ( exprIsHNF )
+import Id ( Id, setIdCprInfo, idCprInfo, idArity,
+ isBottomingId, idDemandInfo, isImplicitId )
import IdInfo ( CprInfo(..) )
+import Demand ( isStrict )
import VarEnv
-import Type ( Type, splitFunTys, splitForAllTys, splitNewType_maybe )
-import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
-import DataCon ( dataConTyCon, splitProductType_maybe )
-import Const ( Con(DataCon), isWHNFCon )
-import Util ( zipEqual, zipWithEqual )
+import Util ( nTimes, mapAccumL )
import Outputable
-import UniqFM (ufmToList)
-
+import Maybe
\end{code}
This module performs an analysis of a set of Core Bindings for 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
- | Tuple [AbsVal] -- A constructed product of values
+
+ | Fun AbsVal -- A function that takes an argument
+ -- and gives AbsVal as result.
+
+ | Tuple -- A constructed product of values
+
| Bot -- Bot'tom included for convenience
-- we could use appropriate Tuple Vals
- deriving Show
+ deriving (Eq,Show)
-- For pretty debugging
instance Outputable AbsVal where
- ppr Top = ptext SLIT("Top")
- ppr (Tuple la) = ptext SLIT("Tuple ") <> text "[" <>
- (hsep (punctuate comma (map ppr la))) <>
- text "]"
- ppr Bot = ptext SLIT("Bot")
+ ppr Top = ptext SLIT("Top")
+ ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
+ ppr Tuple = ptext SLIT("Tuple ")
+ 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 Tuple Tuple = Tuple
+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}
\begin{code}
-cprAnalyse :: [CoreBind]
- -> IO [CoreBind]
-cprAnalyse binds
+cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
+cprAnalyse dflags binds
= do {
- beginPass "Constructed Product analysis" ;
+ showPass dflags "Constructed Product analysis" ;
let { binds_plus_cpr = do_prog binds } ;
- endPass "Constructed Product analysis"
- (opt_D_dump_cpranal || opt_D_verbose_core2core)
- binds_plus_cpr
+ endPass dflags "Constructed Product analysis"
+ Opt_D_dump_cpranal binds_plus_cpr
}
where
do_prog :: [CoreBind] -> [CoreBind]
- do_prog binds
- = snd $ foldl analBind (initCPREnv, []) binds
- where
- analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind])
- analBind (rho,done_binds) bind
- = (extendVarEnvList rho env, done_binds ++ [bind'])
- where
- (env, bind') = cprAnalTopBind rho bind
-
+ do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
\end{code}
The cprAnal functions take binds/expressions and an environment which
with ids decorated with their CPR info.
\begin{code}
--- Return environment updated with info from this binding
-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.
-cprAnalTopBind rho (Rec bounders)
- = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders',
- Rec fin_bounders')
- where
- init_rho = rho `extendVarEnvList` (zip binders (repeat Bot))
- binders = map fst bounders
+-- Return environment extended with info from this binding
+cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
+cprAnalBind rho (NonRec b e)
+ | isImplicitId b -- Don't touch the CPR info on constructors, selectors etc
+ = (rho, NonRec b e)
+ | otherwise
+ = (extendVarEnv rho b absval, NonRec b' e')
+ where
+ (e', absval) = cprAnalExpr rho e
+ b' = addIdCprInfo b e' absval
+
+cprAnalBind rho (Rec prs)
+ = (final_rho, Rec (map do_pr prs))
+ where
+ do_pr (b,e) = (b', e')
+ where
+ b' = addIdCprInfo b e' absval
+ (e', absval) = cprAnalExpr final_rho e
+
+ -- 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.
+ final_rho = nTimes (length prs) do_one_pass init_rho
+ init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
+
+ do_one_pass :: CPREnv -> CPREnv
+ do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
+ rho prs
- (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))
- fin_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)
- 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
- zz_other -> ids_inf
- zz_other -> 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
- else Top)
+ | isBottomingId v = (e, Bot)
+ | otherwise = (e, case lookupVarEnv rho v of
+ Just a_val -> a_val
+ Nothing -> getCprAbsVal v)
+
+-- Literals are unboxed
+cprAnalExpr rho (Lit l) = (Lit l, Top)
+
+-- 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
- (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).
+ (fun_cpr, fun_res) = cprAnalExpr rho fun
+
cprAnalExpr rho (App fun arg)
- = (App fun_cpr arg_cpr, res_aval)
- where
- (fun_cpr, res_aval) = cprAnalExpr rho fun
- (arg_cpr, arg_aval) = cprAnalExpr rho arg
+ = (App fun_cpr arg_cpr, res_res)
+ where
+ (fun_cpr, fun_res) = cprAnalExpr rho fun
+ (arg_cpr, _) = cprAnalExpr rho arg
+ res_res = case fun_res of
+ Fun res_res -> res_res
+ Top -> Top
+ Bot -> Bot
+ Tuple -> WARN( True, ppr (App fun arg) ) Top
+ -- This really should not happen!
+
-- 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
-cprAnalExpr rho (Let (NonRec binder rhs) body)
- = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval)
- where
- (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs
- (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 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 binders (repeat Bot)
- binders = map fst bounders
-
+cprAnalExpr rho (Let bind body)
+ = (Let bind' body', body_aval)
+ where
+ (rho', bind') = cprAnalBind rho bind
+ (body', body_aval) = cprAnalExpr rho' body
cprAnalExpr rho (Case scrut bndr alts)
= (Case scrut_cpr bndr alts_cpr, alts_aval)
(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)
-
cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
cprAnalCaseAlts rho alts
- = foldl anal_alt ([], Bot) alts
+ = foldr anal_alt ([], Bot) alts
where
- anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
- anal_alt (done, aval) (con, binds, exp)
- = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
+ anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
+ anal_alt (con, binds, exp) (done, aval)
+ = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
rho' = rho `extendVarEnvList` (zip binds (repeat Top))
--- 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 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
- -- 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 /= []
- -- 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
-
-absToCprInfo :: AbsVal -> CprInfo
-absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
-absToCprInfo _ = NoCPRInfo
-
-cprInfoToAbs :: CprInfo -> AbsVal
-cprInfoToAbs NoCPRInfo = Top
-cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Utilities}
-%* *
-%************************************************************************
-
-
-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.
-
--- 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, argtys, resty)
- where (tyvars, funty) = splitForAllTys ty
- (argtys, resty) = splitFunTysIgnoringNewTypes funty
--- (argtys, resty) = splitFunTys funty
-
--- splitFunTys, 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
+addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
+addIdCprInfo bndr rhs absval
+ | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
+ | otherwise = bndr
where
- split ty = case splitNewType_maybe res of
- Nothing -> (args, res)
- Just rep_ty -> (args ++ args', res')
- where
- (args', res') = split rep_ty
- where
- (args, res) = splitFunTys 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 _ = 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}
+ cpr_info = absToCprInfo absval
+ useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
+
+ ok_to_add = case absval of
+ Fun _ -> idArity bndr >= n_fun_tys absval
+ -- Enough visible lambdas
+
+ Tuple -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
+ -- If the rhs is a value, and returns a constructed product,
+ -- it will be inlined at usage sites, so we give it a Tuple absval
+ -- If it isn't a value, we won't inline it (code/work dup worries), so
+ -- we discard its absval.
+ --
+ -- Also, if the strictness analyser has figured out that it's strict,
+ -- the let-to-case transformation will happen, so again it's good.
+ -- (CPR analysis runs before the simplifier has had a chance to do
+ -- the let-to-case transform.)
+ -- This made a big difference to PrelBase.modInt, which had something like
+ -- modInt = \ x -> let r = ... -> I# v in
+ -- ...body strict in r...
+ -- r's RHS isn't a value yet; but modInt returns r in various branches, so
+ -- if r doesn't have the CPR property then neither does modInt
+
+ _ -> False
+
+ n_fun_tys :: AbsVal -> Int
+ n_fun_tys (Fun av) = 1 + n_fun_tys av
+ n_fun_tys other = 0
-\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
+absToCprInfo :: AbsVal -> CprInfo
+absToCprInfo Tuple = ReturnsCPR
+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.
+getCprAbsVal v = case idCprInfo v of
+ NoCPRInfo -> Top
+ ReturnsCPR -> nTimes arity Fun Tuple
+ where
+ arity = idArity v
+ -- Imported (non-nullary) constructors will have the CPR property
+ -- in their IdInfo, so no need to look at their unfolding
+#endif /* OLD_STRICTNESS */
\end{code}
projects / ghc-hetmet.git / blobdiff