X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fdeforest%2FDefUtils.lhs;fp=ghc%2Fcompiler%2Fdeforest%2FDefUtils.lhs;h=81752f9b2a65d414ded327c0ecd0e1e50e7f4cb1;hb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;hp=0000000000000000000000000000000000000000;hpb=e48474bff05e6cfb506660420f025f694c870d38;p=ghc-hetmet.git

diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs
new file mode 100644
index 0000000..81752f9
--- /dev/null
+++ b/ghc/compiler/deforest/DefUtils.lhs
@@ -0,0 +1,622 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[DefUtils]{Miscellaneous Utility functions}
+
+>#include "HsVersions.h"
+
+> module DefUtils (
+> 	strip, stripAtom, stripCaseAlts, freeVars, renameExprs, rebindExpr,
+>	atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
+>	mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
+>	isArgId
+>	) 
+> 	where
+
+> import DefSyn
+> import Def2Core	-- tmp, for traces
+
+>#ifdef __HBC__
+> import Trace
+>#endif
+
+> import AbsUniType	( cloneTyVar, mkTyVarTy, applyTypeEnvToTy, 
+> 			  extractTyVarsFromTy, TyVar, SigmaType(..)
+>			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
+>			)
+> import BasicLit	( BasicLit )	-- for Eq BasicLit
+> import CoreSyn
+> import Id		( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
+> 			  getIdInfo, toplevelishId, getIdUniType, Id )
+> import IdEnv
+> import IdInfo
+> import Outputable
+> import Pretty
+> import PrimOps	( PrimOp )	-- for Eq PrimOp
+> import SplitUniq
+> import SrcLoc		( mkUnknownSrcLoc )
+> import TyVarEnv
+> import Util
+
+-----------------------------------------------------------------------------
+\susbsection{Strip}
+
+Implementation of the strip function.  Strip is the identity on
+expressions (recursing into subterms), but replaces each label with
+its left hand side.  The result is a term with no labels.
+
+> strip :: DefExpr -> DefExpr
+
+> strip e' = case e' of
+> 	CoVar (DefArgExpr e) -> panic "DefUtils(strip): CoVar (DefExpr _)"
+>	CoVar (Label l e)    -> l
+>       CoVar (DefArgVar v)  -> e'
+>       CoLit l              -> e'
+>       CoCon c ts es        -> CoCon c ts (map stripAtom es)
+>       CoPrim op ts es      -> CoPrim op ts (map stripAtom es)
+>       CoLam vs e           -> CoLam vs (strip e)
+>       CoTyLam alpha e      -> CoTyLam alpha (strip e)
+>       CoApp e v            -> CoApp (strip e) (stripAtom v)
+>       CoTyApp e t          -> CoTyApp (strip e) t
+>       CoCase e ps          -> CoCase (strip e) (stripCaseAlts ps)
+>       CoLet (CoNonRec v e) e' -> CoLet (CoNonRec v (strip e)) (strip e')
+>       CoLet (CoRec bs) e   -> 
+>		CoLet (CoRec [ (v, strip e) | (v,e) <- bs ]) (strip e)
+>       CoSCC l e            -> CoSCC l (strip e)
+
+> stripAtom :: DefAtom -> DefAtom
+> stripAtom (CoVarAtom v) = CoVarAtom (stripArg v)
+> stripAtom (CoLitAtom l) = CoLitAtom l	-- XXX
+
+> stripArg :: DefBindee -> DefBindee
+> stripArg (DefArgExpr e) = DefArgExpr (strip e)
+> stripArg (Label l e)   = panic "DefUtils(stripArg): Label _ _"
+> stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _"
+
+> stripCaseAlts (CoAlgAlts as def) 
+> 	= CoAlgAlts (map stripAlgAlt as) (stripDefault def)
+> stripCaseAlts (CoPrimAlts as def) 
+> 	= CoPrimAlts (map stripPrimAlt as) (stripDefault def)
+
+> stripAlgAlt  (c, vs, e) = (c, vs, strip e)
+> stripPrimAlt (l, e) = (l, strip e)
+
+> stripDefault CoNoDefault = CoNoDefault
+> stripDefault (CoBindDefault v e) = CoBindDefault v (strip e)
+
+-----------------------------------------------------------------------------
+\subsection{Free Variables}
+
+Find the free variables of an expression.  With labels, we descend
+into the left side since this is the only sensible thing to do.
+Strictly speaking, for a term (Label l e), freeVars l == freeVars e,
+but l is guranteed to be finite so we choose that one.
+
+> freeVars :: DefExpr -> [Id]
+> freeVars e = free e []
+>   where 
+>   	free e fvs = case e of
+>		CoVar (DefArgExpr e) -> 
+>			panic "DefUtils(free): CoVar (DefExpr _)"
+>		CoVar (Label l e)    -> free l fvs
+>       	CoVar (DefArgVar v)
+>			| v `is_elem` fvs	-> fvs
+>			| otherwise	-> v : fvs
+>		  where { is_elem = isIn "freeVars(deforest)" }
+>       	CoLit l              -> fvs
+>       	CoCon c ts es        -> foldr freeAtom fvs es
+>       	CoPrim op ts es      -> foldr freeAtom fvs es
+>       	CoLam vs e           -> free' vs (free e fvs)
+>       	CoTyLam alpha e      -> free e fvs
+>       	CoApp 	e v          -> free e (freeAtom v fvs)
+>       	CoTyApp e t          -> free e fvs
+>       	CoCase e ps          -> free e (freeCaseAlts ps fvs)
+>       	CoLet (CoNonRec v e) e' -> free e (free' [v] (free e' fvs))
+>       	CoLet (CoRec bs) e   -> free' vs (foldr free (free e fvs) es)
+>			where (vs,es) = unzip bs
+>       	CoSCC l e            -> free e fvs
+
+>	free' :: [Id] -> [Id] -> [Id]
+> 	free' vs fvs = filter (\x -> notElem x vs) fvs
+
+> 	freeAtom (CoVarAtom (DefArgExpr e)) fvs = free e fvs
+> 	freeAtom (CoVarAtom (Label l e)) fvs 
+> 		= panic "DefUtils(free): CoVarAtom (Label _ _)"
+> 	freeAtom (CoVarAtom (DefArgVar v)) fvs
+> 		= panic "DefUtils(free): CoVarAtom (DefArgVar _ _)"
+> 	freeAtom (CoLitAtom l) fvs = fvs
+
+> 	freeCaseAlts (CoAlgAlts as def) fvs
+> 		= foldr freeAlgAlt  (freeDefault def fvs) as
+> 	freeCaseAlts (CoPrimAlts as def) fvs
+> 		= foldr freePrimAlt (freeDefault def fvs) as
+>		
+> 	freeAlgAlt  (c, vs, e) fvs = free' vs (free e fvs)
+> 	freePrimAlt (l, e) fvs = free e fvs
+
+> 	freeDefault CoNoDefault fvs = fvs
+> 	freeDefault (CoBindDefault v e) fvs = free' [v] (free e fvs)
+
+-----------------------------------------------------------------------------
+\subsection{Free Type Variables}
+
+> freeTyVars :: DefExpr -> [TyVar]
+> freeTyVars e = free e []
+>   where
+>   	free e tvs = case e of
+>		CoVar (DefArgExpr e)    ->
+>			panic "DefUtils(freeVars): CoVar (DefExpr _)"
+>		CoVar (Label l e)       -> free l tvs
+>       	CoVar (DefArgVar id)    -> freeId id tvs
+>       	CoLit l                 -> tvs
+>       	CoCon c ts es           -> foldr freeTy (foldr freeAtom tvs es) ts
+>       	CoPrim op ts es         -> foldr freeTy (foldr freeAtom tvs es) ts
+>       	CoLam vs e              -> foldr freeId (free e tvs) vs
+>       	CoTyLam alpha e         -> filter (/= alpha) (free e tvs)
+>       	CoApp e v               -> free e (freeAtom v tvs)
+>       	CoTyApp e t             -> free e (freeTy t tvs)
+>       	CoCase e ps             -> free e (freeCaseAlts ps tvs)
+>       	CoLet (CoNonRec v e) e' -> free e (freeId v (free e' tvs))
+>       	CoLet (CoRec bs) e      -> foldr freeBind (free e tvs) bs
+>       	CoSCC l e               -> free e tvs
+>		
+>	freeId id tvs = extractTyVarsFromTy (getIdUniType id) `union` tvs
+>	freeTy t  tvs = extractTyVarsFromTy t `union` tvs
+>	freeBind (v,e) tvs = freeId v (free e tvs)
+  
+> 	freeAtom (CoVarAtom (DefArgExpr e)) tvs = free e tvs
+> 	freeAtom (CoVarAtom (Label l e)) tvs
+> 		= panic "DefUtils(freeVars): CoVarAtom (Label _ _)"
+> 	freeAtom (CoVarAtom (DefArgVar v)) tvs
+> 		= panic "DefUtils(freeVars): CoVarAtom (DefArgVar _ _)"
+> 	freeAtom (CoLitAtom l) tvs = tvs	-- XXX
+
+> 	freeCaseAlts (CoAlgAlts as def) tvs
+> 		= foldr freeAlgAlt  (freeDefault def tvs) as
+> 	freeCaseAlts (CoPrimAlts as def) tvs
+> 		= foldr freePrimAlt (freeDefault def tvs) as
+
+> 	freeAlgAlt  (c, vs, e) tvs = foldr freeId (free e tvs) vs
+> 	freePrimAlt (l, e) tvs = free e tvs
+
+> 	freeDefault CoNoDefault tvs = tvs
+> 	freeDefault (CoBindDefault v e) tvs = freeId v (free e tvs)
+
+-----------------------------------------------------------------------------
+\subsection{Rebinding variables in an expression}
+
+Here is the code that renames all the bound variables in an expression
+with new uniques.  Free variables are left unchanged.
+
+> rebindExpr :: DefExpr -> SUniqSM DefExpr
+> rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
+
+> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> SUniqSM DefExpr
+> uniqueExpr p t e =
+>   case e of
+> 	CoVar (DefArgVar v) -> 
+> 		returnSUs (CoVar (DefArgVar (lookup v p)))
+> 	
+> 	CoVar (Label l e) -> 
+> 		uniqueExpr p t l		`thenSUs` \l ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		returnSUs (mkLabel l e)
+> 		
+> 	CoVar (DefArgExpr _) ->
+> 		panic "DefUtils(uniqueExpr): CoVar(DefArgExpr _)"
+> 		
+> 	CoLit l ->
+> 		returnSUs e
+> 		
+> 	CoCon c ts es ->
+> 		mapSUs (uniqueAtom p t) es 	`thenSUs` \es ->
+> 		returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
+> 		
+> 	CoPrim op ts es ->
+> 		mapSUs (uniqueAtom p t) es	 `thenSUs` \es ->
+> 		returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
+> 		
+> 	CoLam vs e ->
+> 		mapSUs (newVar t) vs		`thenSUs` \vs' ->
+> 		uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenSUs` \e ->
+> 		returnSUs (CoLam vs' e)
+> 		
+> 	CoTyLam v e ->
+>		getSUnique			`thenSUs` \u ->
+>		let v' = cloneTyVar v u
+>		    t' = addOneToTyVarEnv t v (mkTyVarTy v') in
+> 		uniqueExpr p t' e 		`thenSUs` \e ->
+> 		returnSUs (CoTyLam v' e)
+> 	
+> 	CoApp e v ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		uniqueAtom p t v		`thenSUs` \v ->
+> 		returnSUs (CoApp e v)
+> 		
+> 	CoTyApp e ty ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		returnSUs (mkCoTyApp e (applyTypeEnvToTy t ty))
+> 	
+> 	CoCase e alts ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		uniqueAlts alts			`thenSUs` \alts ->
+> 		returnSUs (CoCase e alts)
+> 	     where
+> 	     	uniqueAlts (CoAlgAlts  as d) = 
+> 			mapSUs uniqueAlgAlt  as	`thenSUs` \as ->
+> 			uniqueDefault d		`thenSUs` \d ->
+> 			returnSUs (CoAlgAlts as d)
+> 		uniqueAlts (CoPrimAlts as d) =
+> 			mapSUs uniquePrimAlt as `thenSUs` \as ->
+> 			uniqueDefault d		`thenSUs` \d ->
+> 			returnSUs (CoPrimAlts as d)
+> 			
+> 		uniqueAlgAlt (c, vs, e) = 
+> 			mapSUs (newVar t) vs	`thenSUs` \vs' ->
+> 			uniqueExpr (growIdEnvList p (zip vs vs')) t e 
+>						`thenSUs` \e ->
+> 			returnSUs (c, vs', e)
+> 		uniquePrimAlt (l, e) =
+> 			uniqueExpr p t e	`thenSUs` \e ->
+> 			returnSUs (l, e)
+> 			
+> 		uniqueDefault CoNoDefault = returnSUs CoNoDefault
+> 		uniqueDefault (CoBindDefault v e) = 
+>			newVar t v	`thenSUs` \v' ->
+> 			uniqueExpr (addOneToIdEnv p v v') t e `thenSUs` \e ->
+> 			returnSUs (CoBindDefault v' e)
+> 
+> 	CoLet (CoNonRec v e) e' ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		newVar t v			`thenSUs` \v' ->
+> 		uniqueExpr (addOneToIdEnv p v v') t e'  `thenSUs` \e' ->
+> 		returnSUs (CoLet (CoNonRec v' e) e')
+> 		
+> 	CoLet (CoRec ds) e ->
+> 		let (vs,es) = unzip ds in
+> 		mapSUs (newVar t) vs		`thenSUs` \vs' ->
+> 		let p' = growIdEnvList p (zip vs vs') in
+> 		mapSUs (uniqueExpr p' t) es  	`thenSUs` \es ->
+> 		uniqueExpr p' t e		`thenSUs` \e ->
+> 		returnSUs (CoLet (CoRec (zip vs' es)) e)
+> 
+> 	CoSCC l e ->
+> 		uniqueExpr p t e		`thenSUs` \e ->
+> 		returnSUs (CoSCC l e)
+> 		
+> 
+> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> SUniqSM DefAtom
+> uniqueAtom p t (CoLitAtom l) = returnSUs (CoLitAtom l) -- XXX
+> uniqueAtom p t (CoVarAtom v) = 
+> 	uniqueArg p t v	`thenSUs` \v ->
+>	returnSUs (CoVarAtom v)
+> 
+> uniqueArg p t (DefArgVar v) =
+> 	panic "DefUtils(uniqueArg): DefArgVar _ _"
+> uniqueArg p t (DefArgExpr e) =
+> 	uniqueExpr p t e	`thenSUs` \e ->
+> 	returnSUs (DefArgExpr e)
+> uniqueArg p t (Label l e) =
+> 	panic "DefUtils(uniqueArg): Label _ _"
+
+We shouldn't need to apply the type environment to free variables,
+since their types can only contain type variables that are free in the
+expression as a whole (?)
+
+> lookup :: Id -> IdEnv Id -> Id
+> lookup id p =
+> 	case lookupIdEnv p id of
+>		Nothing -> id
+>		Just new_id -> new_id
+
+> newVar :: TypeEnv -> Id -> SUniqSM Id
+> newVar t id = 
+> 	getSUnique		`thenSUs` \u ->
+> 	returnSUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
+
+-----------------------------------------------------------------------------
+\subsection{Detecting Renamings}
+
+The function `renameExprs' takes two expressions and returns True if
+they are renamings of each other.  The variables in the list `fs' are
+excluded from the renaming process (i.e. if any of these variables
+are present in one expression, they cannot be renamed in the other
+expression).
+
+We only allow renaming of sysLocal ids - ie. not top-level, imported
+or otherwise global ids.
+
+> data RenameResult 
+> 	= NotRenaming
+>	| IsRenaming [(Id,Id)]
+>	| InconsistentRenaming [(Id,Id)]
+
+> renameExprs :: DefExpr -> DefExpr -> SUniqSM RenameResult
+> renameExprs u u' = 
+>	case ren u u' of
+>		[]   -> returnSUs NotRenaming
+>		[r] -> if not (consistent r) then 
+>				d2c (strip u)	`thenSUs` \u ->
+>				d2c (strip u')  `thenSUs` \u' ->
+>				trace ("failed consistency check:\n" ++
+>				       ppShow 80 (ppr PprDebug u) ++ "\n" ++
+>				       ppShow 80 (ppr PprDebug u'))
+>				(returnSUs (InconsistentRenaming r))
+>			else 
+>				trace "Renaming!" (returnSUs (IsRenaming r))
+>		_ -> panic "DefUtils(renameExprs)"
+
+Check that we have a consistent renaming.  A renaming is consistent if
+each time variable x in expression 1 is renamed, it is renamed to the
+same variable.
+
+> consistent :: [(Id,Id)] -> Bool
+> consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ]
+
+> checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
+> checkConsistency bound free = [ r' | r <- free, r' <- check r ]
+> 	where 
+>	   check r | they're_consistent = [frees]
+>		   | otherwise          = []
+> 	   	where  
+>		   (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
+>	           (lbound,rbound) = unzip bound
+>	           they're_consistent = consistent (bound ++ bounds)
+
+Renaming composition operator.
+
+> (....) :: [[a]] -> [[a]] -> [[a]]
+> r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ]
+
+The class of identifiers which can be renamed.  It is sensible to
+disallow renamings of deforestable ids, but the top-level ones are a
+bit iffy.  Ideally, we should allow renaming of top-level ids, but the
+current scheme allows us to leave out the top-level ids from the
+argument lists of new function definitions.  (we still have the
+shadowed ones to worry about..)
+
+Main renaming function.  Returns a list of renamings made while
+comparing the expressions.
+
+> ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
+> 
+>	-- renaming or identical cases --
+>	
+>
+> 	-- same variable, no renaming
+> ren (CoVar (DefArgVar x)) t@(CoVar (DefArgVar y)) 
+> 	| x == y = [[(x,y)]]
+>	| isArgId x && isArgId y = [[(x,y)]]
+>
+>	-- if we're doing matching, use the next rule,
+>	-- and delete the second clause in the above rule.
+> {-
+> ren (CoVar (DefArgVar x)) t 
+> 	| okToRename x && all (not. deforestable) (freeVars t)
+>	= [[(x,t)]]
+> -}
+
+> ren (CoLit l) (CoLit l') | l == l'
+> 	= [[]]
+> ren (CoCon c ts es) (CoCon c' ts' es') | c == c'
+> 	= foldr (....) [[]] (zipWith renAtom es es')
+> ren (CoPrim op ts es) (CoPrim op' ts' es') | op == op'
+> 	= foldr (....) [[]] (zipWith renAtom es es')
+> ren (CoLam vs e) (CoLam vs' e')
+> 	= checkConsistency (zip vs vs') (ren e e')
+> ren (CoTyLam vs e) (CoTyLam vs' e')
+> 	= ren e e'			-- XXX!
+> ren (CoApp e v) (CoApp e' v')
+> 	= ren e e' .... renAtom v v'
+> ren (CoTyApp e t) (CoTyApp e' t')
+> 	= ren e e'			-- XXX!
+> ren (CoCase e alts) (CoCase e' alts')
+> 	= ren e e' .... renAlts alts alts'
+> ren (CoLet (CoNonRec v a) b) (CoLet (CoNonRec v' a') b')
+> 	= ren a a' .... (checkConsistency [(v,v')] (ren b b'))
+> ren (CoLet (CoRec ds) e) (CoLet (CoRec ds') e')
+> 	= checkConsistency (zip vs vs') 
+>		(ren e e' .... (foldr (....) [[]] (zipWith ren es es')))
+>	where (vs ,es ) = unzip ds
+>	      (vs',es') = unzip ds'
+>	   
+> 	-- label cases --
+>	
+> ren (CoVar (Label l e)) e' 	= ren l e'
+> ren e (CoVar (Label l e'))	= ren e l
+>
+>	-- error cases --
+>	
+> ren (CoVar (DefArgExpr _)) _
+> 	= panic "DefUtils(ren): CoVar (DefArgExpr _)"
+> ren _ (CoVar (DefArgExpr _))
+> 	= panic "DefUtils(ren): CoVar (DefArgExpr _)"
+>	
+>	-- default case --
+>	
+> ren _ _ = [] 
+
+Rename atoms.
+
+> renAtom (CoVarAtom (DefArgExpr e)) (CoVarAtom (DefArgExpr e'))
+> 	= ren e e'
+>  -- XXX shouldn't need the next two
+> renAtom (CoLitAtom l) (CoLitAtom l') | l == l' = [[]]				
+> renAtom (CoVarAtom (DefArgVar v)) _ =
+> 	panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
+> renAtom _ (CoVarAtom (DefArgVar v)) =
+> 	panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
+> renAtom (CoVarAtom (Label _ _)) _ = 
+> 	panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
+> renAtom e (CoVarAtom (Label l e')) =
+> 	panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
+>	
+> renAtom _ _ = []
+
+Renamings of case alternatives doesn't allow reordering, but that
+should be Ok (we don't ever change the ordering anyway).
+
+> renAlts (CoAlgAlts as dflt) (CoAlgAlts as' dflt')
+> 	= foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
+> renAlts (CoPrimAlts as dflt) (CoPrimAlts as' dflt')
+> 	= foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt'
+> renAlts _ _ = []
+>	
+> renAlgAlt (c,vs,e) (c',vs',e') | c == c' 
+> 	= checkConsistency (zip vs vs') (ren e e')
+> renAlgAlt _ _ = []
+> 
+> renPrimAlt (l,e) (l',e') | l == l' = ren e e'
+> renPrimAlt _ _ = []
+>
+> renDefault CoNoDefault CoNoDefault = [[]]
+> renDefault (CoBindDefault v e) (CoBindDefault v' e')
+> 	= checkConsistency [(v,v')] (ren e e')
+
+-----------------------------------------------------------------------------
+
+> atom2expr :: DefAtom -> DefExpr
+> atom2expr (CoVarAtom (DefArgExpr e)) = e
+> atom2expr (CoVarAtom (Label l e)) = mkLabel l e
+> -- XXX next two should be illegal
+> atom2expr (CoLitAtom l) = CoLit l
+> atom2expr (CoVarAtom (DefArgVar v)) = 
+> 	panic "DefUtils(atom2expr): CoVarAtom (DefArgVar _)"
+
+> expr2atom = CoVarAtom . DefArgExpr
+
+-----------------------------------------------------------------------------
+Grab a new Id and tag it as coming from the Deforester.
+
+> newDefId :: UniType -> SUniqSM Id
+> newDefId t = 
+> 	getSUnique	`thenSUs` \u ->
+>	returnSUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+
+> newTmpId :: UniType -> SUniqSM Id
+> newTmpId t =
+> 	getSUnique	`thenSUs` \u ->
+>	returnSUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+
+-----------------------------------------------------------------------------
+Check whether an Id was given a `DEFOREST' annotation by the programmer.
+
+> deforestable :: Id -> Bool
+> deforestable id =
+> 	case getInfo (getIdInfo id) of
+>		DoDeforest -> True
+>		Don'tDeforest -> False
+
+-----------------------------------------------------------------------------
+Filter for free variables to abstract from new functions.
+
+> isArgId id 
+> 	=    (not . deforestable)  id  
+>         && (not . toplevelishId) id 
+
+-----------------------------------------------------------------------------
+
+> foldrSUs f c [] = returnSUs c
+> foldrSUs f c (x:xs)
+> 	= foldrSUs f c xs	`thenSUs` \xs' ->
+>	  f x xs'
+
+-----------------------------------------------------------------------------
+
+> mkDefLetrec [] e = e
+> mkDefLetrec bs e = CoLet (CoRec bs) e
+
+-----------------------------------------------------------------------------
+Substitutions.
+
+> subst :: [(Id,DefExpr)]
+> 	-> DefExpr
+>	-> SUniqSM DefExpr
+
+> subst p e' = sub e'
+>  where
+>     p' = mkIdEnv p
+>     sub e' = case e' of
+> 	CoVar (DefArgExpr e) -> panic "DefExpr(sub): CoVar (DefArgExpr _)"
+>	CoVar (Label l e)    -> panic "DefExpr(sub): CoVar (Label _ _)"
+>       CoVar (DefArgVar v) ->
+>		case lookupIdEnv p' v of
+>			Just e  -> rebindExpr e	`thenSUs` \e -> returnSUs e
+>			Nothing -> returnSUs e'
+>       CoLit l              -> returnSUs e'
+>       CoCon c ts es        -> mapSUs substAtom es	`thenSUs` \es ->
+>				returnSUs (CoCon c ts es)
+>       CoPrim op ts es      -> mapSUs substAtom es	`thenSUs` \es ->
+>				returnSUs (CoPrim op ts es)
+>       CoLam vs e           -> sub e			`thenSUs` \e ->
+>				returnSUs (CoLam vs e)
+>       CoTyLam alpha e      -> sub e			`thenSUs` \e ->
+>				returnSUs (CoTyLam alpha e)
+>       CoApp e v            -> sub e			`thenSUs` \e ->
+>				substAtom v		`thenSUs` \v ->
+>				returnSUs (CoApp e v)
+>       CoTyApp e t          -> sub e			`thenSUs` \e ->
+>				returnSUs (CoTyApp e t)
+>       CoCase e ps          -> sub e			`thenSUs` \e ->
+>				substCaseAlts ps	`thenSUs` \ps ->
+>				returnSUs (CoCase e ps)
+>       CoLet (CoNonRec v e) e' 
+>			     -> sub e			`thenSUs` \e ->
+>			        sub e'			`thenSUs` \e' ->
+>				returnSUs (CoLet (CoNonRec v e) e')
+>       CoLet (CoRec bs) e   -> sub e			`thenSUs` \e ->
+>				mapSUs substBind bs	`thenSUs` \bs ->
+>				returnSUs (CoLet (CoRec bs) e)
+>			where
+>				substBind (v,e) = 
+>					sub e 		`thenSUs` \e ->
+>					returnSUs (v,e)
+>       CoSCC l e            -> sub e			`thenSUs` \e ->
+>				returnSUs (CoSCC l e)
+
+>     substAtom (CoVarAtom v) = 
+>     		substArg v `thenSUs` \v ->
+>		returnSUs (CoVarAtom v)
+>     substAtom (CoLitAtom l) = 
+>     		returnSUs (CoLitAtom l)	-- XXX
+
+>     substArg (DefArgExpr e) = 
+>     		sub e		`thenSUs` \e ->
+>		returnSUs (DefArgExpr e)
+>     substArg e@(Label _ _)  = 
+>     		panic "DefExpr(substArg): Label _ _"
+>     substArg e@(DefArgVar v)  =	-- XXX
+>     		case lookupIdEnv p' v of
+>			Just e -> rebindExpr e	`thenSUs` \e ->
+>				  returnSUs (DefArgExpr e)
+>			Nothing -> returnSUs e
+
+>     substCaseAlts (CoAlgAlts as def) = 
+>     		mapSUs substAlgAlt as		`thenSUs` \as ->
+>		substDefault def		`thenSUs` \def ->
+>		returnSUs (CoAlgAlts as def)
+>     substCaseAlts (CoPrimAlts as def) =
+>     		mapSUs substPrimAlt as		`thenSUs` \as ->
+>		substDefault def		`thenSUs` \def ->
+>		returnSUs (CoPrimAlts as def)
+
+>     substAlgAlt  (c, vs, e) = 
+>     		sub e				`thenSUs` \e ->
+>		returnSUs (c, vs, e)
+>     substPrimAlt (l, e) = 
+>     		sub e				`thenSUs` \e ->
+>		returnSUs (l, e)
+
+>     substDefault CoNoDefault = 
+>     		returnSUs CoNoDefault
+>     substDefault (CoBindDefault v e) = 
+>     		sub e				`thenSUs` \e ->
+>		returnSUs (CoBindDefault v e)
+
+-----------------------------------------------------------------------------
+
+> union [] ys = ys
+> union (x:xs) ys 
+> 	| x `is_elem` ys = union xs ys
+>	| otherwise   = x : union xs ys
+>   where { is_elem = isIn "union(deforest)" }