Rewrite CorePrep and improve eta expansion

[ghc-hetmet.git] / compiler / coreSyn / CoreSubst.lhs

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index cf086c8..f63968e 100644 (file)
--- 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