[commit: ghc] wip/nested-cpr: Do not attach CPR information to data constructor ids (6a238e3)

[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/6a238e34ddd9f9a4ad705d46819c7234ca92e166/ghc

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

commit 6a238e34ddd9f9a4ad705d46819c7234ca92e166
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Jan 17 10:36:09 2014 +0000

    Do not attach CPR information to data constructor ids
    
    because the worker is handled specially by the demand analyser, and the
    wrapper is expected to be inlined before that.
    
    There are corner cases (such as undersaturated calls) where this loses
    information, but nofib does not know any of these.
    
    On the other side it simplifies and removes code, and it makes it easier
    to get holdof the DynFlags whenever we create CPR information.


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

6a238e34ddd9f9a4ad705d46819c7234ca92e166
 compiler/basicTypes/Demand.lhs                     |    5 +--
 compiler/basicTypes/MkId.lhs                       |   37 ++------------------
 .../tests/simplCore/should_compile/T7360.stderr    |    2 +-
 3 files changed, 4 insertions(+), 40 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 475890c..0a864ed 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -28,7 +28,7 @@ module Demand (
 
         DmdResult, CPRResult,
         isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
-        topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
+        topRes, convRes, botRes, cprProdRes, cprSumRes,
         splitNestedRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         returnsCPR_maybe,
@@ -876,9 +876,6 @@ forgetSumCPR_help (RetProd ds) = RetProd (map forgetSumCPR ds)
 forgetSumCPR_help (RetSum _)   = NoCPR
 forgetSumCPR_help NoCPR        = NoCPR
 
-vanillaCprProdRes :: Arity -> DmdResult
-vanillaCprProdRes arity = cprProdRes (replicate arity topRes)
-
 splitNestedRes :: DmdResult -> [DmdResult]
 splitNestedRes Diverges      = repeat topRes
 splitNestedRes (Dunno c)     = splitNestedCPR c
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 150cf0d..1e6f3ee 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -389,11 +389,9 @@ mkDataConWorkId wkr_name data_con
     wkr_arity = dataConRepArity data_con
     wkr_info  = noCafIdInfo
                 `setArityInfo`       wkr_arity
-                `setStrictnessInfo`  wkr_sig
                 `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                      -- even if arity = 0
 
-    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
         -- Notice that we do *not* say the worker is strict
         -- even if the data constructor is declared strict
@@ -426,33 +424,6 @@ mkDataConWorkId wkr_name data_con
                    mkCompulsoryUnfolding $ 
                    mkLams nt_tvs $ Lam id_arg1 $ 
                    wrapNewTypeBody tycon res_ty_args (Var id_arg1)
-
-dataConCPR :: DataCon -> DmdResult
-dataConCPR con
-  | isDataTyCon tycon     -- Real data types only; that is, 
-                          -- not unboxed tuples or newtypes
-  , isVanillaDataCon con  -- No existentials 
-  , wkr_arity > 0
-  , wkr_arity <= mAX_CPR_SIZE
-  = if is_prod then vanillaCprProdRes (dataConRepArity con)
-               else cprSumRes (dataConTag con)
-  | otherwise
-  = topRes
-  where
-    is_prod = isProductTyCon tycon
-    tycon = dataConTyCon con
-    wkr_arity = dataConRepArity con
-
-    mAX_CPR_SIZE :: Arity
-    mAX_CPR_SIZE = 10
-    -- We do not treat very big tuples as CPR-ish:
-    --      a) for a start we get into trouble because there aren't 
-    --         "enough" unboxed tuple types (a tiresome restriction, 
-    --         but hard to fix), 
-    --      b) more importantly, big unboxed tuples get returned mainly
-    --         on the stack, and are often then allocated in the heap
-    --         by the caller.  So doing CPR for them may in fact make
-    --         things worse.
 \end{code}
 
 -------------------------------------------------
@@ -497,16 +468,12 @@ mkDataConRep dflags fam_envs wrap_name data_con
                     	     -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                     	     -- so it not make sure that the CAF info is sane
 
-             wrap_sig_conv = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
-             wrap_sig | any isBanged (dropList eq_spec wrap_bangs) = sigMayDiverge wrap_sig_conv
-                      | otherwise                                  = wrap_sig_conv
+             wrap_sig = mkClosedStrictSig wrap_arg_dmds topRes
 
     	     wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
     	     mk_dmd str | isBanged str = evalDmd
     	                | otherwise    = topDmd
-    	         -- The Cpr info can be important inside INLINE rhss, where the
-    	         -- wrapper constructor isn't inlined.
-    	         -- And the argument strictness can be important too; we
+    	         -- The argument strictness can be important; we
     	         -- may not inline a contructor when it is partially applied.
     	         -- For example:
     	         --      data W = C !Int !Int !Int
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index b3f70e9..627dc32 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -6,7 +6,7 @@ T7360.$WFoo3 [InlPrag=INLINE] :: GHC.Types.Int -> T7360.Foo
 [GblId[DataConWrapper],
  Arity=1,
  Caf=NoCafRefs,
- Str=DmdType <S,U>m3,
+ Str=DmdType <S,U>,
  Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
          ConLike=True, WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=True)