--- /dev/null
+\section[CprAnalyse]{Identify functions that always return a
+constructed product result}
+
+\begin{code}
+#ifndef OLD_STRICTNESS
+module CprAnalyse ( ) where
+
+#else
+
+module CprAnalyse ( cprAnalyse ) where
+
+#include "HsVersions.h"
+
+import DynFlags ( DynFlags, DynFlag(..) )
+import CoreLint ( showPass, endPass )
+import CoreSyn
+import CoreUtils ( exprIsHNF )
+import Id ( Id, setIdCprInfo, idCprInfo, idArity,
+ isBottomingId, idDemandInfo, isImplicitId )
+import IdInfo ( CprInfo(..) )
+import Demand ( isStrict )
+import VarEnv
+import Util ( nTimes, mapAccumL )
+import Outputable
+
+import Maybe
+\end{code}
+
+This module performs an analysis of a set of Core Bindings for the
+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@.
+
+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.
+
+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.
+
+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 -- 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 (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 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
+
+initCPREnv = emptyVarEnv
+
+\end{code}
+
+Programs
+~~~~~~~~
+
+Take a list of core bindings and return a new list with CPR function
+ids decorated with their CprInfo pragmas.
+
+\begin{code}
+
+cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
+cprAnalyse dflags binds
+ = do {
+ showPass dflags "Constructed Product analysis" ;
+ let { binds_plus_cpr = do_prog binds } ;
+ endPass dflags "Constructed Product analysis"
+ Opt_D_dump_cpranal binds_plus_cpr
+ }
+ where
+ do_prog :: [CoreBind] -> [CoreBind]
+ do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
+\end{code}
+
+The cprAnal functions take binds/expressions and an environment which
+gives CPR info for visible ids and returns a new bind/expression
+with ids decorated with their CPR info.
+
+\begin{code}
+-- 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
+
+
+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)
+ | 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
+ (fun_cpr, fun_res) = cprAnalExpr rho fun
+
+cprAnalExpr rho (App fun 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, 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 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)
+ 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, expr_aval)
+ where
+ (exp_cpr, expr_aval) = cprAnalExpr rho exp
+
+cprAnalExpr rho (Type t)
+ = (Type t, Top)
+
+cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
+cprAnalCaseAlts rho alts
+ = foldr anal_alt ([], Bot) alts
+ where
+ 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))
+
+
+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 -> 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
+
+
+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