X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcoreSyn%2FCoreSubst.lhs;h=6eecc27c9daf2c74738b02d5fa2760ffebcfa694;hb=335bc125303a226a78b20be8a7b8fec5b6c59d2b;hp=c432d55f9468bb1d63b989d94e8218555cacd106;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index c432d55..6eecc27 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -1,13 +1,16 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+Utility functions on @Core@ syntax
 
 \begin{code}
 module CoreSubst (
 	-- Substitution stuff
 	Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
 
+	deShadowBinds,
 	substTy, substExpr, substSpec, substWorker,
 	lookupIdSubst, lookupTvSubst, 
 
@@ -23,29 +26,23 @@ module CoreSubst (
 
 #include "HsVersions.h"
 
-import CoreSyn		( Expr(..), Bind(..), Note(..), CoreExpr,
-			  CoreRule(..), hasUnfolding, noUnfolding
-			)
-import CoreFVs		( exprFreeVars )
-import CoreUtils	( exprIsTrivial )
+import CoreSyn
+import CoreFVs
+import CoreUtils
 
-import qualified Type	( substTy, substTyVarBndr )
-import Type		( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), mkTyVarTy )
+import qualified Type
+import Type     ( Type, TvSubst(..), TvSubstEnv )
 import VarSet
 import VarEnv
-import Var		( setVarUnique, isId )
-import Id		( idType, setIdType, maybeModifyIdInfo, isLocalId )
-import IdInfo		( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo,
-			  unfoldingInfo, setUnfoldingInfo, seqSpecInfo,
-			  WorkerInfo(..), workerExists, workerInfo, setWorkerInfo
-			)
-import Unique		( Unique )
-import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply )
-import Var		( Var, Id, TyVar, isTyVar )
-import Maybes		( orElse )
+import Id
+import Var      ( Var, TyVar, setVarUnique )
+import IdInfo
+import Unique
+import UniqSupply
+import Maybes
 import Outputable
 import PprCore		()		-- Instances
-import Util		( mapAccumL )
+import Util
 import FastTypes
 \end{code}
 
@@ -123,20 +120,31 @@ extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEn
 lookupIdSubst :: Subst -> Id -> CoreExpr
 lookupIdSubst (Subst in_scope ids tvs) v 
   | not (isLocalId v) = Var v
-  | otherwise
-  = case lookupVarEnv ids v of {
-	Just e  -> e ;
-	Nothing -> 	
+  | otherwise	      = case lookupVarEnv ids v of
+			  Just e  -> e
+			  Nothing -> Var v 
+
+{-	We used to have to look up in the in-scope set, 
+	because GADTs were implicit in the intermediate language
+	But with FC, the type of an Id does not change in its scope
+	The worst that can happen if we don't look up in the in-scope set
+	is that we don't propagate IdInfo as vigorously as we might.
+	But that'll happen (when it's useful) in SimplEnv.substId
+
+	If you put this back in, you should worry about the
+		Just e -> e
+	case above too!
+
     case lookupInScope in_scope v of {
 	-- Watch out!  Must get the Id from the in-scope set,
 	-- because its type there may differ
 	Just v  -> Var v ;
 	Nothing -> WARN( True, ptext SLIT("CoreSubst.lookupIdSubst") <+> ppr v ) 
 		   Var v
-    }}
+-}
 
 lookupTvSubst :: Subst -> TyVar -> Type
-lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v `orElse` mkTyVarTy v
+lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
 
 ------------------------------
 isInScope :: Var -> Subst -> Bool
@@ -181,19 +189,14 @@ substExpr subst expr
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
+    go (Cast e co)     = Cast (go e) (substTy subst co)
     go (Lam bndr body) = Lam bndr' (substExpr subst' body)
 		       where
 			 (subst', bndr') = substBndr subst bndr
 
