X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSubst.lhs;h=9f1e20db4d20d83d95810bd15c5ffc1cbb6ed6d1;hp=4b42c0dcafb48c7333daaae65ba4a4cc5a7bc479;hb=b06d623b2e367a572de5daf06d6a0b12c2740471;hpb=43b5afae2ef2a0ebd29d88dc379ddfc0c793bebd

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 4b42c0d..9f1e20d 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -13,7 +13,7 @@ module CoreSubst (
         -- ** Substituting into expressions and related types
 	deShadowBinds, substSpec, substRulesForImportedIds,
 	substTy, substExpr, substBind, substUnfolding,
-	substInlineRuleInfo, lookupIdSubst, lookupTvSubst, substIdOcc,
+	substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
 
         -- ** Operations on substitutions
 	emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
@@ -39,6 +39,7 @@ import OccurAnal( occurAnalyseExpr )
 
 import qualified Type
 import Type     ( Type, TvSubst(..), TvSubstEnv )
+import OptCoercion ( optCoercion )
 import VarSet
 import VarEnv
 import Id
@@ -290,7 +291,10 @@ substExpr subst expr
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co)     = Cast (go e) (substTy subst co)
+    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+	-- Optimise coercions as we go; this is good, for example
+	-- in the RHS of rules, which are only substituted in
+
     go (Lam bndr body) = Lam bndr' (substExpr subst' body)
 		       where
 			 (subst', bndr') = substBndr subst bndr
@@ -463,8 +467,10 @@ substTyVarBndr (Subst in_scope id_env tv_env) tv
 
 -- | See 'Type.substTy'
 substTy :: Subst -> Type -> Type 
-substTy (Subst in_scope _id_env tv_env) ty
-  = Type.substTy (TvSubst in_scope tv_env) ty
+substTy subst ty = Type.substTy (getTvSubst subst) ty
+
+getTvSubst :: Subst -> TvSubst
+getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
 \end{code}
 
 
@@ -507,30 +513,40 @@ substUnfolding :: Subst -> Unfolding -> Unfolding
 substUnfolding subst (DFunUnfolding con args)
   = DFunUnfolding con (map (substExpr subst) args)
 
-substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
 	-- Retain an InlineRule!
+  | not (isInlineRuleSource src)  -- Always zap a CoreUnfolding, to save substitution work
+  = NoUnfolding
+  | otherwise                     -- But keep an InlineRule!
   = seqExpr new_tmpl `seq` 
-    new_mb_wkr `seq`
-    unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } }
+    new_src `seq`
+    unf { uf_tmpl = new_tmpl, uf_src = new_src }
   where
-    new_tmpl   = substExpr subst tmpl
-    new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide)
-
-substUnfolding _ (CoreUnfolding {}) = NoUnfolding	-- Discard
-	-- Always zap a CoreUnfolding, to save substitution work
+    new_tmpl = substExpr subst tmpl
+    new_src  = substUnfoldingSource subst src
 
-substUnfolding _ unf = unf	-- Otherwise no substitution to do
+substUnfolding _ unf = unf	-- NoUnfolding, OtherCon
 
 -------------------
-substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo
-substInlineRuleGuidance subst (InlWrapper wkr)
-  = case lookupIdSubst subst wkr of
-      Var w1 -> InlWrapper w1
-      other  -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr )
-      	        InlUnSat   -- Worker has got substituted away altogether
-			   -- (This can happen if it's trivial, via
-			   --  postInlineUnconditionally, hence only warning)
-substInlineRuleGuidance _ info = info
+substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
+substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+  | Just wkr_expr <- lookupVarEnv ids wkr 
+  = case wkr_expr of
+      Var w1 -> InlineWrapper w1
+      _other -> WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr 
+                            <+> ifPprDebug (equals <+> ppr wkr_expr) )   
+			      -- Note [Worker inlining]
+                InlineRule    -- It's not a wrapper any more, but still inline it!
+
+  | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
+  | otherwise = WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
+    	      	-- This can legitimately happen.  The worker has been inlined and
+		-- dropped as dead code, because we don't treat the UnfoldingSource
+		-- as an "occurrence".
+                -- Note [Worker inlining]
+      	        InlineRule
+
+substUnfoldingSource _ src = src
 
 ------------------
 substIdOcc :: Subst -> Id -> Id
@@ -584,6 +600,18 @@ substVarSet subst fvs
 	| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
 \end{code}
 
+Note [Worker inlining]
+~~~~~~~~~~~~~~~~~~~~~~
+A worker can get sustituted away entirely.
+	- it might be trivial
+	- it might simply be very small
+We do not treat an InlWrapper as an 'occurrence' in the occurence 
+analyser, so it's possible that the worker is not even in scope any more.
+
+In all all these cases we simply drop the special case, returning to
+InlVanilla.  The WARN is just so I can see if it happens a lot.
+
+
 %************************************************************************
 %*									*
 	The Very Simple Optimiser