X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplEnv.lhs;h=699ba7be15f39b8ee390907894efb6fe606c34dc;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hp=1b057379b4cd8d063e3093cc896ff73ab0a97375;hpb=be7bf80fec1f471ceccbbe06885c265411baf25e;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 1b05737..699ba7b 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -46,7 +46,7 @@ module SimplEnv (
 
 #include "HsVersions.h"
 
-import SimplMonad	
+import SimplMonad
 import IdInfo
 import CoreSyn
 import Rules
@@ -64,7 +64,9 @@ import Coercion
 import BasicTypes	
 import DynFlags
 import Util
+import MonadUtils
 import Outputable
+import FastString
 
 import Data.List
 \end{code}
@@ -455,15 +457,19 @@ floatBinds (Floats bs _) = fromOL bs
 
 
 \begin{code}
-substId :: SimplEnv -> Id -> SimplSR
+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
-	Just (DoneId v) -> DoneId (refine in_scope v)
-	Just res	-> res
-	Nothing		-> DoneId (refine in_scope v)
+	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 res	      -> res	-- DoneEx non-var, or ContEx
   where
 
 	-- Get the most up-to-date thing from the in-scope set
@@ -473,7 +479,7 @@ refine in_scope v = case lookupInScope in_scope v of
 			 Just v' -> v'
 			 Nothing -> WARN( True, ppr v ) v	-- This is an error!
 
-lookupRecBndr :: SimplEnv -> Id -> Id
+lookupRecBndr :: SimplEnv -> InId -> OutId
 -- Look up an Id which has been put into the envt by simplRecBndrs,
 -- but where we have not yet done its RHS
 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
@@ -496,8 +502,8 @@ These functions are in the monad only so that they can be made strict via seq.
 \begin{code}
 simplBinders, simplLamBndrs
 	:: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
-simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
 
 -------------
 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@ -515,18 +521,19 @@ simplBinder env bndr
 -------------
 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 -- Used for lambda binders.  These sometimes have unfoldings added by
--- the worker/wrapper pass that must be preserved, becuase they can't
+-- the worker/wrapper pass that must be preserved, because they can't
 -- be reconstructed from context.  For example:
 --	f x = case x of (a,b) -> fw a b x
 --	fw a b x{=(a,b)} = ...
 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 simplLamBndr env bndr
-  | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr	-- Normal case
-  | otherwise					= seqId id2 `seq` return (env', id2)
+  | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2)  -- Special case
+  | otherwise 				  = simplBinder env bndr	 	-- Normal case
   where
     old_unf = idUnfolding bndr
-    (env', id1) = substIdBndr env bndr
-    id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+    (env1, id1) = substIdBndr env bndr
+    id2  = id1 `setIdUnfolding` substUnfolding env old_unf
+    env2 = modifyInScope env1 id1 id2
 
 ---------------
 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@ -617,7 +624,7 @@ Can we eta-expand f?  Only if we see that f has arity 1, and then we
 take advantage of the 'state hack' on the result of
 (f y) :: State# -> (State#, Int) to expand the arity one more.
 
-There is a disadvantage though.  Making the arity visible in the RHA
+There is a disadvantage though.  Making the arity visible in the RHS
 allows us to eta-reduce
 	f = \x -> f x
 to
@@ -655,7 +662,7 @@ addBndrRules env in_id out_id
   where
     subst     = mkCoreSubst env
     old_rules = idSpecialisation in_id
-    new_rules = CoreSubst.substSpec subst old_rules
+    new_rules = CoreSubst.substSpec subst out_id old_rules
     final_id  = out_id `setIdSpecialisation` new_rules
 
 ------------------