-    go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
-				    where
-				      (subst', bndr') = substBndr subst bndr
-
-    go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
-			      where
-				(subst', bndrs') = substRecBndrs subst (map fst pairs)
-				pairs'	= bndrs' `zip` rhss'
-				rhss'	= map (substExpr subst' . snd) pairs
+    go (Let bind body) = Let bind' (substExpr subst' body)
+		       where
+			 (subst', bind') = substBind subst bind
 
     go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
 			         where
@@ -203,8 +206,30 @@ substExpr subst expr
 				 where
 				   (subst', bndrs') = substBndrs subst bndrs
 
-    go_note (Coerce ty1 ty2) = Coerce (substTy subst ty1) (substTy subst ty2)
     go_note note	     = note
+
+substBind :: Subst -> CoreBind -> (Subst, CoreBind)
+substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (substExpr subst rhs))
+				  where
+				    (subst', bndr') = substBndr subst bndr
+
+substBind subst (Rec pairs) = (subst', Rec pairs')
+			    where
+				(subst', bndrs') = substRecBndrs subst (map fst pairs)
+				pairs'	= bndrs' `zip` rhss'
+				rhss'	= map (substExpr subst' . snd) pairs
+\end{code}
+
+De-shadowing the program is sometimes a useful pre-pass.  It can be done simply
+by running over the bindings with an empty substitution, becuase substitution
+returns a result that has no-shadowing guaranteed.
+
+(Actually, within a single *type* there might still be shadowing, because 
+substType is a no-op for the empty substitution, but that's OK.)
+
+\begin{code}
+deShadowBinds :: [CoreBind] -> [CoreBind]
+deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
 \end{code}
 
 
@@ -246,17 +271,25 @@ substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id
   = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
   where
     id1 = uniqAway in_scope old_id	-- id1 is cloned if necessary
-    id2 = substIdType subst id1		-- id2 has its type zapped
+    id2 | no_type_change = id1
+	| otherwise	 = setIdType id1 (substTy subst old_ty)
+
+    old_ty = idType old_id
+    no_type_change = isEmptyVarEnv tvs || 
+                     isEmptyVarSet (Type.tyVarsOfType old_ty)
 
 	-- new_id has the right IdInfo
 	-- The lazy-set is because we're in a loop here, with 
 	-- rec_subst, when dealing with a mutually-recursive group
-    new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
+    new_id = maybeModifyIdInfo mb_new_info id2
+    mb_new_info = substIdInfo rec_subst (idInfo id2)
 
 	-- Extend the substitution if the unique has changed
 	-- See the notes with substTyVarBndr for the delVarEnv
-    new_env | new_id /= old_id  = extendVarEnv env old_id (Var new_id)
-	    | otherwise         = delVarEnv env old_id
+    new_env | no_change = delVarEnv env old_id
+	    | otherwise = extendVarEnv env old_id (Var new_id)
+
+    no_change = False -- id1 == old_id && isNothing mb_new_info && no_type_change
 \end{code}
 
 Now a variant that unconditionally allocates a new unique.
@@ -289,7 +322,7 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
   where
     id1	    = setVarUnique old_id uniq
     id2     = substIdType subst id1
-    new_id  = maybeModifyIdInfo (substIdInfo rec_subst) id2
+    new_id  = maybeModifyIdInfo (substIdInfo rec_subst (idInfo old_id)) id2
     new_env = extendVarEnv env old_id (Var new_id)
 \end{code}
 
@@ -325,7 +358,7 @@ substTy (Subst in_scope id_env tv_env) ty
 \begin{code}
 substIdType :: Subst -> Id -> Id
 substIdType subst@(Subst in_scope id_env tv_env) id
-  | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+  | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
   | otherwise	= setIdType id (substTy subst old_ty)
 		-- The tyVarsOfType is cheaper than it looks
 		-- because we cache the free tyvars of the type
@@ -389,5 +422,5 @@ substVarSet subst fvs
   where
     subst_fv subst fv 
 	| isId fv   = exprFreeVars (lookupIdSubst subst fv)
-	| otherwise = tyVarsOfType (lookupTvSubst subst fv)
+	| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
 \end{code}