X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=0a7575a890be2ca70255f76b5d721a1f98f2402e;hb=7936b988d6d0a5f9a9b439c7d4a6adf616ddb9b5;hp=70e0fa11491c6bed378739750e9803cf97824fd5;hpb=3b896bc3a6fbc19ee311849aed046edcd75dca62;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 70e0fa1..0a7575a 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -271,9 +271,12 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v
 	-- _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
@@ -353,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
@@ -440,20 +443,25 @@ 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
 
@@ -461,9 +469,11 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 	-- Even though it isn't in the substitution, it may be in
 	-- the in-scope set with better IdInfo
 refine :: InScopeSet -> Var -> Var
-refine in_scope v = case lookupInScope in_scope v of
+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,
@@ -519,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)
@@ -644,7 +654,7 @@ addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 -- 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
@@ -667,7 +677,7 @@ substUnfolding :: SimplEnv -> Unfolding -> Unfolding
 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