[commit: ghc] wip/T12618: Have SimpleWrapperUnfoldings (be4a16d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/be4a16dbc727fe35315a5bc47878d7e09e5f6288/ghc

>---------------------------------------------------------------

commit be4a16dbc727fe35315a5bc47878d7e09e5f6288
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Oct 14 15:34:23 2016 -0400

    Have SimpleWrapperUnfoldings
    
    to keep them apart from compulsory unfoldings for now, to avoid
    accidential unrelated effects of this patch.


>---------------------------------------------------------------

be4a16dbc727fe35315a5bc47878d7e09e5f6288
 compiler/basicTypes/MkId.hs    |  2 +-
 compiler/coreSyn/CoreSubst.hs  |  6 +++---
 compiler/coreSyn/CoreSyn.hs    | 15 +++++++++++----
 compiler/coreSyn/CoreUnfold.hs |  8 ++++----
 4 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 5daf492..ff1a530 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -499,7 +499,7 @@ mkSimpleDataConRep wrap_name dc
         -- Somewhat ugly, but there is no code generated for wrappers
         -- for unboxed tuples. Let's just get rid of them as soon as possible.
         | is_unbox_tup = mkCompulsoryUnfolding wrap_rhs
-        | otherwise    = mkCompulsorySatUnfolding wrap_arity wrap_rhs
+        | otherwise    = mkSimpleWrapperUnfolding wrap_arity wrap_rhs
     wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR dc)
     wrap_arg_dmds = replicate wrap_arity topDmd
     rep_strs = [ NotMarkedStrict | _ <- arg_tys ]
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 81bd3a8..de6e10a 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -927,8 +927,7 @@ simple_opt_expr subst expr
   where
     in_scope_env = (substInScope subst, simpleUnfoldingFun)
 
-    go (Var v) | isSatCompulsoryUnfolding (idUnfolding v) 0
-               , isAlwaysActive (idInlineActivation v)
+    go (Var v) | isSimpleWrapperUnfolding (idUnfolding v) 0
                =  go (unfoldingTemplate (idUnfolding v))
     go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
     go (App e1 e2)      = simple_app subst e1 [go e2]
@@ -1006,7 +1005,8 @@ simple_app subst (Lam b e) (a:as)
     (subst', b') = subst_opt_bndr subst b
     b2 = add_info subst' b b'
 simple_app subst (Var v) as
-  | isSatCompulsoryUnfolding (idUnfolding v) (length as)
+  | isCompulsoryUnfolding (idUnfolding v) ||
+    isSimpleWrapperUnfolding (idUnfolding v) (length as)
   , isAlwaysActive (idInlineActivation v)
   -- See Note [Unfold compulsory unfoldings in LHSs]
   =  simple_app subst (unfoldingTemplate (idUnfolding v)) as
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 724d61c..7bdbf39 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -57,7 +57,7 @@ module CoreSyn (
         maybeUnfoldingTemplate, otherCons,
         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-        isSatCompulsoryUnfolding,
+        isSimpleWrapperUnfolding,
         isStableUnfolding, hasStableCoreUnfolding_maybe,
         isClosedUnfolding, hasSomeUnfolding,
         isBootUnfolding,
@@ -1065,6 +1065,12 @@ data UnfoldingSource
                        --
                        -- See Note [InlineRules]
 
+  | InlineWrapper      -- A simple wrapper (e.g. for data constructors). Simple means that
+                       -- it applies in all phases, and the right hand side is simple
+                       -- enough so that it may occur on the LHS of a rule
+                       -- (no case expressions, for example).
+                       -- Such unfolding are applied in the LHS of a rule!
+
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
                        -- Only a few primop-like things have this property
                        -- (see MkId.hs, calls to mkCompulsoryUnfolding).
@@ -1180,6 +1186,7 @@ isStableSource :: UnfoldingSource -> Bool
 -- Keep the unfolding template
 isStableSource InlineCompulsory   = True
 isStableSource InlineStable       = True
+isStableSource InlineWrapper      = True
 isStableSource InlineRhs          = False
 
 -- | Retrieves the template of an unfolding: panics if none is known
@@ -1259,13 +1266,13 @@ isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
 isCompulsoryUnfolding _                                             = False
 
-isSatCompulsoryUnfolding :: Unfolding -> Arity -> Bool
-isSatCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory, uf_guidance = guidance }) arity
+isSimpleWrapperUnfolding :: Unfolding -> Arity -> Bool
+isSimpleWrapperUnfolding (CoreUnfolding { uf_src = InlineWrapper, uf_guidance = guidance }) arity
     | arity_ok guidance
     = True
   where arity_ok (UnfWhen { ug_arity = ug_arity })  = ug_arity <= arity
         arity_ok _ = True
-isSatCompulsoryUnfolding _ _
+isSimpleWrapperUnfolding _ _
     = False
 
 isStableUnfolding :: Unfolding -> Bool
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 958e3df..146f8c7 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -24,7 +24,7 @@ module CoreUnfold (
         mkUnfolding, mkCoreUnfolding,
         mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
         mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
-        mkCompulsoryUnfolding, mkCompulsorySatUnfolding, mkDFunUnfolding,
+        mkCompulsoryUnfolding, mkSimpleWrapperUnfolding, mkDFunUnfolding,
         specUnfolding,
 
         ArgSummary(..),
@@ -125,9 +125,9 @@ mkWorkerUnfolding dflags work_fn
 mkWorkerUnfolding _ _ _ = noUnfolding
 
 -- Inline very early, even in gentle, but only if saturated.
-mkCompulsorySatUnfolding :: Arity -> CoreExpr -> Unfolding
-mkCompulsorySatUnfolding arity expr
-  = mkCoreUnfolding InlineCompulsory True
+mkSimpleWrapperUnfolding :: Arity -> CoreExpr -> Unfolding
+mkSimpleWrapperUnfolding arity expr
+  = mkCoreUnfolding InlineWrapper True
                     (simpleOptExpr expr)
                     (UnfWhen { ug_arity = arity
                              , ug_unsat_ok = False