X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcprAnalysis%2FCprAnalyse.lhs;h=cbc28442ea2faf5dc132170e6c17c7a95a87520c;hb=1a03162e0239a336d297383107a68d06814e8924;hp=be1c7481bd1afb7adfb21dace5015cd7fe5b3b3f;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index be1c748..cbc2844 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -2,29 +2,28 @@ 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 ( exprIsValue ) -import CoreUnfold ( maybeUnfoldingTemplate ) -import Var ( Var, Id, TyVar, idType, varName, varType ) -import Id ( setIdCprInfo, idCprInfo, idArity, - isBottomingId ) +import Id ( Id, setIdCprInfo, idCprInfo, idArity, + isBottomingId, idDemandInfo, isImplicitId ) import IdInfo ( CprInfo(..) ) +import Demand ( isStrict ) import VarEnv -import Type ( Type, splitFunTys, splitFunTy_maybe, splitForAllTys ) -import TyCon ( isNewTyCon, isUnLiftedTyCon ) -import DataCon ( dataConTyCon ) -import Util ( zipEqual, zipWithEqual, nTimes, mapAccumL ) +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 @@ -97,10 +96,6 @@ data AbsVal = Top -- Not a constructed product -- 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") @@ -140,15 +135,13 @@ ids decorated with their CprInfo pragmas. \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] @@ -163,18 +156,21 @@ with ids decorated with their CPR info. -- 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) = cprAnalRhs rho e - b' = setIdCprInfo b (absToCprInfo absval) + (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' = setIdCprInfo b (absToCprInfo absval) - (e', absval) = cprAnalRhs final_rho e + 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. @@ -183,18 +179,12 @@ cprAnalBind rho (Rec prs) 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 (cprAnalRhs rho e))) + do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e))) rho prs -cprAnalRhs :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal) -cprAnalRhs rho e - = case cprAnalExpr rho e of - (e_pluscpr, e_absval) -> (e_pluscpr, pinCPR e e_absval) - 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. @@ -271,56 +261,47 @@ cprAnalCaseAlts rho alts rho' = rho `extendVarEnvList` (zip binds (repeat Top)) --- 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 :: CoreExpr -> AbsVal -> AbsVal -pinCPR e av = case av of - -- is v a function with insufficent lambdas? - Fun _ | n_fun_tys av /= 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 - -- constructor 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 - Top - - Tuple | exprIsValue e -> av - | otherwise -> 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 -> 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 - _ -> av - where - n_fun_tys :: AbsVal -> Int - n_fun_tys (Fun av) = 1 + n_fun_tys av - n_fun_tys other = 0 + _ -> False + + n_fun_tys :: AbsVal -> Int + n_fun_tys (Fun av) = 1 + n_fun_tys av + n_fun_tys other = 0 - -- val_binders are the explicit lambdas at the head of the expression - -- Don't get confused by inline pragamas - val_binders = filter isId (fst (collectBindersIgnoringNotes e)) 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 @@ -330,4 +311,5 @@ getCprAbsVal v = case idCprInfo v of 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}