1 \section[CprAnalyse]{Identify functions that always return a
2 constructed product result}
5 module CprAnalyse ( cprAnalyse ) where
7 #include "HsVersions.h"
9 import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal )
10 import CoreLint ( beginPass, endPass )
12 import CoreUtils ( coreExprType )
13 import CoreUnfold ( maybeUnfoldingTemplate )
14 import Var ( Var, Id, TyVar, idType, varName, varType )
15 import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding, getIdArity,
17 import IdInfo ( CprInfo(..), arityLowerBound )
19 import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys, splitNewType_maybe )
20 import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
21 import DataCon ( dataConTyCon, splitProductType_maybe, dataConRawArgTys )
22 import Const ( Con(DataCon), isDataCon, isWHNFCon )
23 import Util ( zipEqual, zipWithEqual )
26 import UniqFM (ufmToList)
28 import PprType( pprType ) -- Only called in debug messages
31 This module performs an analysis of a set of Core Bindings for the
32 Constructed Product Result (CPR) transformation.
34 It detects functions that always explicitly (manifestly?) construct a
35 result value with a product type. A product type is a type which has
36 only one constructor. For example, tuples and boxed primitive values
39 We must also ensure that the function's body starts with sufficient
40 manifest lambdas otherwise loss of sharing can occur. See the comment
43 The transformation of bindings to worker/wrapper pairs is done by the
44 worker-wrapper pass. The worker-wrapper pass splits bindings on the
45 basis of both strictness and CPR info. If an id has both then it can
46 combine the transformations so that only one pair is produced.
48 The analysis here detects nested CPR information. For example, if a
49 function returns a constructed pair, the first element of which is a
50 constructed int, then the analysis will detect nested CPR information
51 for the int as well. Unfortunately, the current transformations can't
52 take advantage of the nested CPR information. They have (broken now,
53 I think) code which will flatten out nested CPR components and rebuild
54 them in the wrapper, but enabling this would lose laziness. It is
55 possible to make use of the nested info: if we knew that a caller was
56 strict in that position then we could create a specialized version of
57 the function which flattened/reconstructed that position.
59 It is not known whether this optimisation would be worthwhile.
61 So we generate and carry round nested CPR information, but before
62 using this info to guide the creation of workers and wrappers we map
63 all components of a CPRInfo to NoCprInfo.
69 Within this module Id's CPR information is represented by
70 ``AbsVal''. When adding this information to the Id's pragma info field
71 we convert the ``Absval'' to a ``CprInfo'' value.
73 Abstract domains consist of a `no information' value (Top), a function
74 value (Fun) which when applied to an argument returns a new AbsVal
75 (note the argument is not used in any way), , for product types, a
76 corresponding length tuple (Tuple) of abstract values. And finally,
77 Bot. Bot is not a proper abstract value but a generic bottom is
78 useful for calculating fixpoints and representing divergent
79 computations. Note that we equate Bot and Fun^n Bot (n > 0), and
80 likewise for Top. This saves a lot of delving in types to keep
81 everything exactly correct.
83 Since functions abstract to constant functions we could just
84 represent them by the abstract value of their result. However, it
85 turns out (I know - I tried!) that this requires a lot of type
86 manipulation and the code is more straightforward if we represent
87 functions by an abstract constant function.
90 data AbsVal = Top -- Not a constructed product
91 | Fun AbsVal -- A function that takes an argument
92 -- and gives AbsVal as result.
93 | Tuple [AbsVal] -- A constructed product of values
94 | Bot -- Bot'tom included for convenience
95 -- we could use appropriate Tuple Vals
98 isFun :: AbsVal -> Bool
102 -- For pretty debugging
103 instance Outputable AbsVal where
104 ppr Top = ptext SLIT("Top")
105 ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
106 ppr (Tuple la) = ptext SLIT("Tuple ") <> text "[" <>
107 (hsep (punctuate comma (map ppr la))) <>
109 ppr Bot = ptext SLIT("Bot")
112 -- lub takes the lowest upper bound of two abstract values, standard.
113 lub :: AbsVal -> AbsVal -> AbsVal
118 lub (Tuple l) (Tuple r) = Tuple (zipWithEqual "CPR: lub" lub l r)
119 lub (Fun l) (Fun r) = Fun (lub l r)
120 lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
125 The environment maps Ids to their abstract CPR value.
129 type CPREnv = VarEnv AbsVal
131 initCPREnv = emptyVarEnv
138 Take a list of core bindings and return a new list with CPR function
139 ids decorated with their CprInfo pragmas.
143 cprAnalyse :: [CoreBind]
147 beginPass "Constructed Product analysis" ;
148 let { binds_plus_cpr = do_prog binds } ;
149 endPass "Constructed Product analysis"
150 (opt_D_dump_cpranal || opt_D_verbose_core2core)
154 do_prog :: [CoreBind] -> [CoreBind]
156 = snd $ foldl analBind (initCPREnv, []) binds
158 analBind :: (CPREnv, [CoreBind]) -> CoreBind -> (CPREnv, [CoreBind])
159 analBind (rho,done_binds) bind
160 = (extendVarEnvList rho env, done_binds ++ [bind'])
162 (env, bind') = cprAnalTopBind rho bind
166 The cprAnal functions take binds/expressions and an environment which
167 gives CPR info for visible ids and returns a new bind/expression
168 with ids decorated with their CPR info.
171 -- Return environment updated with info from this binding
172 cprAnalTopBind :: CPREnv -> CoreBind -> ([(Var, AbsVal)], CoreBind)
173 cprAnalTopBind rho (NonRec v e)
174 = ([(v', e_absval')], NonRec v' e_pluscpr)
176 (e_pluscpr, e_absval) = cprAnalExpr rho e
177 (v', e_absval') = pinCPR v e e_absval
179 -- When analyzing mutually recursive bindings the iterations to find
180 -- a fixpoint is bounded by the number of bindings in the group.
181 -- for simplicity we just iterate that number of times.
182 cprAnalTopBind rho (Rec bounders)
183 = (map (\(b,e) -> (b, lookupVarEnv_NF fin_rho b)) fin_bounders',
186 init_rho = rho `extendVarEnvList` (zip binders (repeat Bot))
187 binders = map fst bounders
189 (fin_rho, fin_bounders) = nTimes (length bounders)
192 fin_bounders' = map (\(b,e) -> (fst $ pinCPR b e (lookupVarEnv_NF fin_rho b), e))
195 cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
198 -- If Id will always diverge when given sufficient arguments then
199 -- we can just set its abs val to Bot. Any other CPR info
200 -- from other paths will then dominate, which is what we want.
201 -- Check in rho, if not there it must be imported, so check
203 cprAnalExpr rho e@(Var v)
204 | isBottomingId v = (e, Bot)
205 | otherwise = (e, case lookupVarEnv rho v of
207 Nothing -> cpr_prag_a_val)
209 ids_inf = (cprInfoToAbs.getIdCprInfo) v
210 ids_arity = (arityLowerBound.getIdArity) v
211 cpr_prag_a_val = case ids_inf of
212 Top -> -- if we can inline this var, and its a constructor app
213 -- then analyse the unfolding
214 case (maybeUnfoldingTemplate.getIdUnfolding) v of
215 Just e | isCon e -> snd $ cprAnalExpr rho e
217 zz_other -> -- Unfortunately, cprinfo doesn't store the # of args
218 nTimes ids_arity Fun ids_inf
220 -- Return constructor with decorated arguments. If constructor
221 -- has product type then this is a manifest constructor (hooray!)
222 cprAnalExpr rho (Con con args)
224 -- If we are a product with 0 args we must be void(like)
225 -- We can't create an unboxed tuple with 0 args for this
226 -- and since Void has only one, constant value it should
227 -- just mean returning a pointer to a pre-existing cell.
228 -- So we won't really gain from doing anything fancy
229 -- and we treat this case as Top.
232 then Tuple args_aval_filt_funs
235 anal_con_args = map (cprAnalExpr rho) args
236 args_cpr = map fst anal_con_args
238 args_aval_filt_funs = if (not.isDataCon) con then
239 map snd anal_con_args
241 map (ifApply isFun (const Top)) $
243 filter (not.isTypeArg.fst) anal_con_args
245 -- For apps we don't care about the argument's abs val. This
246 -- app will return a constructed product if the function does. We strip
247 -- a Fun from the functions abs val, unless the argument is a type argument
248 -- or it is already Top or Bot.
249 cprAnalExpr rho (App fun arg@(Type _))
250 = (App fun_cpr arg, fun_res)
252 (fun_cpr, fun_res) = cprAnalExpr rho fun
254 cprAnalExpr rho (App fun arg)
255 = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot
259 (fun_cpr, fun_res) = cprAnalExpr rho fun
260 (arg_cpr, _) = cprAnalExpr rho arg
261 Fun res_res = fun_res
263 -- Map arguments to Top (we aren't constructing them)
264 -- Return the abstract value of the body, since functions
265 -- are represented by the CPR value of their result, and
266 -- add a Fun for this lambda..
267 cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
268 | otherwise = (Lam b body_cpr, Fun body_aval)
270 (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
272 cprAnalExpr rho (Let (NonRec binder rhs) body)
273 = (Let (NonRec binder' rhs_cpr) body_cpr, body_aval)
275 (rhs_cpr, rhs_aval) = cprAnalExpr rho rhs
276 (binder', rhs_aval') = pinCPR binder rhs_cpr rhs_aval
277 (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho binder rhs_aval') body
279 cprAnalExpr rho (Let (Rec bounders) body)
280 = (Let (Rec fin_bounders) body_cpr, body_aval)
282 (rhs_rho, fin_bounders) = nTimes
287 (body_cpr, body_aval) = cprAnalExpr rhs_rho body
289 init_rho = rho `extendVarEnvList` zip binders (repeat Bot)
290 binders = map fst bounders
293 cprAnalExpr rho (Case scrut bndr alts)
294 = (Case scrut_cpr bndr alts_cpr, alts_aval)
296 (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
297 (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
299 cprAnalExpr rho (Note n exp)
300 = (Note n exp_cpr, expr_aval)
302 (exp_cpr, expr_aval) = cprAnalExpr rho exp
304 cprAnalExpr rho (Type t)
308 cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
309 cprAnalCaseAlts rho alts
310 = foldl anal_alt ([], Bot) alts
312 anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
313 anal_alt (done, aval) (con, binds, exp)
314 = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
315 where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
316 rho' = rho `extendVarEnvList` (zip binds (repeat Top))
319 -- Does one analysis pass through a list of mutually recursive bindings.
320 do_one_pass :: (CPREnv, [(CoreBndr,CoreExpr)]) -> (CPREnv, [(CoreBndr,CoreExpr)])
321 do_one_pass (i_rho,bounders)
322 = foldl anal_bind (i_rho, []) bounders
324 anal_bind (c_rho, done) (b,e) = (modifyVarEnv (const e_absval') c_rho b,
326 where (e', e_absval) = cprAnalExpr c_rho e
327 e_absval' = snd (pinCPR b e e_absval)
330 -- take a binding pair and the abs val calculated from the rhs and
331 -- calculate a new absval taking into account sufficient manifest
333 -- Also we pin the var's CPR property to it. A var only has the CPR property if
336 pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
337 pinCPR v e av = case av of
338 -- is v a function with insufficent lambdas?
339 Fun _ | length argtys /= length val_binders ->
340 -- argtys must be greater than val_binders. So stripped_exp
341 -- has a function type. The head of this expr can't be lambda
342 -- a note, because we stripped them off before. It can't be a
343 -- Con because it has a function type. It can't be a Type.
344 -- If its an app, let or case then there is work to get the
345 -- and we can't do anything because we may lose laziness. *But*
346 -- if its a var (i.e. a function name) then we are fine. Note
347 -- that I don't think this case is at all interesting, but I have
348 -- a test program that generates it.
350 -- UPDATE: 20 Jul 1999
351 -- I've decided not to allow this (useless) optimisation. It will make
352 -- the w/w split more complex.
353 -- if isVar stripped_exp then
359 -- Pin NoInfo to v. If v appears in the interface file then an
360 -- importing module will check to see if it has an unfolding
361 -- with a constructor at its head (WHNF). If it does it will re-analyse
362 -- the folding. I could do the check here, but I don't know if
363 -- the current unfolding info is final.
365 -- Retain CPR info if it has a constructor
366 -- at its head, and thus will be inlined and simplified by
367 -- case of a known constructor
368 if isCon e then av else Top)
371 -- func to pin CPR info on a var
372 addCpr :: AbsVal -> Var
373 addCpr = (setIdCprInfo v).absToCprInfo
375 -- Split argument types and result type from v's type
376 (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v
378 -- val_binders are the explicit lambdas at the head of the expression
379 (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e'
382 absToCprInfo :: AbsVal -> CprInfo
383 absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
384 absToCprInfo (Fun r) = absToCprInfo r
385 absToCprInfo _ = NoCPRInfo
387 -- Cpr Info doesn't store the number of arguments a function has, so the caller
388 -- must take care to add the appropriate number of Funs.
389 cprInfoToAbs :: CprInfo -> AbsVal
390 cprInfoToAbs NoCPRInfo = Top
391 cprInfoToAbs (CPRInfo args) = Tuple $ map cprInfoToAbs args
395 %************************************************************************
397 \subsection{Utilities}
399 %************************************************************************
402 Now we define a couple of functions that split up types, they should
403 be moved to Type.lhs if it is agreed that they are doing something
408 -- Split a function type into forall tyvars, argument types and result type.
409 -- If the type isn't a function type then tyvars and argument types will be
412 -- Experimental, look through new types. I have given up on this for now,
413 -- if the target of a function is a new type which is a function (see monadic
414 -- functions for examples) we could look into these. However, it turns out that
415 -- the (necessary) coercions in the code stop the beneficial simplifications.
416 splitTypeToFunArgAndRes :: Type -> ([TyVar], [Type], Type)
417 splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
418 where (tyvars, funty) = splitForAllTys ty
419 (argtys, resty) = splitFunTysIgnoringNewTypes funty
420 -- (argtys, resty) = splitFunTys funty
422 -- splitFunTys, modified to keep searching through newtypes.
423 -- Should move to Type.lhs if it is doing something sensible.
425 splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
426 splitFunTysIgnoringNewTypes ty = split ty
428 split ty = case splitNewType_maybe res of
429 Nothing -> (args, res)
430 Just rep_ty -> (args ++ args', res')
432 (args', res') = split rep_ty
434 (args, res) = splitFunTys ty
437 -- Is this the constructor for a product type (i.e. algebraic, single constructor)
438 -- NB: isProductTyCon replies 'False' for unboxed tuples
439 isConProdType :: Con -> Bool
440 isConProdType (DataCon con) = isProductTyCon . dataConTyCon $ con
441 isConProdType _ = False
443 -- returns True iff head of expression is a constructor
444 -- Should I look through notes? I think so ...
445 isCon :: CoreExpr -> Bool
446 isCon (Con c _) = isWHNFCon c -- is this the right test?
447 isCon (Note _ e) = isCon e
450 -- Compose a function with itself n times. (nth rather than twice)
451 -- This must/should be in a library somewhere, but where!
452 nTimes :: Int -> (a -> a) -> (a -> a)
455 nTimes n f = f . nTimes (n-1) f
457 -- Only apply f to argument if it satisfies p
458 ifApply :: (a -> Bool) -> (a -> a) -> (a -> a)
459 ifApply p f x = if p x then f x else x