X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FUpdAnal.lhs;h=5c670ad47ca5c74ad839de830a1563e118fdbedd;hb=97372c19ce6514f598f4dcf3211b6801699ab133;hp=a50e672f657ac190c1519563902f9198024654bb;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index a50e672..5c670ad 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -1,48 +1,54 @@
-\section{Update Avoidance Analyser}			-*-haskell-literate-*-
+\section{Update Avoidance Analyser}
 
 (c) Simon Marlow, Andre Santos 1992-1993
-(c) The AQUA Project, Glasgow University, 1995
+(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,
+			  getIdUpdateInfo, 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}
 
-> module UpdAnal ( updateAnalyse ) where
->
-> IMPORT_Trace
-
-> import AbsUniType	( splitTyArgs, splitType, Class, TyVarTemplate, 
-> 			  TauType(..)
->			)
-> import Id
-> import IdEnv
-> import IdInfo
-> import Outputable	( isExported )
-> import Pretty
-> import SrcLoc 	( mkUnknownSrcLoc )
-> import StgSyn
-> import UniqSet
-> import Unique 	( getBuiltinUniques )
-> import Util
 
 %-----------------------------------------------------------------------------
 \subsection{Reverse application}
 
 This is used instead of lazy pattern bindings to avoid space leaks.
 
-> infixr 3 =:
-> a =: k = k a
+\begin{code}
+infixr 3 =:
+a =: k = k a
+\end{code}
 
 %-----------------------------------------------------------------------------
 \subsection{Types}
 
 List of closure references
 
-> type Refs = IdSet
-> x `notInRefs` y = not (x `elementOfUniqSet` y)
+\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
@@ -53,57 +59,59 @@ 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.
 
-> -- 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 = nullIdEnv
->
-> unit_IdEnv :: Id -> a -> IdEnv (Id, a)
-> unit_IdEnv k v = unitIdEnv k (k, v)
->
-> mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a)
-> mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ]
->
-> grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a)
-> grow_IdEnv env1 env2 = growIdEnv env1 env2
->
-> addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a)
-> addOneTo_IdEnv env k v = addOneToIdEnv 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
->   where
->     new_combiner (id, x) (_, y) = (id, combiner x y)
->
-> dom_IdEnv :: IdEnv (Id, a) -> Refs
-> dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ]
->
-> lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a
-> lookup_IdEnv env key = case lookupIdEnv env key of
->			   Nothing    -> Nothing
->			   Just (_,a) -> Just a
-> -- end backward compat stuff
-
-> type Closure = (IdEnvInt, Refs, AbFun)
-
-> type AbVal = IdEnvClosure -> Closure
-> data AbFun = Fun (Closure -> Closure)
-
-> -- partain: speeding-up stuff
->
-> type CaseBoundVars = IdSet
-> noCaseBound   = emptyUniqSet
-> isCaseBound   = elementOfUniqSet
-> x `notCaseBound` y = not (isCaseBound x y)
-> moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars
-> moreCaseBound old new = old `unionUniqSets` mkUniqSet new
->
-> -- end speeding-up
+\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}
@@ -112,32 +120,37 @@ 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.
 
-> lookup v
->   | isImportedId v 
->   = const (case updateInfoMaybe (getIdUpdateInfo v) of
->		Nothing   -> unknownClosure
->		Just spec -> convertUpdateSpec spec)
->   | otherwise	 
->   = \p -> case lookup_IdEnv p v of
->		Just b  -> b
->		Nothing -> unknownClosure
+\begin{code}
+lookup v
+  | isLocallyDefined v
+  = \p -> case lookup_IdEnv p v of
+		Just b  -> b
+		Nothing -> unknownClosure
+
+  | otherwise
+  = const (case updateInfoMaybe (getIdUpdateInfo v) of
+		Nothing   -> unknownClosure
+		Just spec -> convertUpdateSpec spec)
+\end{code}
 
 %-----------------------------------------------------------------------------
 Represent a list of references as an ordered list.
 
-> mkRefs :: [Id] -> Refs
-> mkRefs = mkUniqSet
+\begin{code}
+mkRefs :: [Id] -> Refs
+mkRefs = mkVarSet
 
-> noRefs :: Refs
-> noRefs = emptyUniqSet
+noRefs :: Refs
+noRefs = emptyVarSet
 
-> elemRefs = elementOfUniqSet
+elemRefs = elemVarSet
 
-> merge :: [Refs] -> Refs
-> merge xs = foldr merge2 emptyUniqSet xs
+merge :: [Refs] -> Refs
+merge xs = foldr merge2 emptyVarSet xs
 
-> merge2 :: Refs -> Refs -> Refs
-> merge2 = unionUniqSets
+merge2 :: Refs -> Refs -> Refs
+merge2 = unionVarSet
+\end{code}
 
 %-----------------------------------------------------------------------------
 \subsection{Some non-interesting values}
