X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSubst.lhs;h=f63968e0fa132574c14e861875c0f1001fcb34fc;hp=cf086c8bf5053f1396b53841562c993c6e370c59;hb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4;hpb=d95ce839533391e7118257537044f01cbb1d6694

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index cf086c8..f63968e 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -12,7 +12,7 @@ module CoreSubst (
 
         -- ** Substituting into expressions and related types
 	deShadowBinds,
-	substTy, substExpr, substSpec, substUnfolding,
+	substTy, substExpr, substBind, substSpec, substWorker,
 	lookupIdSubst, lookupTvSubst, 
 
         -- ** Operations on substitutions
@@ -211,7 +211,7 @@ lookupIdSubst (Subst in_scope ids _) v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
 	-- Vital! See Note [Extending the Subst]
-  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope ) 
+  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v ) 
 		Var v
 
 -- | Find the substitution for a 'TyVar' in the 'Subst'
@@ -474,40 +474,31 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 substIdInfo subst new_id info
   | nothing_to_do = Nothing
   | otherwise     = Just (info `setSpecInfo`   	  substSpec subst new_id old_rules
-			       `setUnfoldingInfo` substUnfolding subst old_unf)
+			       `setWorkerInfo` 	  substWorker subst old_wrkr
+			       `setUnfoldingInfo` noUnfolding)
   where
     old_rules 	  = specInfo info
-    old_unf	  = unfoldingInfo info
-    nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
+    old_wrkr  	  = workerInfo info
+    nothing_to_do = isEmptySpecInfo old_rules &&
+		    not (workerExists old_wrkr) &&
+		    not (hasUnfolding (unfoldingInfo info))
     
 
 ------------------
--- | Substitutes for the 'Id's within an unfolding
-substUnfolding :: Subst -> Unfolding -> Unfolding
-	-- Seq'ing on the returned Unfolding is enough to cause
-	-- all the substitutions to happen completely
-substUnfolding subst unf@(InlineRule { uf_tmpl = tmpl, uf_worker = mb_wkr })
-	-- Retain an InlineRule!
-  = seqExpr new_tmpl `seq` 
-    new_mb_wkr `seq`
-    unf { uf_tmpl = new_tmpl, uf_worker = new_mb_wkr }
-  where
-    new_tmpl   = substExpr subst tmpl
-    new_mb_wkr = case mb_wkr of
-		  Nothing -> Nothing
-		  Just w  -> subst_wkr w
-
-    subst_wkr w = case lookupIdSubst subst w of
-		    Var w1 -> Just w1
-		    other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
-			      Nothing	-- Worker has got substituted away altogether
-					-- (This can happen if it's trivial, 
-					--  via postInlineUnconditionally, hence warning)
-
-substUnfolding _ (CoreUnfolding {}) = NoUnfolding	-- Discard
-	-- Always zap a CoreUnfolding, to save substitution work
-
-substUnfolding _ unf = unf	-- Otherwise no substitution to do
+-- | Substitutes for the 'Id's within the 'WorkerInfo'
+substWorker :: Subst -> WorkerInfo -> WorkerInfo
+	-- Seq'ing on the returned WorkerInfo is enough to cause all the 
+	-- substitutions to happen completely
+
+substWorker _ NoWorker
+  = NoWorker
+substWorker subst (HasWorker w a)
+  = case lookupIdSubst subst w of
+	Var w1 -> HasWorker w1 a
+	other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
+		  NoWorker	-- Worker has got substituted away altogether
+				-- (This can happen if it's trivial, 
+				--  via postInlineUnconditionally, hence warning)
 
 ------------------
 -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
@@ -521,7 +512,7 @@ substSpec subst new_fn (SpecInfo rules rhs_fvs)
     do_subst rule@(BuiltinRule {}) = rule
     do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
 	= rule { ru_bndrs = bndrs', 
-		 ru_fn    = new_name, 	-- Important: the function may have changed its name!
+		 ru_fn = new_name, 	-- Important: the function may have changed its name!
 		 ru_args  = map (substExpr subst') args,
 		 ru_rhs   = substExpr subst' rhs }
 	where