Adjust Activations for specialise and work/wrap, and better simplify in InlineRules

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 37fa798..b7084c8 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -662,7 +662,7 @@ addNonRecWithUnf env new_bndr new_rhs new_unfolding
 
 ------------------------------
 simplUnfolding :: SimplEnv-> TopLevelFlag
-              -> Id    -- Debug output only
+              -> Id
               -> OccInfo -> OutExpr
               -> Unfolding -> SimplM Unfolding
 -- Note [Setting the new unfolding]
@@ -671,18 +671,20 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
   where
     ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
 
-simplUnfolding env top_lvl _ _ _ 
+simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
   | isInlineRuleSource src
-  = do { expr' <- simplExpr (updMode updModeForInlineRules env) expr
-                      -- See Note [Simplifying gently inside InlineRules] in SimplUtils
+  = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
        ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
                -- See Note [Top-level flag on inline rules] in CoreUnfold
+  where
+    rule_env = updMode (updModeForInlineRules (idInlineActivation id)) env
+                      -- See Note [Simplifying gently inside InlineRules] in SimplUtils
 
-simplUnfolding _ top_lvl _ _occ_info new_rhs _
-  = return (mkUnfolding (isTopLevel top_lvl) new_rhs)
+simplUnfolding _ top_lvl id _occ_info new_rhs _
+  = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   --        (b) In TidyPgm we currently assume that, if we want to
@@ -874,7 +876,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType
         -- Kept monadic just so we can do the seqType
 simplType env ty
   = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
-    seqType new_ty   `seq`   return new_ty
+    seqType new_ty `seq` return new_ty
   where
     new_ty = substTy env ty
 
@@ -883,8 +885,9 @@ simplCoercion :: SimplEnv -> InType -> SimplM OutType
 -- The InType isn't *necessarily* a coercion, but it might be
 -- (in a type application, say) and optCoercion is a no-op on types
 simplCoercion env co
-  = do { co' <- simplType env co
-       ; return (optCoercion co') }
+  = seqType new_co `seq` return new_co
+  where 
+    new_co = optCoercion (getTvSubst env) co
 \end{code}
 
 
@@ -1724,7 +1727,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs
-  = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs)
+  = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons