\section{Update Avoidance Analyser}
(c) Simon Marlow, Andre Santos 1992-1993
-(c) The AQUA Project, Glasgow University, 1995-1996
+(c) The AQUA Project, Glasgow University, 1995-1998
%-----------------------------------------------------------------------------
\subsection{Module Interface}
import Prelude hiding ( lookup )
import StgSyn
-import MkId ( mkSysLocal )
-import Id ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
- unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
- IdSet,
- getIdUpdateInfo, addIdUpdateInfo, idType,
+import VarEnv
+import VarSet
+import Id ( mkSysLocal,
+ getIdUpdateInfo, setIdUpdateInfo, idType,
externallyVisibleId,
Id
)
import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
import Name ( isLocallyDefined )
import Type ( splitFunTys, splitSigmaTy )
-import UniqSet
import Unique ( getBuiltinUniques )
-import SrcLoc ( noSrcLoc )
import Util ( panic )
\end{code}
\begin{code}
type Refs = IdSet
-x `notInRefs` y = not (x `elementOfUniqSet` y)
+x `notInRefs` y = not (x `elemVarSet` y)
\end{code}
A closure value: environment of closures that are evaluated on entry,
-- backward-compat functions
null_IdEnv :: IdEnv (Id, a)
-null_IdEnv = nullIdEnv
+null_IdEnv = emptyVarEnv
unit_IdEnv :: Id -> a -> IdEnv (Id, a)
-unit_IdEnv k v = unitIdEnv k (k, v)
+unit_IdEnv k v = unitVarEnv k (k, v)
mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
-mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
+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 = growIdEnv env1 env2
+grow_IdEnv env1 env2 = plusVarEnv env1 env2
addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
-addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v)
+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 = combineIdEnvs new_combiner env1 env2
+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 = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
+dom_IdEnv env = mkVarSet [ i | (i,_) <- rngVarEnv env ]
lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
-lookup_IdEnv env key = case lookupIdEnv env key of
+lookup_IdEnv env key = case lookupVarEnv env key of
Nothing -> Nothing
Just (_,a) -> Just a
-- end backward compat stuff
-- partain: speeding-up stuff
type CaseBoundVars = IdSet
-noCaseBound = emptyUniqSet
-isCaseBound = elementOfUniqSet
+noCaseBound = emptyVarSet
+isCaseBound = elemVarSet
x `notCaseBound` y = not (isCaseBound x y)
moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
-moreCaseBound old new = old `unionUniqSets` mkUniqSet new
+moreCaseBound old new = old `unionVarSet` mkVarSet new
-- end speeding-up
\end{code}
\begin{code}
mkRefs :: [Id] -> Refs
-mkRefs = mkUniqSet
+mkRefs = mkVarSet
noRefs :: Refs
-noRefs = emptyUniqSet
+noRefs = emptyVarSet
-elemRefs = elementOfUniqSet
+elemRefs = elemVarSet
merge :: [Refs] -> Refs
-merge xs = foldr merge2 emptyUniqSet xs
+merge xs = foldr merge2 emptyVarSet xs
merge2 :: Refs -> Refs -> Refs
-merge2 = unionUniqSets
+merge2 = unionVarSet
\end{code}
%-----------------------------------------------------------------------------
\subsection{Analysing an atom}
\begin{code}
-udAtom :: CaseBoundVars -> StgArg -> AbVal
-udAtom cvs (StgVarArg v)
- | v `isCaseBound` cvs = const unknownClosure
- | otherwise = lookup v
+udVar :: CaseBoundVars -> Id -> AbVal
+udVar cvs v | v `isCaseBound` cvs = const unknownClosure
+ | otherwise = lookup v
-udAtom cvs _ = const noClosure
+udAtom :: CaseBoundVars -> StgArg -> AbVal
+udAtom cvs (StgVarArg v) = udVar cvs v
+udAtom cvs _ = const noClosure
\end{code}
%-----------------------------------------------------------------------------
-> IdEnvClosure -- Current environment
-> (StgExpr, AbVal) -- (New expression, abstract value)
-ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs)
-ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) ->
- (StgSCC ty lab a', abval_a)
+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
I've left the type signature for doApp in to make things a bit clearer.
\begin{code}
-ud e@(StgApp a atoms lvs) cvs p
+ud e@(StgApp a atoms) cvs p
= (e, abval_app)
where
abval_atoms = map (udAtom cvs) atoms
- abval_a = udAtom cvs a
+ abval_a = udVar cvs a
abval_app = \p ->
let doApp :: Closure -> AbVal -> Closure
doApp (c, b, Fun f) abval_atom =
(combine_IdEnvs (+) c' c, b', f')
in foldl doApp (abval_a p) abval_atoms
-ud (StgCase expr lve lva uniq alts) cvs p
+ud (StgCase expr lve lva bndr srt alts) cvs p
= ud expr cvs p =: \(expr', abval_selector) ->
udAlt alts p =: \(alts', abval_alts) ->
let
let bs' = b `merge2` bs in
(combine_IdEnvs (+) c cs, bs', dont_know bs')
in
- (StgCase expr' lve lva uniq alts', abval_case)
+ (StgCase expr' lve lva bndr srt alts', abval_case)
where
+ alts_cvs = moreCaseBound cvs [bndr]
+
udAlt :: StgCaseAlts
-> IdEnvClosure
-> (StgCaseAlts, AbVal)
= udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
udPrimAlt p (l, e)
- = ud e cvs p =: \(e', v) -> ((l, e'), v)
+ = ud e alts_cvs p =: \(e', v) -> ((l, e'), v)
udAlgAlt p (id, vs, use_mask, e)
- = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v)
+ = ud e (moreCaseBound alts_cvs vs) p
+ =: \(e', v) -> ((id, vs, use_mask, e'), v)
udDef :: StgCaseDefault
-> IdEnvClosure
udDef StgNoDefault p
= (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
- udDef (StgBindDefault v is_used expr) p
- = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) ->
- (StgBindDefault v is_used expr', abval)
+ 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) ->
abval p =: \(c, b, abfun) ->
(c, unit_IdEnv v (a, b, abfun))
a = case rhs of
- StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1
+ StgRhsClosure _ _ _ _ Updatable [] _ -> unit_IdEnv v 1
_ -> null_IdEnv
in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv)
= udRhs rhs cvs p =: \(rhs', abval) ->
(v,(v,rhs'), abval)
- collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
+ collectfv (_, StgRhsClosure _ _ _ fv _ _ _) = fv
collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ]
\end{code}
\begin{code}
udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
-udRhs (StgRhsClosure cc bi fv u [] body) cvs p
+udRhs (StgRhsClosure cc bi srt fv u [] body) cvs p
= ud body cvs p =: \(body', abval_body) ->
- (StgRhsClosure cc bi fv u [] 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
analyse each lambda expression.
\begin{code}
-udRhs (StgRhsClosure cc bi fv u args body) cvs p
+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 fv u args body', abval_rhs)
+ (StgRhsClosure cc bi srt fv u args body', abval_rhs)
where
doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
\begin{code}
tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
-tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
+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 fv SingleEntry [] body)
+ StgNonRec v (StgRhsClosure cc bi srt fv SingleEntry [] body)
-- )
else r
tag b c other = other
where
(c,b,_) = foldl doApp f ids
ids = map mkid (getBuiltinUniques arity)
- mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc
+ mkid u = mkSysLocal u noType
countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
noType = panic "UpdAnal: no type!"
where attachOne v
| externallyVisibleId v
= let c = lookup v p in
- addIdUpdateInfo v
+ setIdUpdateInfo v
(mkUpdateInfo (mkUpdateSpec v c))
| otherwise = v
\end{code}
projects / ghc-hetmet.git / blobdiff