path: root/ghc/compiler/simplStg/UpdAnal.lhs

\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}

%-----------------------------------------------------------------------------