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 CmdLineOpts ( DynFlags, DynFlag(..) )
+import CoreLint ( showPass, endPass )
import CoreSyn
-import CoreUtils ( coreExprType )
-import Var ( Var, Id, TyVar, idType, varName, varType )
-import Id ( setIdCprInfo, getIdCprInfo )
+import CoreUtils ( exprIsValue )
+import Id ( Id, setIdCprInfo, idCprInfo, idArity,
+ isBottomingId, idDemandInfo, isImplicitId )
import IdInfo ( CprInfo(..) )
+import Demand ( isStrict )
import VarEnv
-import Type ( Type, splitFunTys, splitForAllTys, splitTyConApp_maybe,
- splitAlgTyConApp_maybe )
-import TyCon ( maybeTyConSingleCon, isProductTyCon, isNewTyCon )
-import DataCon ( dataConTyCon, dataConArgTys )
-import Const
-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
-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.
+
+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
~~~~~~~~~~
-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.
-Since functions abstract to constant functions we can just
-represent their result. It is not necessary to model functions
-directly.
+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.
+
+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
- | Bot
- deriving Show
+ | 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 (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 l r = pprPanic "CPR lub:" $ hsep [ppr l, ppr 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}
+The environment maps Ids to their abstract CPR value.
+
\begin{code}
type CPREnv = VarEnv AbsVal
~~~~~~~~
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}
-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
- = 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'])
- 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
+ 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
-cprAnalBind :: CPREnv -> CoreBind -> CoreBind
-cprAnalBind rho (NonRec v e)
- = NonRec (addCpr v e_pluscpr e_absval) e_pluscpr
- where
- (e_pluscpr, e_absval) = cprAnalExpr rho e
+-- 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
--- 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)
- where
- init_rho = rho `extendVarEnvList`
- (zip (map fst bounders) (repeat Bot))
- (fin_rho, fin_bounders) = ntimes (length bounders)
- do_one_pass
- (init_rho, bounders)
+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]
--- Updates a binder's CprInfo
-addRecBindsInfo :: CPREnv -> (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr)
-addRecBindsInfo rho (b,e)
- = (addCpr b e (lookupVarEnv_NF rho b), e)
+ do_one_pass :: CPREnv -> CPREnv
+ do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
+ rho prs
cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
--- Check in rho, if not there it must be imported, so check the var's idinfo
+-- 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 -> (cprInfoToAbs . getIdCprInfo) v)
-
--- 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)
-cprAnalExpr rho (Lam b body)
- = (Lam b body_cpr, body_aval)
+-- Return the abstract value of the body, since functions
+-- 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 (addCpr binder rhs_cpr rhs_aval) 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
-
-cprAnalExpr rho (Let (Rec bounders) body)
- = (Let (Rec $ map (addRecBindsInfo rhs_rho) 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)
+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 (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
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 (\(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
- where
- (_, argtys, resty) = splitTypeToFunArgAndRes (varType v)
- -- val_binders are the explicit lambdas at the head of the expression
- (_,val_binders,_) = collectTyAndValBinders e
-
-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
-
--- 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
-
-
--- Returns True iff abstract value shows a constructed product
-isCprVal :: AbsVal -> Bool
-isCprVal (Tuple _) = True
-isCprVal _ = False
-
-\end{code}
-
-\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
-splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
-splitTypeToFunArgAndRes ty = (tyvars, {- pprTrace "splitTypeToFunArgAndRes" (ppr tyvars <> ppr argtys <> ppr resty) -} argtys, resty)
- where (tyvars, funty) = splitForAllTys ty
- (argtys, resty) = splitFunTys funty
-
--- Is this the constructor for a product type (i.e. algebraic, single constructor)
-isConProdType :: Con -> Bool
-isConProdType (DataCon con) = isProductTyCon (dataConTyCon con)
-isConProdType _ = False
+addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
+addIdCprInfo bndr rhs absval
+ | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
+ | otherwise = bndr
+ where
+ 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 -> exprIsValue 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
-\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
+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