1 % (c) The University of Glasgow 2006
3 \section[CprAnalyse]{Identify functions that always return a
4 constructed product result}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 #ifndef OLD_STRICTNESS
15 module CprAnalyse ( ) where
19 module CprAnalyse ( cprAnalyse ) where
21 #include "HsVersions.h"
37 This module performs an analysis of a set of Core Bindings for the
38 Constructed Product Result (CPR) transformation.
40 It detects functions that always explicitly (manifestly?) construct a
41 result value with a product type. A product type is a type which has
42 only one constructor. For example, tuples and boxed primitive values
45 We must also ensure that the function's body starts with sufficient
46 manifest lambdas otherwise loss of sharing can occur. See the comment
49 The transformation of bindings to worker/wrapper pairs is done by the
50 worker-wrapper pass. The worker-wrapper pass splits bindings on the
51 basis of both strictness and CPR info. If an id has both then it can
52 combine the transformations so that only one pair is produced.
54 The analysis here detects nested CPR information. For example, if a
55 function returns a constructed pair, the first element of which is a
56 constructed int, then the analysis will detect nested CPR information
57 for the int as well. Unfortunately, the current transformations can't
58 take advantage of the nested CPR information. They have (broken now,
59 I think) code which will flatten out nested CPR components and rebuild
60 them in the wrapper, but enabling this would lose laziness. It is
61 possible to make use of the nested info: if we knew that a caller was
62 strict in that position then we could create a specialized version of
63 the function which flattened/reconstructed that position.
65 It is not known whether this optimisation would be worthwhile.
67 So we generate and carry round nested CPR information, but before
68 using this info to guide the creation of workers and wrappers we map
69 all components of a CPRInfo to NoCprInfo.
75 Within this module Id's CPR information is represented by
76 ``AbsVal''. When adding this information to the Id's pragma info field
77 we convert the ``Absval'' to a ``CprInfo'' value.
79 Abstract domains consist of a `no information' value (Top), a function
80 value (Fun) which when applied to an argument returns a new AbsVal
81 (note the argument is not used in any way), , for product types, a
82 corresponding length tuple (Tuple) of abstract values. And finally,
83 Bot. Bot is not a proper abstract value but a generic bottom is
84 useful for calculating fixpoints and representing divergent
85 computations. Note that we equate Bot and Fun^n Bot (n > 0), and
86 likewise for Top. This saves a lot of delving in types to keep
87 everything exactly correct.
89 Since functions abstract to constant functions we could just
90 represent them by the abstract value of their result. However, it
91 turns out (I know - I tried!) that this requires a lot of type
92 manipulation and the code is more straightforward if we represent
93 functions by an abstract constant function.
96 data AbsVal = Top -- Not a constructed product
98 | Fun AbsVal -- A function that takes an argument
99 -- and gives AbsVal as result.
101 | Tuple -- A constructed product of values
103 | Bot -- Bot'tom included for convenience
104 -- we could use appropriate Tuple Vals
107 -- For pretty debugging
108 instance Outputable AbsVal where
109 ppr Top = ptext SLIT("Top")
110 ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
111 ppr Tuple = ptext SLIT("Tuple ")
112 ppr Bot = ptext SLIT("Bot")
115 -- lub takes the lowest upper bound of two abstract values, standard.
116 lub :: AbsVal -> AbsVal -> AbsVal
121 lub Tuple Tuple = Tuple
122 lub (Fun l) (Fun r) = Fun (lub l r)
123 lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
128 The environment maps Ids to their abstract CPR value.
132 type CPREnv = VarEnv AbsVal
134 initCPREnv = emptyVarEnv
141 Take a list of core bindings and return a new list with CPR function
142 ids decorated with their CprInfo pragmas.
146 cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
147 cprAnalyse dflags binds
149 showPass dflags "Constructed Product analysis" ;
150 let { binds_plus_cpr = do_prog binds } ;
151 endPass dflags "Constructed Product analysis"
152 Opt_D_dump_cpranal binds_plus_cpr
155 do_prog :: [CoreBind] -> [CoreBind]
156 do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
159 The cprAnal functions take binds/expressions and an environment which
160 gives CPR info for visible ids and returns a new bind/expression
161 with ids decorated with their CPR info.
164 -- Return environment extended with info from this binding
165 cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
166 cprAnalBind rho (NonRec b e)
167 | isImplicitId b -- Don't touch the CPR info on constructors, selectors etc
170 = (extendVarEnv rho b absval, NonRec b' e')
172 (e', absval) = cprAnalExpr rho e
173 b' = addIdCprInfo b e' absval
175 cprAnalBind rho (Rec prs)
176 = (final_rho, Rec (map do_pr prs))
178 do_pr (b,e) = (b', e')
180 b' = addIdCprInfo b e' absval
181 (e', absval) = cprAnalExpr final_rho e
183 -- When analyzing mutually recursive bindings the iterations to find
184 -- a fixpoint is bounded by the number of bindings in the group.
185 -- for simplicity we just iterate that number of times.
186 final_rho = nTimes (length prs) do_one_pass init_rho
187 init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
189 do_one_pass :: CPREnv -> CPREnv
190 do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
194 cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
196 -- If Id will always diverge when given sufficient arguments then
197 -- we can just set its abs val to Bot. Any other CPR info
198 -- from other paths will then dominate, which is what we want.
199 -- Check in rho, if not there it must be imported, so check
201 cprAnalExpr rho e@(Var v)
202 | isBottomingId v = (e, Bot)
203 | otherwise = (e, case lookupVarEnv rho v of
205 Nothing -> getCprAbsVal v)
207 -- Literals are unboxed
208 cprAnalExpr rho (Lit l) = (Lit l, Top)
210 -- For apps we don't care about the argument's abs val. This
211 -- app will return a constructed product if the function does. We strip
212 -- a Fun from the functions abs val, unless the argument is a type argument
213 -- or it is already Top or Bot.
214 cprAnalExpr rho (App fun arg@(Type _))
215 = (App fun_cpr arg, fun_res)
217 (fun_cpr, fun_res) = cprAnalExpr rho fun
219 cprAnalExpr rho (App fun arg)
220 = (App fun_cpr arg_cpr, res_res)
222 (fun_cpr, fun_res) = cprAnalExpr rho fun
223 (arg_cpr, _) = cprAnalExpr rho arg
224 res_res = case fun_res of
225 Fun res_res -> res_res
228 Tuple -> WARN( True, ppr (App fun arg) ) Top
229 -- This really should not happen!
232 -- Map arguments to Top (we aren't constructing them)
233 -- Return the abstract value of the body, since functions
234 -- are represented by the CPR value of their result, and
235 -- add a Fun for this lambda..
236 cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
237 | otherwise = (Lam b body_cpr, Fun body_aval)
239 (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
241 cprAnalExpr rho (Let bind body)
242 = (Let bind' body', body_aval)
244 (rho', bind') = cprAnalBind rho bind
245 (body', body_aval) = cprAnalExpr rho' body
247 cprAnalExpr rho (Case scrut bndr alts)
248 = (Case scrut_cpr bndr alts_cpr, alts_aval)
250 (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
251 (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
253 cprAnalExpr rho (Note n exp)
254 = (Note n exp_cpr, expr_aval)
256 (exp_cpr, expr_aval) = cprAnalExpr rho exp
258 cprAnalExpr rho (Type t)
261 cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
262 cprAnalCaseAlts rho alts
263 = foldr anal_alt ([], Bot) alts
265 anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
266 anal_alt (con, binds, exp) (done, aval)
267 = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
268 where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
269 rho' = rho `extendVarEnvList` (zip binds (repeat Top))
272 addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
273 addIdCprInfo bndr rhs absval
274 | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
277 cpr_info = absToCprInfo absval
278 useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
280 ok_to_add = case absval of
281 Fun _ -> idArity bndr >= n_fun_tys absval
282 -- Enough visible lambdas
284 Tuple -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
285 -- If the rhs is a value, and returns a constructed product,
286 -- it will be inlined at usage sites, so we give it a Tuple absval
287 -- If it isn't a value, we won't inline it (code/work dup worries), so
288 -- we discard its absval.
290 -- Also, if the strictness analyser has figured out that it's strict,
291 -- the let-to-case transformation will happen, so again it's good.
292 -- (CPR analysis runs before the simplifier has had a chance to do
293 -- the let-to-case transform.)
294 -- This made a big difference to PrelBase.modInt, which had something like
295 -- modInt = \ x -> let r = ... -> I# v in
296 -- ...body strict in r...
297 -- r's RHS isn't a value yet; but modInt returns r in various branches, so
298 -- if r doesn't have the CPR property then neither does modInt
302 n_fun_tys :: AbsVal -> Int
303 n_fun_tys (Fun av) = 1 + n_fun_tys av
307 absToCprInfo :: AbsVal -> CprInfo
308 absToCprInfo Tuple = ReturnsCPR
309 absToCprInfo (Fun r) = absToCprInfo r
310 absToCprInfo _ = NoCPRInfo
313 -- Cpr Info doesn't store the number of arguments a function has, so the caller
314 -- must take care to add the appropriate number of Funs.
315 getCprAbsVal v = case idCprInfo v of
317 ReturnsCPR -> nTimes arity Fun Tuple
320 -- Imported (non-nullary) constructors will have the CPR property
321 -- in their IdInfo, so no need to look at their unfolding
322 #endif /* OLD_STRICTNESS */