[Git][ghc/ghc][wip/T22404] Try to get benefits of fast path with less duplication

[Simon Peyton Jones (@simonpj)]

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


Commits:
e2326410 by Simon Peyton Jones at 2023-07-20T11:28:05+01:00
Try to get benefits of fast path with less duplication

- - - - -


1 changed file:

- compiler/GHC/Core/Opt/OccurAnal.hs


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -955,10 +955,10 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
     in WUD body_uds (combine [NonRec bndr rhs] res)
 
   -- /Existing/ non-recursive join points
-  -- Analyse the RHS and /then/ the body
-  | NotTopLevel <- lvl
-  , mb_join@(Just {}) <- isJoinId_maybe bndr
-  = let -- Analyse the rhs first, generating rhs_uds
+  -- See Note [Occurrence analysis for join points]
+  | mb_join@(Just {}) <- isJoinId_maybe bndr
+  = -- Analyse the RHS and /then/ the body
+    let -- Analyse the rhs first, generating rhs_uds
         !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env ire mb_join bndr rhs
         rhs_uds = foldr1 orUDs rhs_uds_s   -- Note orUDs
 
@@ -1007,10 +1007,13 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
     in if isDeadBinder tagged_bndr      -- Drop dead code; see Note [Dead code]
     then WUD body_uds body
     else let
-        -- Get the join info from the *new* decision
+        -- Get the join info from the *new* decision; NB: bndr is not already a JoinId
         -- See Note [Join points and unfoldings/rules]
         -- => join arity O of Note [Join arity prediction based on joinRhsArity]
-        mb_join = willBeJoinId_maybe tagged_bndr
+        mb_join = case tailCallInfo (idOccInfo tagged_bndr) of
+                    AlwaysTailCalled arity -> Just arity
+                    _                      -> Nothing
+
         !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs
     in WUD (foldr andUDs body_uds rhs_uds_s)      -- Note `andUDs`
            (combine [NonRec final_bndr rhs'] body)
@@ -1050,8 +1053,9 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
     -- hence adjust the UDs from the RHS
     WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $
                                 occAnalLamTail rhs_env rhs
-    final_bndr = bndr `setIdSpecialisation` mkRuleInfo rules'
-                      `setIdUnfolding` unf2
+    final_bndr | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
+               | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'
+                                          `setIdUnfolding` unf2
 
     --------- Unfolding ---------
     -- See Note [Join points and unfoldings/rules]
@@ -1076,9 +1080,10 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
          -- that g is (since the RULE might turn g into h), so
          -- we make g mention h.
 
-    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds
-    add_rule_uds (_, l, r) uds_s
-      = (l `andUDs` adjustTailArity mb_join r) : uds_s
+    adj_rule_uds :: [UsageDetails]
+    adj_rule_uds = imp_rule_uds ++
+                   [ l `andUDs` adjustTailArity mb_join r
+                   | (_,l,r) <- rules_w_uds ]
 
 
     ----------
@@ -1703,8 +1708,9 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
                  , nd_weak_fvs        = weak_fvs
                  , nd_active_rule_fvs = active_rule_fvs }
 
-    bndr' = bndr `setIdUnfolding`      unf'
-                 `setIdSpecialisation` mkRuleInfo rules'
+    bndr' | noBinderSwaps env = bndr  -- See Note [Unfoldings and rules]
+          | otherwise         = bndr `setIdUnfolding`      unf'
+                                     `setIdSpecialisation` mkRuleInfo rules'
 
     -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the
     --     JoinArity rhs_ja of unadj_rhs_uds.
@@ -2249,9 +2255,7 @@ occAnalUnfolding !env unf
         | isStableSource src ->
             let
               WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs
-
-              unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]
-                   | otherwise         = unf { uf_tmpl = rhs' }
+              unf' = unf { uf_tmpl = rhs' }
             in WTUD (TUD rhs_ja (markAllMany uds)) unf'
               -- markAllMany: see Note [Occurrences in stable unfoldings]
 
@@ -2283,8 +2287,7 @@ occAnalRules !env bndr
     occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
       = (rule', lhs_uds', TUD rhs_ja rhs_uds')
       where
-        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]
-              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }
+        rule' = rule { ru_args = args', ru_rhs = rhs' }
 
         WUD lhs_uds args' = addInScope env bndrs $ \env ->
                             occAnalList env args
@@ -2803,6 +2806,7 @@ data OccEnv
                -- Vars (TyVars and Ids) free in the range of occ_bs_env
 
              -- Usage details of the RHS of in-scope non-recursive join points
+             -- See Note [Occurrence analysis for join points]
            , occ_join_points :: !(IdEnv OccInfoEnv)
                -- Invariant: no Id maps to emptyDetails
     }



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e23264102f48d6e5b4efe85eb8c7087d8fb0d07a
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/20230720/fd02e26c/attachment-0001.html>