[commit: ghc] wip/dmd-arity: Compute strictness signatures assuming idArity (79c909f)

[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/79c909f1f0f34a9f541a9228c5d649f6e44ee6a2/ghc

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

commit 79c909f1f0f34a9f541a9228c5d649f6e44ee6a2
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date:   Thu Feb 7 16:43:04 2019 +0100

    Compute strictness signatures assuming idArity


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

79c909f1f0f34a9f541a9228c5d649f6e44ee6a2
 compiler/basicTypes/Demand.hs |  6 +-----
 compiler/stranal/DmdAnal.hs   | 19 ++++++++++++-------
 2 files changed, 13 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 52bdf67..a4ba7c9 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -22,7 +22,7 @@ module Demand (
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         nopDmdType, botDmdType, mkDmdType,
-        addDemand, removeDmdTyArgs,
+        addDemand, ensureArgs,
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
 
         DmdEnv, emptyDmdEnv,
@@ -1207,10 +1207,6 @@ mkDmdType fv ds res = DmdType fv ds res
 dmdTypeDepth :: DmdType -> Arity
 dmdTypeDepth (DmdType _ ds _) = length ds
 
--- Remove any demand on arguments. This is used in dmdAnalRhs on the body
-removeDmdTyArgs :: DmdType -> DmdType
-removeDmdTyArgs = ensureArgs 0
-
 -- This makes sure we can use the demand type with n arguments,
 -- It extends the argument list with the correct resTypeArgDmd
 -- It also adjusts the DmdResult: Divergence survives additional arguments,
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index e4230e0..082a7e7 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -634,13 +634,14 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
                    -> (bndrs, body, let_dmd)
 
            Nothing | (bndrs, body) <- collectBinders rhs
-                   -> (bndrs, body, mkBodyDmd env body)
+                   , let body_arity = max (idArity id - length bndrs) 0
+                   -> (bndrs, body, mkBodyDmd env body_arity body)
 
     env_body         = foldl' extendSigsWithLam env bndrs
     (body_ty, body') = dmdAnal env_body body_dmd body
-    body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info
-    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
-                     = annotateLamBndrs env (isDFunId id) body_ty' bndrs
+    (rhs_ty, bndrs') = annotateLamBndrs env (isDFunId id) body_ty bndrs
+    DmdType rhs_fv rhs_dmds rhs_res
+                     = ensureArgs (idArity id) rhs_ty -- zap possible deep CPR info
     sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
     id'              = set_idStrictness env id sig_ty
         -- See Note [NOINLINE and strictness]
@@ -666,10 +667,14 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
        || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
           -- See Note [Optimistic CPR in the "virgin" case]
 
-mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand
+-- | Creates a 'CleanDemand' appropriate for unleashing on the given function
+-- body, by wrapping a head demand into @arity@ many calls.
 -- See Note [Product demands for function body]
-mkBodyDmd env body
-  = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
+mkBodyDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
+mkBodyDmd env arity body
+  = iterate mkCallDmd base !! arity
+  where
+    base = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
        Nothing            -> cleanEvalDmd
        Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)