~~~~~~~~~~
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.
+``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
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.
+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.
+ | Fun AbsVal -- A function that takes an argument
+ -- and gives AbsVal as result.
- | Tuple -- A constructed product of values
+ | Tuple -- A constructed product of values
| Bot -- Bot'tom included for convenience
-- we could use appropriate Tuple Vals
-- For pretty debugging
instance Outputable AbsVal where
- ppr Top = ptext SLIT("Top")
- ppr (Fun r) = ptext SLIT("Fun->") <> (parens.ppr) r
+ 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 a Bot = a
lub Top a = Top
lub a Top = Top
-lub Tuple Tuple = Tuple
+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"
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
+ 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
+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
+-- 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)
+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
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.
+ 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
+ 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)
+-- 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)
+ 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
+-- 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
+ = (App fun_cpr arg, fun_res)
+ where
+ (fun_cpr, fun_res) = cprAnalExpr rho fun
-cprAnalExpr rho (App fun arg)
+cprAnalExpr rho (App fun arg)
= (App fun_cpr arg_cpr, res_res)
- where
- (fun_cpr, fun_res) = cprAnalExpr rho fun
+ 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!
+ 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
+-- 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
+ where
(body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
cprAnalExpr rho (Let bind body)
= (Let bind' body', body_aval)
- where
+ 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
+ where
(scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
(alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
-cprAnalExpr rho (Note n exp)
+cprAnalExpr rho (Note n exp)
= (Note n exp_cpr, expr_aval)
where
(exp_cpr, expr_aval) = cprAnalExpr rho exp
-cprAnalExpr rho (Type t)
+cprAnalExpr rho (Type t)
= (Type t, Top)
cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
cprAnalCaseAlts rho alts
= foldr anal_alt ([], Bot) alts
- where
+ 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))
+ = ((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
+ | 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
+ -- 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
-- 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
+ 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 / commitdiff