[Git][ghc/ghc][wip/T24623] Add strictCallArity

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T24623 at Glasgow Haskell Compiler / GHC


Commits:
85f84982 by Simon Peyton Jones at 2024-06-19T10:01:19+01:00
Add strictCallArity

- - - - -


2 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1104,8 +1104,9 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs
     (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity
                                                       rhs_dmds (de_div rhs_env) rhs'
 
-    dmd_sig_arity = ww_arity + calledOnceArity body_sd
+    dmd_sig_arity = ww_arity + strictCallArity body_sd
     sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)
+          -- strictCallArity is > 0 only for join points
           -- See Note [mkDmdSigForArity]
 
     opts       = ae_opts env


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.Types.Demand (
     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
     -- ** Other @Demand@ operations
     oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,
-    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, calledOnceArity,
+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity,
     mkWorkerDemand, subDemandIfEvaluated,
     -- ** Extracting one-shot information
     callCards, argOneShots, argsOneShots, saturatedByOneShots,
@@ -1038,11 +1038,11 @@ peelManyCalls k sd = go k C_11 sd
     go _ _  _                          = (topCard, topSubDmd)
 {-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context
 
-calledOnceArity :: SubDemand -> Arity
-calledOnceArity sd = go 0 sd
+strictCallArity :: SubDemand -> Arity
+strictCallArity sd = go 0 sd
   where
-    go n (viewCall -> Just (C_11, sd)) = go (n+1) sd
-    go n _                             = n
+    go n (Call card sd) | isStrict card = go (n+1) sd
+    go n _                              = n
 
 -- | Extract the 'SubDemand' of a 'Demand'.
 -- PRECONDITION: The SubDemand must be used in a context where the expression



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85f849826f1fe370f4ec9243f437f52701269c34

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85f849826f1fe370f4ec9243f437f52701269c34
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/20240619/c0707697/attachment-0001.html>