[commit: ghc] wip/nested-cpr: Inline the datacon wrapper more aggressively (7a16718)

[git at git.haskell.org]

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

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/7a16718e934b0a6db8ac719c1a6eab8d2100ee36/ghc

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

commit 7a16718e934b0a6db8ac719c1a6eab8d2100ee36
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 14 10:18:48 2014 +0000

    Inline the datacon wrapper more aggressively
    
    so that the CPR analysis find the real constructor and can return a
    nested CPR result.
    
    An alternative would be to look through the unfolding and analize that
    (but that would only be a good idea if the wrapper is going to be
    inlined afterwards), or special-case wrappers in the demand analyzer.
    Both not very nice.
    
    According to nofib: The impact of this is (on code size and allocations)
    is ... nil.


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

7a16718e934b0a6db8ac719c1a6eab8d2100ee36
 compiler/basicTypes/MkId.lhs                       |    2 +-
 compiler/coreSyn/CoreUnfold.lhs                    |   31 ++++++++++++++++++++
 .../tests/deSugar/should_compile/T2431.stderr      |    2 +-
 .../tests/simplCore/should_compile/T7360.stderr    |    2 +-
 4 files changed, 34 insertions(+), 3 deletions(-)

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index b7716b2..150cf0d 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -513,7 +513,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
     	         --      ...(let w = C x in ...(w p q)...)...
     	         -- we want to see that w is strict in its two arguments
 
-    	     wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+             wrap_unf = mkDataConWrapUnfolding wrap_arity wrap_rhs
              wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     	     wrap_rhs = mkLams wrap_tvs $ 
     	                mkLams wrap_args $
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index a219de8..2df8139 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -29,6 +29,7 @@ module CoreUnfold (
         mkUnfolding, mkCoreUnfolding,
 	mkTopUnfolding, mkSimpleUnfolding,
 	mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
+        mkDataConWrapUnfolding,
 	mkCompulsoryUnfolding, mkDFunUnfolding,
 
 	interestingArg, ArgSummary(..),
@@ -127,6 +128,16 @@ mkInlineUnfolding mb_arity expr
               
     boring_ok = inlineBoringOk expr'
 
+mkDataConWrapUnfolding :: Arity -> CoreExpr -> Unfolding
+mkDataConWrapUnfolding arity expr
+  = mkCoreUnfolding InlineStable
+                    True
+                    expr' arity
+                    (UnfWhen needSaturated boringCxtOk)
+                    -- Note [Inline data constructor wrappers aggresively]
+  where
+    expr' = simpleOptExpr expr
+
 mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
 mkInlinableUnfolding dflags expr
   = mkUnfolding dflags InlineStable True is_bot expr'
@@ -199,6 +210,26 @@ This can occasionally mean that the guidance is very pessimistic;
 it gets fixed up next round.  And it should be rare, because large
 let-bound things that are dead are usually caught by preInlineUnconditionally
 
+Note [Inline data constructor wrappers aggresively]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wrappers for strict data type constructors are to be inlined even in
+a boring context. This increases the chance that the demand analyzer will
+see the real constructor and return a nested CPR property.
+
+For example:
+    data P a = P !a !b
+    f :: Int -> P Int Int
+    f x = P x x
+previously, the demand analyzer would only see
+    f x = $WP x x
+and infer a strictness signature of "<S,U>m(,)", i.e. a non-nested CPR property.
+
+But if we inline $WP, we get
+    f x = case x of _ -> P x x
+and we would get "<S,U>,m(t(),t())", i.e. a nested CPR property.
+
+A real world example of this issue is the function mean in [ticket:2289#comment:1].
+
 
 %************************************************************************
 %*									*
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index dbafaed..0d68d40 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -8,7 +8,7 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a T2431.:~: a
  Str=DmdType,
  Unf=Unf{Src=InlineStable, TopLvl=True, Arity=0, Value=True,
          ConLike=True, WorkFree=True, Expandable=True,
-         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
+         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=True)
          Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N}]
 T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N
 
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 51207a6..b3f70e9 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -9,7 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE] :: GHC.Types.Int -> T7360.Foo
  Str=DmdType <S,U>m3,
  Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
          ConLike=True, WorkFree=True, Expandable=True,
-         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
+         Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=True)
          Tmpl= \ (dt [Occ=Once!] :: GHC.Types.Int) ->
                  case dt of _ [Occ=Dead] { GHC.Types.I# dt [Occ=Once] ->
                  T7360.Foo3 dt