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 CoreUnfold ( maybeUnfoldingTemplate )
-import Var ( Var, Id, TyVar, idType, varName, varType )
-import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding, getIdArity,
- isBottomingId )
-import IdInfo ( CprInfo(..), arityLowerBound )
+import CoreUtils ( exprIsValue )
+import Id ( Id, setIdCprInfo, idCprInfo, idArity,
+ isBottomingId, idDemandInfo, isImplicitId )
+import IdInfo ( CprInfo(..) )
+import Demand ( isStrict )
import VarEnv
-import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys, splitNewType_maybe )
-import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
-import DataCon ( dataConTyCon, splitProductType_maybe, dataConRawArgTys )
-import Const ( Con(DataCon), isDataCon, isWHNFCon )
-import Util ( zipEqual, zipWithEqual )
+import Util ( nTimes, mapAccumL )
import Outputable
-import UniqFM (ufmToList)
import Maybe
-import PprType( pprType ) -- Only called in debug messages
\end{code}
This module performs an analysis of a set of Core Bindings for the
\begin{code}
data AbsVal = Top -- Not a constructed product
+
| Fun AbsVal -- A function that takes an argument
-- and gives AbsVal as result.
- | Tuple [AbsVal] -- A constructed product of values
+
+ | Tuple -- A constructed product of values
+
| Bot -- Bot'tom included for convenience
-- we could use appropriate Tuple Vals
deriving (Eq,Show)
-isFun :: AbsVal -> Bool
-isFun (Fun _) = True
-isFun _ = False
-
-- For pretty debugging
instance Outputable AbsVal where
- ppr Top = ptext SLIT("Top")
- ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
- 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 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"
\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
- (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
+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
-cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, 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.
+ 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.
| isBottomingId v = (e, Bot)
| otherwise = (e, case lookupVarEnv rho v of
Just a_val -> a_val
- Nothing -> cpr_prag_a_val)
- where
- ids_inf = (cprInfoToAbs.getIdCprInfo) v
- ids_arity = (arityLowerBound.getIdArity) v
- cpr_prag_a_val = case ids_inf of
- Top -> -- if we can inline this var, and its a constructor app
- -- then analyse the unfolding
- case (maybeUnfoldingTemplate.getIdUnfolding) v of
- Just e | isCon e -> snd $ cprAnalExpr rho e
- zz_other -> Top
- zz_other -> -- Unfortunately, cprinfo doesn't store the # of args
- nTimes ids_arity Fun 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,
- if isConProdType con
- then Tuple args_aval_filt_funs
- else Top)
- where
- anal_con_args = map (cprAnalExpr rho) args
- args_cpr = map fst anal_con_args
+ Nothing -> getCprAbsVal v)
- args_aval_filt_funs = if (not.isDataCon) con then
- map snd anal_con_args
- else
- map (ifApply isFun (const Top)) $
- map snd $
- filter (not.isTypeArg.fst) anal_con_args
+-- 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
-- or it is already Top or Bot.
cprAnalExpr rho (App fun arg@(Type _))
= (App fun_cpr arg, fun_res)
- where
+ where
(fun_cpr, fun_res) = cprAnalExpr rho fun
cprAnalExpr rho (App fun arg)
- = (App fun_cpr arg_cpr, if fun_res==Top || fun_res==Bot
- then fun_res
- else res_res)
- where
+ = (App fun_cpr arg_cpr, res_res)
+ where
(fun_cpr, fun_res) = cprAnalExpr rho fun
(arg_cpr, _) = cprAnalExpr rho arg
- Fun res_res = fun_res
+ 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
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)
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
--- Also we pin the var's CPR property to it. A var only has the CPR property if
--- it is a function
-
-pinCPR :: Var -> CoreExpr -> AbsVal -> (Var, AbsVal)
-pinCPR v e av = case av of
- -- is v a function with insufficent lambdas?
- Fun _ | length argtys /= length val_binders ->
- -- argtys must be greater than val_binders. So stripped_exp
- -- has a function type. The head of this expr can't be lambda
- -- a note, because we stripped them off before. It can't be a
- -- Con because it has a function type. It can't be a Type.
- -- If its an app, let or case then there is work to get the
- -- and we can't do anything because we may lose laziness. *But*
- -- if its a var (i.e. a function name) then we are fine. Note
- -- that I don't think this case is at all interesting, but I have
- -- a test program that generates it.
-
- -- UPDATE: 20 Jul 1999
- -- I've decided not to allow this (useless) optimisation. It will make
- -- the w/w split more complex.
- -- if isVar stripped_exp then
- -- (addCpr av, av)
- -- else
- (addCpr Top, Top)
- Tuple _ ->
- -- 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 (WHNF). 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,
- -- 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 av else Top)
- _ -> (addCpr av, av)
- where
- -- func to pin CPR info on a var
- addCpr :: AbsVal -> Var
- addCpr = (setIdCprInfo v).absToCprInfo
-
- -- Split argument types and result type from v's type
- (_, argtys, _) = (splitTypeToFunArgAndRes.varType) v
-
- -- val_binders are the explicit lambdas at the head of the expression
- (_, val_binders, _) = collectTyAndValBinders e -- collectBindersIgnoringNotes e'
+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
absToCprInfo :: AbsVal -> CprInfo
-absToCprInfo (Tuple args) = CPRInfo $ map absToCprInfo args
-absToCprInfo (Fun r) = absToCprInfo r
-absToCprInfo _ = NoCPRInfo
+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.
-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
- 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 . dataConTyCon $ con
-isConProdType _ = False
-
--- returns True iff head of expression is a constructor
--- Should I look through notes? I think so ...
-isCon :: CoreExpr -> Bool
-isCon (Con c _) = isWHNFCon c -- is this the right test?
-isCon (Note _n e) = isCon e
-isCon _ = False
-
--- Compose a function with itself n times. (nth rather than twice)
--- This must/should be in a library somewhere, but where!
-nTimes :: Int -> (a -> a) -> (a -> a)
-nTimes 0 _ = id
-nTimes 1 f = f
-nTimes n f = f . nTimes (n-1) f
-
--- Only apply f to argument if it satisfies p
-ifApply :: (a -> Bool) -> (a -> a) -> (a -> a)
-ifApply p f x = if p x then f x else x
-
+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}