@@ -145,8 +158,10 @@ Represent a list of references as an ordered list.
 bottom will be used for abstract values that are not functions.
 Hopefully its value will never be required!
 
-> bottom 		:: AbFun
-> bottom 		= panic "Internal: (Update Analyser) bottom"
+\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
@@ -154,59 +169,71 @@ 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.
 
-> noClosure, unknownClosure :: Closure
-> noClosure 		= (null_IdEnv, noRefs, bottom)
-> unknownClosure 	= (null_IdEnv, noRefs, dont_know noRefs)
+\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.
 
-> 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''))
+\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}
 
-%-----------------------------------------------------------------------------
+-----------------------------------------------------------------------------
 
-> 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
+\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.
 
-> udData :: [PlainStgAtom] -> CaseBoundVars -> AbVal
-> udData vs cvs
-> 	= \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
->	where local_ids = [ lookup v | (StgVarAtom v) <- vs, v `notCaseBound` cvs ]
+\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}
 
-> udAtom :: CaseBoundVars -> PlainStgAtom -> AbVal
-> udAtom cvs (StgVarAtom v) 
->	| v `isCaseBound` cvs = const unknownClosure
->	| otherwise	      = lookup v
->
-> udAtom cvs _		      = const noClosure
+\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}
 
-> ud :: PlainStgExpr			-- Expression to be analysed
->    -> CaseBoundVars			-- List of case-bound vars
->    -> IdEnvClosure			-- Current environment
->    -> (PlainStgExpr, AbVal)		-- (New expression, abstract value)
->
-> ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs)
-> ud e@(StgConApp  _ 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)
+\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@(StgCon  _ 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
@@ -215,101 +242,108 @@ abstract function iff the atom is a local variable.
 
 I've left the type signature for doApp in to make things a bit clearer.
 
-> ud e@(StgApp a atoms lvs) cvs p
->   = (e, abval_app)
->   where
->     abval_atoms = map (udAtom cvs) atoms
->     abval_a     = udAtom 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 uniq 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 uniq alts', abval_case)
->   where
->   
->     udAlt :: PlainStgCaseAlternatives
->           -> IdEnvClosure
->           -> (PlainStgCaseAlternatives, 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 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)
->
->     udDef :: PlainStgCaseDefault
->           -> IdEnvClosure
->           -> (PlainStgCaseDefault, AbVal)
-> 
->     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)
->
->     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)
+\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.
 
-> 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)
+\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
@@ -321,86 +355,92 @@ respective bindings have already been analysed.
 
 We don't need to find anything out about closures with arguments,
 constructor closures etc.
-  
-> udBinding :: PlainStgBinding
->	    -> CaseBoundVars
->           -> IdEnvClosure
->	    -> (PlainStgBinding,
->		[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 | (StgVarAtom v) <- args ]
-  
+
+\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}
 
-> udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs)
->
-> udRhs (StgRhsClosure cc bi fv u [] body) cvs p
->   = ud body cvs p			=: \(body', abval_body) ->
->     (StgRhsClosure cc bi fv u [] body', abval_body)
+\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.
 
-> udRhs (StgRhsClosure cc bi 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)
->     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)))
-  
+\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}
 
@@ -408,19 +448,21 @@ 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).
 
-> tag :: Refs -> IdEnvInt -> PlainStgBinding -> PlainStgBinding
->
-> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) 
->   = if (v `notInRefs` b) && (lookupc c v <= 1)
->     then -- trace "One!" (
->	   StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
->	   -- )
->     else r
-> tag b c other = other
->
-> lookupc c v = case lookup_IdEnv c v of
->                 Just n -> n
->                 Nothing -> 0
+\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}
@@ -429,18 +471,20 @@ 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).
 
-> updateAnalyse :: PlainStgProgram -> PlainStgProgram {- Exported -}
-> updateAnalyse bs 
->  = udProgram bs null_IdEnv
-  
-> udProgram :: PlainStgProgram -> IdEnvClosure -> PlainStgProgram
-> 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''
+\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}
@@ -448,43 +492,47 @@ thus preventing a space leak).
 Convert the exported representation of a function's update function
 into a real Closure value.
 
-> 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 ))
+\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.
 
-> 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 mkUnknownSrcLoc
->	      	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) = (splitType . getIdUniType) v
-> 	        (reg_arg_tys, _)    = splitTyArgs tau_ty
->		arity               = length dict_tys + length reg_arg_tys
+\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
 
@@ -495,16 +543,18 @@ 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.
 
-> 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
->		| isExported v 
->			= let c = lookup v p in
->		 		addIdUpdateInfo v 
->					(mkUpdateInfo (mkUpdateSpec v c))
->		| otherwise    = v
+\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}
 
 %-----------------------------------------------------------------------------