X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=865acdc98df9420d4766571c36c7bc3ac9fa7ca7;hb=5289f5d85610f71625a439747a09384876655eb5;hp=026bdef7c1a07c4b528c57937fa1cc1d95b2734e;hpb=0c9282a26594a9b803f7681270ac8c830e47a6e7;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 026bdef..865acdc 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -5,8 +5,8 @@
 
 \begin{code}
 module SimplEnv (
-	InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
-	OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
+	InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
+	OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
         InCoercion, OutCoercion,
 
 	-- The simplifier mode
@@ -29,7 +29,7 @@ module SimplEnv (
 
 	simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, 
  	simplBinder, simplBinders, addBndrRules,
-	substExpr, substTy, mkCoreSubst,
+	substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
 
 	-- Floats
   	Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
@@ -40,6 +40,7 @@ module SimplEnv (
 #include "HsVersions.h"
 
 import SimplMonad
+import CoreMonad	( SimplifierMode(..) )
 import IdInfo
 import CoreSyn
 import CoreUtils
@@ -49,12 +50,11 @@ import VarEnv
 import VarSet
 import OrdList
 import Id
-import qualified CoreSubst	( Subst, mkSubst, substExpr, substSpec, substUnfolding )
-import qualified Type		( substTy, substTyVarBndr )
-import Type hiding		( substTy, substTyVarBndr )
+import qualified CoreSubst
+import qualified Type		( substTy, substTyVarBndr, substTyVar )
+import Type hiding		( substTy, substTyVarBndr, substTyVar )
 import Coercion
 import BasicTypes	
-import DynFlags
 import MonadUtils
 import Outputable
 import FastString
@@ -70,6 +70,7 @@ import Data.List
 
 \begin{code}
 type InBndr     = CoreBndr
+type InVar      = Var			-- Not yet cloned
 type InId       = Id			-- Not yet cloned
 type InType     = Type			-- Ditto
 type InBind     = CoreBind
@@ -79,6 +80,7 @@ type InArg      = CoreArg
 type InCoercion = Coercion
 
 type OutBndr     = CoreBndr
+type OutVar	 = Var			-- Cloned
 type OutId	 = Id			-- Cloned
 type OutTyVar	 = TyVar		-- Cloned
 type OutType	 = Type			-- Cloned
@@ -129,7 +131,13 @@ pprSimplEnv :: SimplEnv -> SDoc
 -- Used for debugging; selective
 pprSimplEnv env
   = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
- 	  ptext (sLit "IdSubst:") <+> ppr (seIdSubst env) ]
+ 	  ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
+          ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
+    ]
+  where
+   in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
+             | otherwise = ppr v
 
 type SimplIdSubst = IdEnv SimplSR	-- IdId |--> OutExpr
 	-- See Note [Extending the Subst] in CoreSubst
@@ -152,7 +160,8 @@ instance Outputable SimplSR where
 	-- keep uniq _ = uniq `elemUFM_Directly` fvs
 \end{code}
 
-
+Note [SimplEnv invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 seInScope: 
 	The in-scope part of Subst includes *all* in-scope TyVars and Ids
 	The elements of the set may have better IdInfo than the
@@ -188,9 +197,8 @@ seIdSubst:
 * substId adds a binding (DoneId new_id) to the substitution if 
 	the Id's unique has changed
 
-
   Note, though that the substitution isn't necessarily extended
-  if the type changes.  Why not?  Because of the next point:
+  if the type of the Id changes.  Why not?  Because of the next point:
 
 * We *always, always* finish by looking up in the in-scope set 
   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
@@ -395,7 +403,9 @@ addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 -- in-scope set (although it might also have been created with newId)
 -- but it may now have more IdInfo
 addNonRec env id rhs
-  = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
+  = id `seq`   -- This seq forces the Id, and hence its IdInfo,
+	       -- and hence any inner substitutions
+    env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 	  seInScope = extendInScopeSet (seInScope env) id }
 
 extendFloats :: SimplEnv -> OutBind -> SimplEnv
@@ -526,7 +536,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- The substitution is extended only if the variable is cloned, because
 -- we *don't* need to use it to track occurrence info.
 simplBinder env bndr
-  | isTyVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
+  | isTyCoVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
 			; seqTyVar tv `seq` return (env', tv) }
   | otherwise     = do	{ let (env', id) = substIdBndr env bndr
 			; seqId id `seq` return (env', id) }
@@ -673,7 +683,7 @@ addBndrRules env in_id out_id
   | isEmptySpecInfo old_rules = (env, out_id)
   | otherwise = (modifyInScope env final_id, final_id)
   where
-    subst     = mkCoreSubst env
+    subst     = mkCoreSubst (text "local rules") env
     old_rules = idSpecialisation in_id
     new_rules = CoreSubst.substSpec subst out_id old_rules
     final_id  = out_id `setIdSpecialisation` new_rules
@@ -687,13 +697,19 @@ addBndrRules env in_id out_id
 %************************************************************************
 
 \begin{code}
+getTvSubst :: SimplEnv -> TvSubst
+getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
+  = mkTvSubst in_scope tv_env
+
 substTy :: SimplEnv -> Type -> Type 
-substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
-  = Type.substTy (TvSubst in_scope tv_env) ty
+substTy env ty = Type.substTy (getTvSubst env) ty
+
+substTyVar :: SimplEnv -> TyVar -> Type 
+substTyVar env tv = Type.substTyVar (getTvSubst env) tv
 
 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
-substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
-  = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
+substTyVarBndr env tv
+  = case Type.substTyVarBndr (getTvSubst env) tv of
 	(TvSubst in_scope' tv_env', tv') 
 	   -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 
@@ -702,15 +718,16 @@ substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 -- here.  I think the this will not usually result in a lot of work;
 -- the substitutions are typically small, and laziness will avoid work in many cases.
 
-mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
-mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
+mkCoreSubst  :: SDoc -> SimplEnv -> CoreSubst.Subst
+mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
   = mk_subst tv_env id_env
   where
     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 
     fiddle (DoneEx e)       = e
     fiddle (DoneId v)       = Var v
-    fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
+    fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
+    	   	      	      			-- Don't shortcut here
 
 ------------------
 substIdType :: SimplEnv -> Id -> Id
@@ -724,12 +741,16 @@ substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
     old_ty = idType id
 
 ------------------
-substExpr :: SimplEnv -> CoreExpr -> CoreExpr
-substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
+substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
+substExpr doc env
+  = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc) 
+                        (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env) 
   -- Do *not* short-cut in the case of an empty substitution
-  -- See CoreSubst: Note [Extending the Subst]
+  -- See Note [SimplEnv invariants]
 
 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
-substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf
+substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
+  -- Do *not* short-cut in the case of an empty substitution
+  -- See Note [SimplEnv invariants]
 \end{code}