From: simonpj <unknown>
Date: Thu, 23 Dec 2004 14:59:50 +0000 (+0000)
Subject: [project @ 2004-12-23 14:59:46 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1313
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fdba7999ba01b4e2b4ee704e6784192e4d92b8cf;p=ghc-hetmet.git

[project @ 2004-12-23 14:59:46 by simonpj]
Simplifications, dead code elimination
---

diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 859c1d4..86508c2 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -14,8 +14,6 @@ module Subst (
 	zapSubstEnv, setSubstEnv, 
 	getTvSubst, getTvSubstEnv, setTvSubstEnv, 
 
-	bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-
 	-- Binders
 	simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
 	substAndCloneId, substAndCloneIds, substAndCloneRecIds,
@@ -39,8 +37,7 @@ import CoreFVs		( exprFreeVars )
 import CoreUtils	( exprIsTrivial )
 
 import qualified Type	( substTy )
-import Type		( Type, tyVarsOfType, mkTyVarTy,
-			  TvSubstEnv, TvSubst(..), substTyVarBndr )
+import Type		( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), substTyVarBndr )
 import VarSet
 import VarEnv
 import Var		( setVarUnique, isId, mustHaveLocalBinding )
@@ -60,7 +57,7 @@ import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply )
 import Var		( Var, Id, TyVar, isTyVar )
 import Outputable
 import PprCore		()		-- Instances
-import Util		( mapAccumL, foldl2 )
+import Util		( mapAccumL )
 import FastTypes
 \end{code}
 
@@ -216,38 +213,6 @@ extendInScopeIds (Subst in_scope ids tvs) vs
 	  (ids `delVarEnvList` vs) tvs
 
 -------------------------------
-bindSubst :: Subst -> Var -> Var -> Subst
--- Extend with a substitution, v1 -> Var v2
--- and extend the in-scopes with v2
-bindSubst (Subst in_scope ids tvs) old_bndr new_bndr
-  | isId old_bndr
-  = Subst (in_scope `extendInScopeSet` new_bndr)
-	  (extendVarEnv ids old_bndr (DoneEx (Var new_bndr)))
-	  tvs
-  | otherwise
-  = Subst (in_scope `extendInScopeSet` new_bndr)
-	  ids
-	  (extendVarEnv tvs old_bndr (mkTyVarTy new_bndr))
-
-unBindSubst :: Subst -> Var -> Var -> Subst
--- Reverse the effect of bindSubst
--- If old_bndr was already in the substitution, this doesn't quite work
-unBindSubst (Subst in_scope ids tvs) old_bndr new_bndr
-  = Subst (in_scope `delInScopeSet` new_bndr)
-	  (delVarEnv ids old_bndr) 
-	  (delVarEnv tvs old_bndr)
-
--- And the "List" forms
-bindSubstList :: Subst -> [Var] -> [Var] -> Subst
-bindSubstList subst old_bndrs new_bndrs
-  = foldl2 bindSubst subst old_bndrs new_bndrs
-
-unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
-unBindSubstList subst old_bndrs new_bndrs
-  = foldl2 unBindSubst subst old_bndrs new_bndrs
-
-
--------------------------------
 setInScopeSet :: Subst -> InScopeSet -> Subst
 setInScopeSet (Subst _ ids tvs) in_scope
   = Subst in_scope ids tvs 
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index d0f043b..e677488 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -58,7 +58,8 @@ import CoreSyn
 import CmdLineOpts	( FloatOutSwitches(..) )
 import CoreUtils	( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
 import CoreFVs		-- all of it
-import Subst
+import Subst		( Subst, SubstResult(..), emptySubst, extendInScope, extendIdSubst,
+			  substAndCloneId, substAndCloneRecIds )
 import Id		( Id, idType, mkSysLocalUnencoded, 
 			  isOneShotLambda, zapDemandIdInfo,
 			  idSpecialisation, idWorkerInfo, setIdInfo
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 095a0a5..8bd967b 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -19,13 +19,12 @@ import OccurAnal	( occurAnalyseRule )
 import CoreFVs		( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
 import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils	( tcEqExprX )
+import Type		( Type )
 import CoreTidy		( pprTidyIdRules )
-import Subst		( IdSubstEnv, SubstResult(..) )
 import Id		( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) 
 import Var		( Var )
 import VarSet
 import VarEnv
-import TcType		( TvSubstEnv )
 import Unify 		( tcMatchTyX, MatchEnv(..) )
 import BasicTypes	( Activation, CompilerPhase, isActive )
 
@@ -156,12 +155,27 @@ matchN in_scope tmpl_vars tmpl_es target_es
 				Just ty 	-> Type ty
 				Nothing 	-> unbound tmpl_var
 	| otherwise	   = case lookupVarEnv id_subst tmpl_var of
-				Just (DoneEx e) -> e
-				other		-> unbound tmpl_var
+				Just e -> e
+				other  -> unbound tmpl_var
  
     unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+\end{code}
+
 
-emptySubstEnv :: (TvSubstEnv, IdSubstEnv)
+	---------------------------------------------
+		The inner workings of matching
+	---------------------------------------------
+
+\begin{code}
+-- These two definitions are not the same as in Subst,
+-- but they simple and direct, and purely local to this module
+-- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
+-- for uniformity with IdSubstEnv
+type SubstEnv   = (TvSubstEnv, IdSubstEnv)	
+type IdSubstEnv = IdEnv    CoreExpr		
+type TvSubstEnv = TyVarEnv Type
+
+emptySubstEnv :: SubstEnv
 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 
 
@@ -175,10 +189,10 @@ emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 
 
 match :: MatchEnv
-      -> (TvSubstEnv, IdSubstEnv)
+      -> SubstEnv
       -> CoreExpr		-- Template
       -> CoreExpr		-- Target
-      -> Maybe (TvSubstEnv, IdSubstEnv)
+      -> Maybe SubstEnv
 
 -- See the notes with Unify.match, which matches types
 -- Everything is very similar for terms
@@ -204,10 +218,10 @@ match menv subst@(tv_subst, id_subst) (Var v1) e2
 		-- e.g. match forall a. (\x-> a x) against (\y. y y)
 
 		| otherwise
-		-> Just (tv_subst, extendVarEnv id_subst v1 (DoneEx e2))
+		-> Just (tv_subst, extendVarEnv id_subst v1 e2)
 
-	Just (DoneEx e2') | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
-			  -> Just subst
+	Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
+		 -> Just subst
 
 	other -> Nothing
 
@@ -294,10 +308,10 @@ match menv subst e1 e2 = Nothing
 
 ------------------------------------------
 match_alts :: MatchEnv
-      -> (TvSubstEnv, IdSubstEnv)
+      -> SubstEnv
       -> [CoreAlt]		-- Template
       -> [CoreAlt]		-- Target
-      -> Maybe (TvSubstEnv, IdSubstEnv)
+      -> Maybe SubstEnv
 match_alts menv subst [] []
   = return subst
 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)