1 \section{Update Avoidance Analyser} -*-haskell-literate-*-
3 (c) Simon Marlow, Andre Santos 1992-1993
4 (c) The AQUA Project, Glasgow University, 1995-1996
6 %-----------------------------------------------------------------------------
7 \subsection{Module Interface}
11 module UpdAnal ( updateAnalyse ) where
13 #include "HsVersions.h"
15 import Prelude hiding ( lookup )
18 import Id ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
19 unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
21 getIdUpdateInfo, addIdUpdateInfo, mkSysLocal, idType, isImportedId,
25 import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
26 import Type ( splitFunTys, splitSigmaTy )
28 import Unique ( getBuiltinUniques )
29 import SrcLoc ( noSrcLoc )
34 %-----------------------------------------------------------------------------
35 \subsection{Reverse application}
37 This is used instead of lazy pattern bindings to avoid space leaks.
44 %-----------------------------------------------------------------------------
47 List of closure references
51 x `notInRefs` y = not (x `elementOfUniqSet` y)
54 A closure value: environment of closures that are evaluated on entry,
55 a list of closures that are referenced from the result, and an
56 abstract value for the evaluated closure.
58 An IdEnv is used for the reference counts, as these environments are
59 combined often. A generic environment is used for the main environment
60 mapping closure names to values; as a common operation is extension of
61 this environment, this representation should be efficient.
64 -- partain: funny synonyms to cope w/ the fact
65 -- that IdEnvs know longer know what their keys are
66 -- (94/05) ToDo: improve
67 type IdEnvInt = IdEnv (Id, Int)
68 type IdEnvClosure = IdEnv (Id, Closure)
70 -- backward-compat functions
71 null_IdEnv :: IdEnv (Id, a)
72 null_IdEnv = nullIdEnv
74 unit_IdEnv :: Id -> a -> IdEnv (Id, a)
75 unit_IdEnv k v = unitIdEnv k (k, v)
77 mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
78 mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
80 grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
81 grow_IdEnv env1 env2 = growIdEnv env1 env2
83 addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
84 addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v)
86 combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
87 combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2
89 new_combiner (id, x) (_, y) = (id, combiner x y)
91 dom_IdEnv :: IdEnv (Id, a) -> Refs
92 dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
94 lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
95 lookup_IdEnv env key = case lookupIdEnv env key of
98 -- end backward compat stuff
100 type Closure = (IdEnvInt, Refs, AbFun)
102 type AbVal = IdEnvClosure -> Closure
103 data AbFun = Fun (Closure -> Closure)
105 -- partain: speeding-up stuff
107 type CaseBoundVars = IdSet
108 noCaseBound = emptyUniqSet
109 isCaseBound = elementOfUniqSet
110 x `notCaseBound` y = not (isCaseBound x y)
111 moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
112 moreCaseBound old new = old `unionUniqSets` mkUniqSet new
117 %----------------------------------------------------------------------------
118 \subsection{Environment lookup}
120 If the requested value is not in the environment, we return an unknown
121 value. Lookup is designed to be partially applied to a variable, and
122 repeatedly applied to different environments after that.
127 = const (case updateInfoMaybe (getIdUpdateInfo v) of
128 Nothing -> unknownClosure
129 Just spec -> convertUpdateSpec spec)
131 = \p -> case lookup_IdEnv p v of
133 Nothing -> unknownClosure
136 %-----------------------------------------------------------------------------
137 Represent a list of references as an ordered list.
140 mkRefs :: [Id] -> Refs
144 noRefs = emptyUniqSet
146 elemRefs = elementOfUniqSet
148 merge :: [Refs] -> Refs
149 merge xs = foldr merge2 emptyUniqSet xs
151 merge2 :: Refs -> Refs -> Refs
152 merge2 = unionUniqSets
155 %-----------------------------------------------------------------------------
156 \subsection{Some non-interesting values}
158 bottom will be used for abstract values that are not functions.
159 Hopefully its value will never be required!
163 bottom = panic "Internal: (Update Analyser) bottom"
166 noClosure is a value that is definitely not a function (i.e. primitive
167 values and constructor applications). unknownClosure is a value about
168 which we have no information at all. This should occur rarely, but
169 could happen when an id is imported and the exporting module was not
170 compiled with the update analyser.
173 noClosure, unknownClosure :: Closure
174 noClosure = (null_IdEnv, noRefs, bottom)
175 unknownClosure = (null_IdEnv, noRefs, dont_know noRefs)
178 dont_know is a black hole: it is something we know nothing about.
179 Applying dont_know to anything will generate a new dont_know that simply
180 contains more buried references.
183 dont_know :: Refs -> AbFun
185 = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b'
186 in (null_IdEnv, b'', dont_know b''))
189 -----------------------------------------------------------------------------
192 getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs
193 getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs))
196 getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs
199 -----------------------------------------------------------------------------
201 udData is used when we are putting a list of closure references into a
202 data structure, or something else that we know nothing about.
205 udData :: [StgArg] -> CaseBoundVars -> AbVal
207 = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
208 where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ]
211 %-----------------------------------------------------------------------------
212 \subsection{Analysing an atom}
215 udAtom :: CaseBoundVars -> StgArg -> AbVal
216 udAtom cvs (StgVarArg v)
217 | v `isCaseBound` cvs = const unknownClosure
218 | otherwise = lookup v
220 udAtom cvs _ = const noClosure
223 %-----------------------------------------------------------------------------
224 \subsection{Analysing an STG expression}
227 ud :: StgExpr -- Expression to be analysed
228 -> CaseBoundVars -- List of case-bound vars
229 -> IdEnvClosure -- Current environment
230 -> (StgExpr, AbVal) -- (New expression, abstract value)
232 ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
233 ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs)
234 ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) ->
235 (StgSCC ty lab a', abval_a)
238 Here is application. The first thing to do is analyse the head, and
239 get an abstract function. Multiple applications are performed by using
240 a foldl with the function doApp. Closures are actually passed to the
241 abstract function iff the atom is a local variable.
243 I've left the type signature for doApp in to make things a bit clearer.
246 ud e@(StgApp a atoms lvs) cvs p
249 abval_atoms = map (udAtom cvs) atoms
250 abval_a = udAtom cvs a
252 let doApp :: Closure -> AbVal -> Closure
253 doApp (c, b, Fun f) abval_atom =
254 abval_atom p =: \e@(_,_,_) ->
255 f e =: \(c', b', f') ->
256 (combine_IdEnvs (+) c' c, b', f')
257 in foldl doApp (abval_a p) abval_atoms
259 ud (StgCase expr lve lva uniq alts) cvs p
260 = ud expr cvs p =: \(expr', abval_selector) ->
261 udAlt alts p =: \(alts', abval_alts) ->
264 abval_selector p =: \(c, b, abfun_selector) ->
265 abval_alts p =: \(cs, bs, abfun_alts) ->
266 let bs' = b `merge2` bs in
267 (combine_IdEnvs (+) c cs, bs', dont_know bs')
269 (StgCase expr' lve lva uniq alts', abval_case)
274 -> (StgCaseAlts, AbVal)
276 udAlt (StgAlgAlts ty [alt] StgNoDefault) p
277 = udAlgAlt p alt =: \(alt', abval) ->
278 (StgAlgAlts ty [alt'] StgNoDefault, abval)
279 udAlt (StgAlgAlts ty [] def) p
280 = udDef def p =: \(def', abval) ->
281 (StgAlgAlts ty [] def', abval)
282 udAlt (StgAlgAlts ty alts def) p
283 = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p
284 udAlt (StgPrimAlts ty [alt] StgNoDefault) p
285 = udPrimAlt p alt =: \(alt', abval) ->
286 (StgPrimAlts ty [alt'] StgNoDefault, abval)
287 udAlt (StgPrimAlts ty [] def) p
288 = udDef def p =: \(def', abval) ->
289 (StgPrimAlts ty [] def', abval)
290 udAlt (StgPrimAlts ty alts def) p
291 = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p
294 = ud e cvs p =: \(e', v) -> ((l, e'), v)
296 udAlgAlt p (id, vs, use_mask, e)
297 = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v)
299 udDef :: StgCaseDefault
301 -> (StgCaseDefault, AbVal)
304 = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
305 udDef (StgBindDefault v is_used expr) p
306 = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) ->
307 (StgBindDefault v is_used expr', abval)
309 udManyAlts alts def udalt stgalts p
310 = udDef def p =: \(def', abval_def) ->
311 unzip (map (udalt p) alts) =: \(alts', abvals_alts) ->
314 abval_def p =: \(cd, bd, _) ->
315 unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) ->
316 let bs' = merge (bd:bs) in
317 (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs')
318 in (stgalts alts' def', abval_alts)
321 The heart of the analysis: here we decide whether to make a specific
322 closure updatable or not, based on the results of analysing the body.
325 ud (StgLet binds body) cvs p
326 = udBinding binds cvs p =: \(binds', vs, abval1, abval2) ->
327 abval1 p =: \(cs, p') ->
328 grow_IdEnv p p' =: \p ->
329 ud body cvs p =: \(body', abval_body) ->
330 abval_body p =: \(c, b, abfun) ->
331 tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
334 = abval2 p =: \(c1, p') ->
335 abval_body (grow_IdEnv p p') =: \(c2, b, abfun) ->
336 (combine_IdEnvs (+) c1 c2, b, abfun)
338 (StgLet tagged_binds body', abval)
341 %-----------------------------------------------------------------------------
342 \subsection{Analysing bindings}
344 For recursive sets of bindings we perform one iteration of a fixed
345 point algorithm, using (dont_know fv) as a safe approximation to the
346 real fixed point, where fv are the (mappings in the environment of
347 the) free variables of the function.
349 We'll return two new environments, one with the new closures in and
350 one without. There's no point in carrying around closures when their
351 respective bindings have already been analysed.
353 We don't need to find anything out about closures with arguments,
354 constructor closures etc.
357 udBinding :: StgBinding
362 IdEnvClosure -> (IdEnvInt, IdEnvClosure),
363 IdEnvClosure -> (IdEnvInt, IdEnvClosure))
365 udBinding (StgNonRec v rhs) cvs p
366 = udRhs rhs cvs p =: \(rhs', abval) ->
367 abval p =: \(c, b, abfun) ->
370 abval p =: \(c, b, abfun) ->
371 (c, unit_IdEnv v (a, b, abfun))
373 StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1
375 in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv)
377 udBinding (StgRec ve) cvs p
378 = (StgRec ve', [], abval_rhs, abval_rhs)
380 (vs, ve', abvals) = unzip3 (map udBind ve)
381 fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve
385 p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p
386 closure = (null_IdEnv, fv', dont_know fv')
387 fv' = getrefs p fv vs'
388 (cs, ps) = unzip (doRec vs abvals)
391 doRec (v:vs) (abval:as)
392 = abval p' =: \(c,b,abfun) ->
393 (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
396 (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
399 = udRhs rhs cvs p =: \(rhs', abval) ->
402 collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
403 collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ]
406 %-----------------------------------------------------------------------------
407 \subsection{Analysing Right-Hand Sides}
410 udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
412 udRhs (StgRhsClosure cc bi fv u [] body) cvs p
413 = ud body cvs p =: \(body', abval_body) ->
414 (StgRhsClosure cc bi fv u [] body', abval_body)
417 Here is the code for closures with arguments. A closure has a number
418 of arguments, which correspond to a set of nested lambda expressions.
419 We build up the analysis using foldr with the function doLam to
420 analyse each lambda expression.
423 udRhs (StgRhsClosure cc bi fv u args body) cvs p
424 = ud body cvs p =: \(body', abval_body) ->
426 fv' = map lookup (filter (`notCaseBound` cvs) fv)
428 foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p
430 (StgRhsClosure cc bi fv u args body', abval_rhs)
433 doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
437 let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
438 f b'' (addOneTo_IdEnv p i x)))
441 %-----------------------------------------------------------------------------
442 \subsection{Adjusting Update flags}
444 The closure is tagged single entry iff it is used at most once, it is
445 not referenced from inside a data structure or function, and it has no
446 arguments (closures with arguments are re-entrant).
449 tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
451 tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
452 = if (v `notInRefs` b) && (lookupc c v <= 1)
453 then -- trace "One!" (
454 StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
457 tag b c other = other
459 lookupc c v = case lookup_IdEnv c v of
464 %-----------------------------------------------------------------------------
465 \subsection{Top Level analysis}
467 Should we tag top level closures? This could have good implications
468 for CAFs (i.e. they could be made non-updateable if only used once,
469 thus preventing a space leak).
472 updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
474 = udProgram bs null_IdEnv
476 udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
479 = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) ->
480 abval_bind p =: \(_, p') ->
481 grow_IdEnv p p' =: \p'' ->
482 attachUpdateInfoToBinds d' p'' =: \d'' ->
483 d'' : udProgram ds p''
486 %-----------------------------------------------------------------------------
487 \subsection{Exporting Update Information}
489 Convert the exported representation of a function's update function
490 into a real Closure value.
493 convertUpdateSpec :: UpdateSpec -> Closure
494 convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs
496 mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure
498 mkClosure c b b' [] = (c, b', dont_know b')
499 mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
500 mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
502 (combine_IdEnvs (+) c c')
503 (dom_IdEnv c' `merge2` b'' `merge2` b)
506 mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
508 (dom_IdEnv c' `merge2` b'' `merge2` b)
509 (dom_IdEnv c' `merge2` b'' `merge2` b')
513 Convert a Closure into a representation that can be placed in a .hi file.
516 mkUpdateSpec :: Id -> Closure -> UpdateSpec
517 mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
519 (c,b,_) = foldl doApp f ids
520 ids = map mkid (getBuiltinUniques arity)
521 mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc
522 countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
523 noType = panic "UpdAnal: no type!"
526 = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') ->
527 (combine_IdEnvs (+) c' c, b', f')
529 (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
530 (reg_arg_tys, _) = splitFunTys tau_ty
531 arity = length dict_tys + length reg_arg_tys
534 removeSuperfluous2s = reverse . dropWhile (> 1) . reverse
536 %-----------------------------------------------------------------------------
537 \subsection{Attaching the update information to top-level bindings}
539 This is so that the information can later be retrieved for printing
540 out in the .hi file. This is not an ideal solution, however it will
544 attachUpdateInfoToBinds b p
546 StgNonRec v rhs -> StgNonRec (attachOne v) rhs
547 StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
550 | externallyVisibleId v
551 = let c = lookup v p in
553 (mkUpdateInfo (mkUpdateSpec v c))
557 %-----------------------------------------------------------------------------