From: simonmar Date: Mon, 3 Apr 2000 12:50:26 +0000 (+0000) Subject: [project @ 2000-04-03 12:50:25 by simonmar] X-Git-Tag: Approximately_9120_patches~4860 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7558fd1e56bd50a251a26066ec92e39f56d8fa9d;p=ghc-hetmet.git [project @ 2000-04-03 12:50:25 by simonmar] Finally retire the update analyser. --- diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index cf7ed63..77cc791 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -221,7 +221,6 @@ data CoreToDo -- These are diff core-to-core passes, \begin{code} data StgToDo = StgDoStaticArgs - | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling -- should be (next to) last -- There's also setStgVarInfo, but its absolute "lastness" @@ -492,7 +491,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-fcpr-analyse" -> CORE_TD(CoreDoCPResult) "-fstg-static-args" -> STG_TD(StgDoStaticArgs) - "-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis) "-dstg-stats" -> STG_TD(D_stg_stats) "-flambda-lift" -> STG_TD(StgDoLambdaLift) "-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling) diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 268621b..2b57998 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -16,7 +16,6 @@ import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) -import UpdAnal ( updateAnalyse ) import SRT ( computeSRTs ) import CmdLineOpts ( opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, @@ -92,13 +91,6 @@ stg2stg stg_todos module_name us binds case to_do of StgDoStaticArgs -> panic "STG static argument transformation deleted" - StgDoUpdateAnalysis -> - _scc_ "StgUpdAnal" - -- NB We have to do setStgVarInfo first! (There's one - -- place free-var info is used) But no let-no-escapes, - -- because update analysis doesn't care. - end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds)) - D_stg_stats -> trace (showStgStats binds) end_pass us2 "StgStats" ccs binds diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs deleted file mode 100644 index b79ea19..0000000 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ /dev/null @@ -1,562 +0,0 @@ -\section{Update Avoidance Analyser} - -(c) Simon Marlow, Andre Santos 1992-1993 -(c) The AQUA Project, Glasgow University, 1995-1998 - -%----------------------------------------------------------------------------- -\subsection{Module Interface} - - -\begin{code} -module UpdAnal ( updateAnalyse ) where - -#include "HsVersions.h" - -import Prelude hiding ( lookup ) - -import StgSyn -import VarEnv -import VarSet -import Id ( mkSysLocal, - idUpdateInfo, setIdUpdateInfo, idType, - externallyVisibleId, - Id - ) -import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe ) -import Name ( isLocallyDefined ) -import Type ( splitFunTys, splitSigmaTy ) -import Unique ( getBuiltinUniques ) -import Panic ( panic ) -\end{code} - - -%----------------------------------------------------------------------------- -\subsection{Reverse application} - -This is used instead of lazy pattern bindings to avoid space leaks. - -\begin{code} -infixr 3 =: -a =: k = k a -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Types} - -List of closure references - -\begin{code} -type Refs = IdSet -x `notInRefs` y = not (x `elemVarSet` y) -\end{code} - -A closure value: environment of closures that are evaluated on entry, -a list of closures that are referenced from the result, and an -abstract value for the evaluated closure. - -An IdEnv is used for the reference counts, as these environments are -combined often. A generic environment is used for the main environment -mapping closure names to values; as a common operation is extension of -this environment, this representation should be efficient. - -\begin{code} --- partain: funny synonyms to cope w/ the fact --- that IdEnvs know longer know what their keys are --- (94/05) ToDo: improve -type IdEnvInt = IdEnv (Id, Int) -type IdEnvClosure = IdEnv (Id, Closure) - --- backward-compat functions -null_IdEnv :: IdEnv (Id, a) -null_IdEnv = emptyVarEnv - -unit_IdEnv :: Id -> a -> IdEnv (Id, a) -unit_IdEnv k v = unitVarEnv k (k, v) - -mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a) -mk_IdEnv pairs = mkVarEnv [ (k, (k,v)) | (k,v) <- pairs ] - -grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) -grow_IdEnv env1 env2 = plusVarEnv env1 env2 - -addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a) -addOneTo_IdEnv env k v = extendVarEnv env k (k, v) - -combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) -combine_IdEnvs combiner env1 env2 = plusVarEnv_C new_combiner env1 env2 - where - new_combiner (id, x) (_, y) = (id, combiner x y) - -dom_IdEnv :: IdEnv (Id, a) -> Refs -dom_IdEnv env = mkVarSet [ i | (i,_) <- rngVarEnv env ] - -lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a -lookup_IdEnv env key = case lookupVarEnv env key of - Nothing -> Nothing - Just (_,a) -> Just a --- end backward compat stuff - -type Closure = (IdEnvInt, Refs, AbFun) - -type AbVal = IdEnvClosure -> Closure -newtype AbFun = Fun (Closure -> Closure) - --- partain: speeding-up stuff - -type CaseBoundVars = IdSet -noCaseBound = emptyVarSet -isCaseBound = elemVarSet -x `notCaseBound` y = not (isCaseBound x y) -moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars -moreCaseBound old new = old `unionVarSet` mkVarSet new - --- end speeding-up -\end{code} - -%---------------------------------------------------------------------------- -\subsection{Environment lookup} - -If the requested value is not in the environment, we return an unknown -value. Lookup is designed to be partially applied to a variable, and -repeatedly applied to different environments after that. - -\begin{code} -lookup v - | isLocallyDefined v - = \p -> case lookup_IdEnv p v of - Just b -> b - Nothing -> unknownClosure - - | otherwise - = const (case updateInfoMaybe (idUpdateInfo v) of - Nothing -> unknownClosure - Just spec -> convertUpdateSpec spec) -\end{code} - -%----------------------------------------------------------------------------- -Represent a list of references as an ordered list. - -\begin{code} -mkRefs :: [Id] -> Refs -mkRefs = mkVarSet - -noRefs :: Refs -noRefs = emptyVarSet - -elemRefs = elemVarSet - -merge :: [Refs] -> Refs -merge xs = foldr merge2 emptyVarSet xs - -merge2 :: Refs -> Refs -> Refs -merge2 = unionVarSet -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Some non-interesting values} - -bottom will be used for abstract values that are not functions. -Hopefully its value will never be required! - -\begin{code} -bottom :: AbFun -bottom = panic "Internal: (Update Analyser) bottom" -\end{code} - -noClosure is a value that is definitely not a function (i.e. primitive -values and constructor applications). unknownClosure is a value about -which we have no information at all. This should occur rarely, but -could happen when an id is imported and the exporting module was not -compiled with the update analyser. - -\begin{code} -noClosure, unknownClosure :: Closure -noClosure = (null_IdEnv, noRefs, bottom) -unknownClosure = (null_IdEnv, noRefs, dont_know noRefs) -\end{code} - -dont_know is a black hole: it is something we know nothing about. -Applying dont_know to anything will generate a new dont_know that simply -contains more buried references. - -\begin{code} -dont_know :: Refs -> AbFun -dont_know b' - = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b' - in (null_IdEnv, b'', dont_know b'')) -\end{code} - ------------------------------------------------------------------------------ - -\begin{code} -getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs -getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs)) - where - getrefs' [] = [] - getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs -\end{code} - ------------------------------------------------------------------------------ - -udData is used when we are putting a list of closure references into a -data structure, or something else that we know nothing about. - -\begin{code} -udData :: [StgArg] -> CaseBoundVars -> AbVal -udData vs cvs - = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) - where local_ids = [ lookup v | StgVarArg v <- vs, v `notCaseBound` cvs ] -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Analysing an atom} - -\begin{code} -udVar :: CaseBoundVars -> Id -> AbVal -udVar cvs v | v `isCaseBound` cvs = const unknownClosure - | otherwise = lookup v - -udAtom :: CaseBoundVars -> StgArg -> AbVal -udAtom cvs (StgVarArg v) = udVar cvs v -udAtom cvs _ = const noClosure -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Analysing an STG expression} - -\begin{code} -ud :: StgExpr -- Expression to be analysed - -> CaseBoundVars -- List of case-bound vars - -> IdEnvClosure -- Current environment - -> (StgExpr, AbVal) -- (New expression, abstract value) - -ud e@(StgLit _) cvs p = (e, udData [] cvs) -ud e@(StgConApp _ vs) cvs p = (e, udData vs cvs) -ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs) -ud e@(StgSCC lab a) cvs p = ud a cvs p =: \(a', abval_a) -> - (StgSCC lab a', abval_a) -\end{code} - -Here is application. The first thing to do is analyse the head, and -get an abstract function. Multiple applications are performed by using -a foldl with the function doApp. Closures are actually passed to the -abstract function iff the atom is a local variable. - -I've left the type signature for doApp in to make things a bit clearer. - -\begin{code} -ud e@(StgApp a atoms) cvs p - = (e, abval_app) - where - abval_atoms = map (udAtom cvs) atoms - abval_a = udVar cvs a - abval_app = \p -> - let doApp :: Closure -> AbVal -> Closure - doApp (c, b, Fun f) abval_atom = - abval_atom p =: \e@(_,_,_) -> - f e =: \(c', b', f') -> - (combine_IdEnvs (+) c' c, b', f') - in foldl doApp (abval_a p) abval_atoms - -ud (StgCase expr lve lva bndr srt alts) cvs p - = ud expr cvs p =: \(expr', abval_selector) -> - udAlt alts p =: \(alts', abval_alts) -> - let - abval_case = \p -> - abval_selector p =: \(c, b, abfun_selector) -> - abval_alts p =: \(cs, bs, abfun_alts) -> - let bs' = b `merge2` bs in - (combine_IdEnvs (+) c cs, bs', dont_know bs') - in - (StgCase expr' lve lva bndr srt alts', abval_case) - where - - alts_cvs = moreCaseBound cvs [bndr] - - udAlt :: StgCaseAlts - -> IdEnvClosure - -> (StgCaseAlts, AbVal) - - udAlt (StgAlgAlts ty [alt] StgNoDefault) p - = udAlgAlt p alt =: \(alt', abval) -> - (StgAlgAlts ty [alt'] StgNoDefault, abval) - udAlt (StgAlgAlts ty [] def) p - = udDef def p =: \(def', abval) -> - (StgAlgAlts ty [] def', abval) - udAlt (StgAlgAlts ty alts def) p - = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p - udAlt (StgPrimAlts ty [alt] StgNoDefault) p - = udPrimAlt p alt =: \(alt', abval) -> - (StgPrimAlts ty [alt'] StgNoDefault, abval) - udAlt (StgPrimAlts ty [] def) p - = udDef def p =: \(def', abval) -> - (StgPrimAlts ty [] def', abval) - udAlt (StgPrimAlts ty alts def) p - = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p - - udPrimAlt p (l, e) - = ud e alts_cvs p =: \(e', v) -> ((l, e'), v) - - udAlgAlt p (id, vs, use_mask, e) - = ud e (moreCaseBound alts_cvs vs) p - =: \(e', v) -> ((id, vs, use_mask, e'), v) - - udDef :: StgCaseDefault - -> IdEnvClosure - -> (StgCaseDefault, AbVal) - - udDef StgNoDefault p - = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs)) - udDef (StgBindDefault expr) p - = ud expr alts_cvs p =: \(expr', abval) -> - (StgBindDefault expr', abval) - - udManyAlts alts def udalt stgalts p - = udDef def p =: \(def', abval_def) -> - unzip (map (udalt p) alts) =: \(alts', abvals_alts) -> - let - abval_alts = \p -> - abval_def p =: \(cd, bd, _) -> - unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) -> - let bs' = merge (bd:bs) in - (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs') - in (stgalts alts' def', abval_alts) -\end{code} - -The heart of the analysis: here we decide whether to make a specific -closure updatable or not, based on the results of analysing the body. - -\begin{code} -ud (StgLet binds body) cvs p - = udBinding binds cvs p =: \(binds', vs, abval1, abval2) -> - abval1 p =: \(cs, p') -> - grow_IdEnv p p' =: \p -> - ud body cvs p =: \(body', abval_body) -> - abval_body p =: \(c, b, abfun) -> - tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds -> - let - abval p - = abval2 p =: \(c1, p') -> - abval_body (grow_IdEnv p p') =: \(c2, b, abfun) -> - (combine_IdEnvs (+) c1 c2, b, abfun) - in - (StgLet tagged_binds body', abval) -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Analysing bindings} - -For recursive sets of bindings we perform one iteration of a fixed -point algorithm, using (dont_know fv) as a safe approximation to the -real fixed point, where fv are the (mappings in the environment of -the) free variables of the function. - -We'll return two new environments, one with the new closures in and -one without. There's no point in carrying around closures when their -respective bindings have already been analysed. - -We don't need to find anything out about closures with arguments, -constructor closures etc. - -\begin{code} -udBinding :: StgBinding - -> CaseBoundVars - -> IdEnvClosure - -> (StgBinding, - [Id], - IdEnvClosure -> (IdEnvInt, IdEnvClosure), - IdEnvClosure -> (IdEnvInt, IdEnvClosure)) - -udBinding (StgNonRec v rhs) cvs p - = udRhs rhs cvs p =: \(rhs', abval) -> - abval p =: \(c, b, abfun) -> - let - abval_rhs a = \p -> - abval p =: \(c, b, abfun) -> - (c, unit_IdEnv v (a, b, abfun)) - a = case rhs of - StgRhsClosure _ _ _ _ Updatable [] _ -> unit_IdEnv v 1 - _ -> null_IdEnv - in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv) - -udBinding (StgRec ve) cvs p - = (StgRec ve', [], abval_rhs, abval_rhs) - where - (vs, ve', abvals) = unzip3 (map udBind ve) - fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve - vs' = mkRefs vs - abval_rhs = \p -> - let - p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p - closure = (null_IdEnv, fv', dont_know fv') - fv' = getrefs p fv vs' - (cs, ps) = unzip (doRec vs abvals) - - doRec [] _ = [] - doRec (v:vs) (abval:as) - = abval p' =: \(c,b,abfun) -> - (c, (v,(null_IdEnv, b, abfun))) : doRec vs as - - in - (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps) - - udBind (v,rhs) - = udRhs rhs cvs p =: \(rhs', abval) -> - (v,(v,rhs'), abval) - - collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv - collectfv (_, StgRhsCon _ con args) = [ v | StgVarArg v <- args ] -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Analysing Right-Hand Sides} - -\begin{code} -udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs) - -udRhs (StgRhsClosure cc bi srt fv u [] body) cvs p - = ud body cvs p =: \(body', abval_body) -> - (StgRhsClosure cc bi srt fv u [] body', abval_body) -\end{code} - -Here is the code for closures with arguments. A closure has a number -of arguments, which correspond to a set of nested lambda expressions. -We build up the analysis using foldr with the function doLam to -analyse each lambda expression. - -\begin{code} -udRhs (StgRhsClosure cc bi srt fv u args body) cvs p - = ud body cvs p =: \(body', abval_body) -> - let - fv' = map lookup (filter (`notCaseBound` cvs) fv) - abval_rhs = \p -> - foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p - in - (StgRhsClosure cc bi srt fv u args body', abval_rhs) - where - - doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal - doLam i f b p - = (null_IdEnv, b, - Fun (\x@(c',b',_) -> - let b'' = dom_IdEnv c' `merge2` b' `merge2` b in - f b'' (addOneTo_IdEnv p i x))) -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Adjusting Update flags} - -The closure is tagged single entry iff it is used at most once, it is -not referenced from inside a data structure or function, and it has no -arguments (closures with arguments are re-entrant). - -\begin{code} -tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding - -tag b c r@(StgNonRec v (StgRhsClosure cc bi srt fv Updatable [] body)) - = if (v `notInRefs` b) && (lookupc c v <= 1) - then -- trace "One!" ( - StgNonRec v (StgRhsClosure cc bi srt fv SingleEntry [] body) - -- ) - else r -tag b c other = other - -lookupc c v = case lookup_IdEnv c v of - Just n -> n - Nothing -> 0 -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Top Level analysis} - -Should we tag top level closures? This could have good implications -for CAFs (i.e. they could be made non-updateable if only used once, -thus preventing a space leak). - -\begin{code} -updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -} -updateAnalyse bs - = udProgram bs null_IdEnv - -udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding] -udProgram [] p = [] -udProgram (d:ds) p - = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) -> - abval_bind p =: \(_, p') -> - grow_IdEnv p p' =: \p'' -> - attachUpdateInfoToBinds d' p'' =: \d'' -> - d'' : udProgram ds p'' -\end{code} - -%----------------------------------------------------------------------------- -\subsection{Exporting Update Information} - -Convert the exported representation of a function's update function -into a real Closure value. - -\begin{code} -convertUpdateSpec :: UpdateSpec -> Closure -convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs - -mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure - -mkClosure c b b' [] = (c, b', dont_know b') -mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns)) -mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> - mkClosure - (combine_IdEnvs (+) c c') - (dom_IdEnv c' `merge2` b'' `merge2` b) - (b'' `merge2` b') - ns )) -mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> - mkClosure c - (dom_IdEnv c' `merge2` b'' `merge2` b) - (dom_IdEnv c' `merge2` b'' `merge2` b') - ns )) -\end{code} - -Convert a Closure into a representation that can be placed in a .hi file. - -\begin{code} -mkUpdateSpec :: Id -> Closure -> UpdateSpec -mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids) - where - (c,b,_) = foldl doApp f ids - ids = map mkid (getBuiltinUniques arity) - mkid u = mkSysLocal SLIT("upd") u noType - countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 - noType = panic "UpdAnal: no type!" - - doApp (c,b,Fun f) i - = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') -> - (combine_IdEnvs (+) c' c, b', f') - - (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v - (reg_arg_tys, _) = splitFunTys tau_ty - arity = length dict_tys + length reg_arg_tys -\end{code} - - removeSuperfluous2s = reverse . dropWhile (> 1) . reverse - -%----------------------------------------------------------------------------- -\subsection{Attaching the update information to top-level bindings} - -This is so that the information can later be retrieved for printing -out in the .hi file. This is not an ideal solution, however it will -suffice for now. - -\begin{code} -attachUpdateInfoToBinds b p - = case b of - StgNonRec v rhs -> StgNonRec (attachOne v) rhs - StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] - - where attachOne v - | externallyVisibleId v - = let c = lookup v p in - setIdUpdateInfo v - (mkUpdateInfo (mkUpdateSpec v c)) - | otherwise = v -\end{code} - -%----------------------------------------------------------------------------- diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 77c505d..a8af730 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -677,12 +677,6 @@ The (outwards-)let-floater should be the {\em last} Core-to-Core pass that's run. (Um, well, howzabout the simplifier just once more...) \end{description} -STG-TO-STG PASSES: -\begin{description} -\item[\tr{-fupdate-analysis}:] -It really really wants to be the last STG-to-STG pass that is run. -\end{description} - \begin{code} sub setupOptimiseFlags { @@ -835,8 +829,7 @@ sub setupOptimiseFlags { # SPECIAL FLAGS for -O2 ($OptLevel == 2) ? ( - '-fupdate-analysis', # virtually useless; relegated to -O2 - '-fsemi-tagging', + # none at the present time ) : (), );