[Git][ghc/ghc][wip/T17932] Demand analysis: simplify the demand for a RHS

[Sebastian Graf]

Sebastian Graf pushed to branch wip/T17932 at Glasgow Haskell Compiler / GHC


Commits:
aa89fe2d by Simon Peyton Jones at 2020-03-20T12:38:58Z
Demand analysis: simplify the demand for a RHS

Ticket #17932 showed that we were using a stupid demand for the RHS
of a let-binding, when the result is a product.  This was the result
of a "fix" in 2013, which (happily) turns out to no longer be
necessary.

So I just deleted the code, which simplifies the demand analyser,
and fixes #17932.

I tried nofib, and got 0.0% perf changes.

All this came up when messing about with !2873 (ticket #17917),
but is idependent of it.

- - - - -


4 changed files:

- compiler/GHC/Core/Op/DmdAnal.hs
- + testsuite/tests/stranal/sigs/T17932.hs
- + testsuite/tests/stranal/sigs/T17932.stderr
- testsuite/tests/stranal/sigs/all.T


Changes:

=====================================
compiler/GHC/Core/Op/DmdAnal.hs
=====================================
@@ -617,16 +617,11 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
     is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
 
 -- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
--- unleashing on the given function's @rhs@, by creating a call demand of
--- @rhs_arity@ with a body demand appropriate for possible product types.
--- See Note [Product demands for function body].
--- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a
--- clean usage demand of @C1(C1(U(U,U)))@.
+-- unleashing on the given function's @rhs@, by creating
+-- a call demand of @rhs_arity@
+-- See Historical Note [Product demands for function body]
 mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
-mkRhsDmd env rhs_arity rhs =
-  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of
-    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))
-    _                 -> mkCallDmds rhs_arity cleanEvalDmd
+mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd
 
 -- | If given the let-bound 'Id', 'useLetUp' determines whether we should
 -- process the binding up (body before rhs) or down (rhs before body).
@@ -857,9 +852,9 @@ forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
 GHC.Core.Arity)! A small example is the test case NewtypeArity.
 
 
-Note [Product demands for function body]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This example comes from shootout/binary_trees:
+Historical Note [Product demands for function body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In 2013 I spotted this example, in shootout/binary_trees:
 
     Main.check' = \ b z ds. case z of z' { I# ip ->
                                 case ds_d13s of
@@ -878,8 +873,12 @@ Here we *really* want to unbox z, even though it appears to be used boxed in
 the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
 the whole function gets the CPR property if we do.
 
-So for the demand on the body of a RHS we use a product demand if it's
-a product type.
+That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where
+(solely because the result was a product) we used a product demand
+(albeit with lazy components) for the body. But that gives very silly
+behaviour -- see #17932.   Happily it turns out now to be entirely
+unnecessary: we get good results with C(C(C(S))).   So I simply
+deleted the special case.
 
 ************************************************************************
 *                                                                      *


=====================================
testsuite/tests/stranal/sigs/T17932.hs
=====================================
@@ -0,0 +1,11 @@
+-- See commentary in #17932
+
+module T17932 where
+
+flags (Options f x)
+  = reverse (reverse (reverse (reverse (reverse (reverse (reverse (reverse x)))))))
+  `seq` f
+
+data X = X String Bool Bool Bool Bool
+
+data Options = Options !X [Int]


=====================================
testsuite/tests/stranal/sigs/T17932.stderr
=====================================
@@ -0,0 +1,30 @@
+
+==================== Strictness signatures ====================
+T17932.$tc'Options:
+T17932.$tc'X:
+T17932.$tcOptions:
+T17932.$tcX:
+T17932.$trModule:
+T17932.flags: <S(SS),1*U(1*U,1*U)>
+
+
+
+==================== Cpr signatures ====================
+T17932.$tc'Options: m1
+T17932.$tc'X: m1
+T17932.$tcOptions: m1
+T17932.$tcX: m1
+T17932.$trModule: m1
+T17932.flags: m1
+
+
+
+==================== Strictness signatures ====================
+T17932.$tc'Options:
+T17932.$tc'X:
+T17932.$tcOptions:
+T17932.$tcX:
+T17932.$trModule:
+T17932.flags: <S(SS),1*U(1*U,1*U)>
+
+


=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -19,3 +19,4 @@ test('T12370', normal, compile, [''])
 test('CaseBinderCPR', normal, compile, [''])
 test('NewtypeArity', normal, compile, [''])
 test('T5075', normal, compile, [''])
+test('T17932', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/aa89fe2dec16e68b77dc13574a503a00c589fe5c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/aa89fe2dec16e68b77dc13574a503a00c589fe5c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200320/eb0fc260/attachment-0001.html>