[commit: ghc] wip/dmd-arity: Look at idArity in DmdAnal instead (58860a8)

[git at git.haskell.org]

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

On branch  : wip/dmd-arity
Link       : http://ghc.haskell.org/trac/ghc/changeset/58860a80198860c11efaa02c3fe0f72170c7ce8b/ghc

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

commit 58860a80198860c11efaa02c3fe0f72170c7ce8b
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date:   Tue Mar 5 12:54:46 2019 +0100

    Look at idArity in DmdAnal instead
    
    Incorporating exprArity has the unfortunate side-effect that PAPs are
    automatically eta-expanded. This tries to work around that by looking at
    idArity directly.


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

58860a80198860c11efaa02c3fe0f72170c7ce8b
 compiler/stranal/DmdAnal.hs | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 90dcf08..31a5969 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -287,7 +287,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
 -- This is used for a non-recursive local let without manifest lambdas.
 -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
 dmdAnal' env dmd (Let (NonRec id rhs) body)
-  | useLetUp id rhs
+  | useLetUp id
   = (final_ty, Let (NonRec id' rhs') body')
   where
     (body_ty, body')   = dmdAnal env dmd body
@@ -602,7 +602,7 @@ dmdAnalRhsLetDown :: TopLevelFlag
 dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
   = (lazy_fv, id', mkLams bndrs' body')
   where
-    rhs_arity        = exprArity rhs
+    rhs_arity        = idArity id
     (bndrs, body, body_dmd)
        = case isJoinId_maybe id of
            Just join_arity  -- See Note [Demand analysis for join points]
@@ -610,7 +610,8 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
                    -> (bndrs, body, let_dmd)
 
            Nothing | (bndrs, body) <- collectBinders rhs
-                   -> (bndrs, body, mkBodyDmd env (exprArity body) body)
+                   , let body_arity = rhs_arity - count isId bndrs
+                   -> (bndrs, body, mkBodyDmd env body_arity body)
 
     env_body         = foldl' extendSigsWithLam env bndrs
     (body_ty, body') = dmdAnal env_body body_dmd body
@@ -618,7 +619,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
     DmdType rhs_fv rhs_dmds rhs_res
                      = ensureArgs rhs_arity rhs_ty -- zap possible deep CPR info
     sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
-    id'              = set_idStrictness env id rhs_arity sig_ty
+    id'              = set_idStrictness env id sig_ty
         -- See Note [NOINLINE and strictness]
 
 
@@ -658,7 +659,7 @@ mkBodyDmd env arity body
 --
 -- We use LetDown if there is a chance to get a useful strictness signature.
 -- This is the case when it takes any arguments before performing meaningful
--- work (cf. 'exprArity') or the binding is a join point (hence always acts like
+-- work (cf. 'idArity') or the binding is a join point (hence always acts like
 -- a function, not a value).
 --
 -- Thus, if the binding is not a join point and its arity is 0, we use LetUp.
@@ -667,8 +668,8 @@ mkBodyDmd env arity body
 -- makes a real difference wrt. usage demands. The other reason is being able to
 -- unleash a more precise product demand on its RHS once we know how the thunk
 -- was used in the let body.
-useLetUp :: Var -> CoreExpr -> Bool
-useLetUp f rhs = exprArity rhs == 0 && not (isJoinId f)
+useLetUp :: Var -> Bool
+useLetUp f = idArity f == 0 && not (isJoinId f)
 
 {- Note [Demand analysis for join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1206,10 +1207,9 @@ findBndrDmd env arg_of_dfun dmd_ty id
 
     fam_envs = ae_fam_envs env
 
-set_idStrictness :: AnalEnv -> Id -> Arity -> StrictSig -> Id
-set_idStrictness env id arity sig
+set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
+set_idStrictness env id sig
   = id `setIdStrictness` (killUsageSig (ae_dflags env) sig)
-       `setIdArity` arity -- computed by exprArity and must match sig
 
 dumpStrSig :: CoreProgram -> SDoc
 dumpStrSig binds = vcat (map printId ids)