X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=0a7575a890be2ca70255f76b5d721a1f98f2402e;hp=127e8cbef933c55ed9bd484879a82ec93cc029ab;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=00fe4381668528eb2f60496eea97e433528d2bb8

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 127e8cb..0a7575a 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -4,13 +4,6 @@
 \section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module SimplEnv (
 	InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
 	OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
@@ -30,7 +23,7 @@ module SimplEnv (
 	mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, 
 	zapSubstEnv, setSubstEnv, 
 	getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-	getRules, 
+	getSimplRules, 
 
 	SimplSR(..), mkContEx, substId, lookupRecBndr,
 
@@ -49,7 +42,6 @@ module SimplEnv (
 import SimplMonad
 import IdInfo
 import CoreSyn
-import Rules
 import CoreUtils
 import CostCentre
 import Var
@@ -63,7 +55,6 @@ import Type hiding		( substTy, substTyVarBndr )
 import Coercion
 import BasicTypes	
 import DynFlags
-import Util
 import MonadUtils
 import Outputable
 import FastString
@@ -144,7 +135,7 @@ data SimplSR
 instance Outputable SimplSR where
   ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
   ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
-  ppr (ContEx tv id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
+  ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
 				ppr (filter_env tv), ppr (filter_env id) -}]
 	-- where
 	-- fvs = exprFreeVars e
@@ -277,12 +268,15 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v
 	-- Why delete?  Consider 
 	--	let x = a*b in (x, \x -> x+3)
 	-- We add [x |-> a*b] to the substitution, but we must
-	-- *delete* it from the substitution when going inside
+	-- _delete_ it from the substitution when going inside
 	-- the (\x -> ...)!
 
-modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
-modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
-  = env {seInScope = modifyInScopeSet in_scope v v'}
+modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
+-- The variable should already be in scope, but 
+-- replace the existing version with this new one
+-- which has more information
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v 
+  = env {seInScope = extendInScopeSet in_scope v}
 
 ---------------------
 zapSubstEnv :: SimplEnv -> SimplEnv
@@ -293,10 +287,6 @@ setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 
 mkContEx :: SimplEnv -> InExpr -> SimplSR
 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
-
-isEmptySimplSubst :: SimplEnv -> Bool
-isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
-  = isEmptyVarEnv tvs && isEmptyVarEnv ids
 \end{code}
 
 
@@ -352,7 +342,7 @@ instance Outputable FloatFlag where
 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 andFF FltCareful _ 	    = FltCareful
 andFF FltOkSpec  FltCareful = FltCareful
-andFF FltOkSpec  flt	    = FltOkSpec
+andFF FltOkSpec  _  	    = FltOkSpec
 andFF FltLifted  flt	    = flt
 
 classifyFF :: CoreBind -> FloatFlag
@@ -366,7 +356,7 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
   =  not (isNilOL fs) && want_to_float && can_float
   where
-     want_to_float = isTopLevel lvl || exprIsCheap rhs
+     want_to_float = isTopLevel lvl || exprIsExpandable rhs
      can_float = case ff of
 		   FltLifted  -> True
 	 	   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
@@ -420,7 +410,7 @@ addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 -- This is all very specific to the way recursive bindings are
 -- handled; see Simplify.simplRecBind
 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
-  = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 
 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
@@ -453,29 +443,37 @@ floatBinds (Floats bs _) = fromOL bs
 %*									*
 %************************************************************************
 
+Note [Global Ids in the substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look up even a global (eg imported) Id in the substitution. Consider
+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
+The binder-swap in the occurence analyser will add a binding
+for a LocalId version of g (with the same unique though):
+   case X.g_34 of b { (a,b) ->  let g_34 = b in 
+				... case X.g_34 of { (p,q) -> ...} ... }
+So we want to look up the inner X.g_34 in the substitution, where we'll
+find that it has been substituted by b.  (Or conceivably cloned.)
 
 \begin{code}
 substId :: SimplEnv -> InId -> SimplSR
 -- Returns DoneEx only on a non-Var expression
 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v 
-  | not (isLocalId v) 
-  = DoneId v
-  | otherwise	-- A local Id
-  = case lookupVarEnv ids v of
+  = case lookupVarEnv ids v of		-- Note [Global Ids in the substitution]
 	Nothing		      -> DoneId (refine in_scope v)
 	Just (DoneId v)       -> DoneId (refine in_scope v)
-	Just (DoneEx (Var v)) 
-	       | isLocalId v  -> DoneId (refine in_scope v)
-	       | otherwise    -> DoneId v
+	Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
 	Just res	      -> res	-- DoneEx non-var, or ContEx
   where
 
 	-- Get the most up-to-date thing from the in-scope set
 	-- Even though it isn't in the substitution, it may be in
 	-- the in-scope set with better IdInfo
-refine in_scope v = case lookupInScope in_scope v of
+refine :: InScopeSet -> Var -> Var
+refine in_scope v 
+  | isLocalId v = case lookupInScope in_scope v of
 			 Just v' -> v'
 			 Nothing -> WARN( True, ppr v ) v	-- This is an error!
+  | otherwise = v
 
 lookupRecBndr :: SimplEnv -> InId -> OutId
 -- Look up an Id which has been put into the envt by simplRecBndrs,
@@ -483,8 +481,8 @@ lookupRecBndr :: SimplEnv -> InId -> OutId
 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
   = case lookupVarEnv ids v of
 	Just (DoneId v) -> v
-	Just res	-> pprPanic "lookupRecBndr" (ppr v)
-	Nothing		-> refine in_scope v
+	Just _ -> pprPanic "lookupRecBndr" (ppr v)
+	Nothing -> refine in_scope v
 \end{code}
 
 
@@ -531,7 +529,7 @@ simplLamBndr env bndr
     old_unf = idUnfolding bndr
     (env1, id1) = substIdBndr env bndr
     id2  = id1 `setIdUnfolding` substUnfolding env old_unf
-    env2 = modifyInScope env1 id1 id2
+    env2 = modifyInScope env1 id2
 
 ---------------
 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@ -543,7 +541,7 @@ simplNonRecBndr env id
 ---------------
 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 -- Recursive let binders
-simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
+simplRecBndrs env@(SimplEnv {}) ids
   = do	{ let (env1, ids1) = mapAccumL substIdBndr env ids
 	; seqIds ids1 `seq` return env1 }
 
@@ -653,10 +651,10 @@ See Note [Loop breaking and RULES] in OccAnal.
 
 \begin{code}
 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
--- Rules are added back in to to hte bin
+-- Rules are added back in to to the bin
 addBndrRules env in_id out_id
   | isEmptySpecInfo old_rules = (env, out_id)
-  | otherwise = (modifyInScope env out_id final_id, final_id)
+  | otherwise = (modifyInScope env final_id, final_id)
   where
     subst     = mkCoreSubst env
     old_rules = idSpecialisation in_id
@@ -665,7 +663,7 @@ addBndrRules env in_id out_id
 
 ------------------
 substIdType :: SimplEnv -> Id -> Id
-substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
+substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
   | otherwise	= Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 		-- The tyVarsOfType is cheaper than it looks
@@ -676,14 +674,14 @@ substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 
 ------------------
 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
-substUnfolding env NoUnfolding     	       = NoUnfolding
-substUnfolding env (OtherCon cons) 	       = OtherCon cons
+substUnfolding _   NoUnfolding     	       = NoUnfolding
+substUnfolding _   (OtherCon cons) 	       = OtherCon cons
 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
+substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g
 
 ------------------
 substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
-substWorker env NoWorker = NoWorker
+substWorker _   NoWorker = NoWorker
 substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info
 \end{code}
 
@@ -721,8 +719,8 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id
     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 
 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
-substExpr env expr
-  | isEmptySimplSubst env = expr
-  | otherwise	          = CoreSubst.substExpr (mkCoreSubst env) expr
+substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr
+  -- Do *not* short-cut in the case of an empty substitution
+  -- See CoreSubst: Note [Extending the Subst]
 \end{code}