[Git][ghc/ghc][wip/T22404] Wibbles

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Fri Jan 13 15:20:26 UTC 2023



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


Commits:
ff458a71 by Simon Peyton Jones at 2023-01-13T15:20:53+00:00
Wibbles

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -58,8 +58,8 @@ import GHC.Utils.Misc
 import GHC.Builtin.Names( runRWKey )
 import GHC.Unit.Module( Module )
 
-import Data.List (mapAccumL, mapAccumR)
-import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.List (mapAccumL)
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 
 {-
@@ -596,6 +596,10 @@ Hence the transitive rule_fv_env stuff described in
 Note [Rules and loop breakers].
 
 ------------------------------------------------------------
+Note [Occurrence analysis for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ToDo: addresses #22404.
+
 Note [Finding join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's the occurrence analyser's job to find bindings that we can turn into join
@@ -848,7 +852,9 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
   , not (idHasRules bndr)
   = let -- Analyse the rhs first, generating rhs_uds
         rhs_env = setRhsCtxt OccVanilla env
-        WithUsageDetails rhs_uds rhs' = occAnalRhs rhs_env NonRecursive mb_join rhs
+        WithUsageDetails rhs_uds rhs' = adjustNonRecRhs mb_join $
+                                        occAnalLamTail rhs_env rhs
+
         !(!one_uds, !many_uds) = partitionOneOccUDs rhs_uds
 
         -- Now analyse the body, adding the
@@ -900,7 +906,7 @@ finishNonRec combine tagged_bndr
 occAnalNonRecIdBind :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
                     -> WithUsageDetails [CoreBind]
 occAnalNonRecIdBind !env imp_rule_edges tagged_bndr rhs
-  = WithUsageDetails rhs_usage [NonRec final_bndr rhs']
+  = WithUsageDetails rhs_usage [NonRec final_bndr final_rhs]
   where
     -- Get the join info from the *new* decision
     -- See Note [Join points and unfoldings/rules]
@@ -928,7 +934,7 @@ occAnalNonRecIdBind !env imp_rule_edges tagged_bndr rhs
 
     --------- Unfolding ---------
     -- See Note [Join points and unfoldings/rules]
-    unf = idUnfolding bndr
+    unf = idUnfolding tagged_bndr
     WithTailUsageDetails unf_uds unf1 = occAnalUnfolding rhs_env unf
     unf2 = markNonRecUnfoldingOneShots mb_join_arity unf1
     adj_unf_uds = adjustTailArity mb_join_arity unf_uds
@@ -1019,12 +1025,9 @@ occAnalRec !_ _ scc (WithUsageDetails body_uds binds)
 occAnalRec !_ lvl
            (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
            (WithUsageDetails body_uds binds)
-  = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds)
+  = WithUsageDetails (body_uds `andUDs` rhs_uds')
+                     (NonRec bndr' rhs' : binds)
   where
-    tagged_bndr   = tagNonRecBinder lvl body_uds bndr
-    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds
-    mb_join_arity = willBeJoinId_maybe tagged_bndr
-
     tagged_bndr   = tagNonRecBinder lvl body_uds bndr
     mb_join_arity = willBeJoinId_maybe tagged_bndr
     WithUsageDetails rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds
@@ -1619,7 +1622,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
     -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage
     -- until occAnalRec. In effect, we pretend that the RHS becomes a
     -- non-recursive join point and fix up later with adjustTailUsage.
-    rhs_env = setRhsCtxt env
+    rhs_env = setRhsCtxt OccRhs env
     WithTailUsageDetails (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs
       -- corresponding call to adjustTailUsage in occAnalRec and tagRecBinders
 
@@ -2029,8 +2032,8 @@ occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
 -- See Note [Adjusting right-hand sides]
 occAnalLamTail env (Lam bndr expr)
   | isTyVar bndr
-  = addInScope env [bndr] $ \env ->
-    let WithTailUsageDetails (TUD ja usage) expr' <- occAnalLamTail env expr
+  = addInScopeTail env [bndr] $ \env ->
+    let WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env expr
     in WithTailUsageDetails (TUD (ja+1) usage) (Lam bndr expr')
        -- Important: Do not modify occ_encl, so that with a RHS like
        --   \(@ x) -> K @x (f @x)
@@ -2038,7 +2041,7 @@ occAnalLamTail env (Lam bndr expr)
        -- from inlining f. See the beginning of Note [Cascading inlines].
 
   | otherwise  -- So 'bndr' is an Id
-  = addInScope env [bndr] $ \env ->
+  = addInScopeTail env [bndr] $ \env ->
     let (env_one_shots', bndr1)
            = case occ_one_shots env of
                []         -> ([],  bndr)
@@ -2051,7 +2054,7 @@ occAnalLamTail env (Lam bndr expr)
         env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
         WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env1 expr
         bndr2 = tagLamBinder usage bndr1
-    in WithTailUsageDetails (TUD (ja+1) usage') (Lam bndr2 expr')
+    in WithTailUsageDetails (TUD (ja+1) usage) (Lam bndr2 expr')
 
 -- For casts, keep going in the same lambda-group
 -- See Note [Occurrence analysis for lambda binders]
@@ -2726,10 +2729,28 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
                                           OccRhs -> True
                                           _      -> False
 
-addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
+addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a)
+           -> WithUsageDetails a
+addInScope = add_in_scope fix_up
+  where
+    fix_up fix_up_usage (WithUsageDetails usage res)
+      = WithUsageDetails (fix_up_usage usage) res
+
+addInScopeTail :: OccEnv -> [Var] -> (OccEnv -> WithTailUsageDetails a)
+               -> WithTailUsageDetails a
+addInScopeTail = add_in_scope fix_up
+  where
+    fix_up fix_up_usage (WithTailUsageDetails (TUD ja usage) res)
+      = WithTailUsageDetails (TUD ja (fix_up_usage usage)) res
+
+add_in_scope :: ((UsageDetails -> UsageDetails) -> res -> res)
+             -> OccEnv -> [Var] -> (OccEnv -> res) -> res
 -- Needed for all Vars not just Ids; a TyVar might have a CoVars in its kind
-addInScope env@(OccEnv { occ_join_points = join_points }) bndrs thing_inside
-  = fix_up_uds $ thing_inside $ drop_shadowed_swaps $ drop_shadowed_joins env
+add_in_scope fix_up_result
+             env@(OccEnv { occ_join_points = join_points })
+             bndrs thing_inside
+  = fix_up_result fix_up_uds $ thing_inside $
+    drop_shadowed_swaps $ drop_shadowed_joins env
   where
 
     drop_shadowed_swaps :: OccEnv -> OccEnv
@@ -2744,11 +2765,11 @@ addInScope env@(OccEnv { occ_join_points = join_points }) bndrs thing_inside
     -- See Note [Occurrence analysis for join points]
     drop_shadowed_joins env = env { occ_join_points = good_joins `delVarEnvList` bndrs}
 
-    fix_up_uds :: WithUsageDetails a -> WithUsageDetails a
+    fix_up_uds :: UsageDetails -> UsageDetails
+    -- Remove usage for bndrs
     -- Add usage info for (a) CoVars used in the types of bndrs
     -- and (b) occ_join_points that we cannot push inwards because of shadowing
-    fix_up_uds (WithUsageDetails uds res)
-      = WithUsageDetails with_joins res
+    fix_up_uds uds = with_joins
       where
         trimmed_uds      = uds `delDetails` bndrs
         with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
@@ -3376,8 +3397,8 @@ adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage)
     exact_join = mb_join_arity == Just rhs_ja
 
 adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails
-adjustTailArity mb_rhs_ja (TUD ud_ja usage) =
-  markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage
+adjustTailArity mb_rhs_ja (TUD ud_ja usage)
+  = markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage
 
 markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
 -- For a /non-recursive/ join point we can mark all



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

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


More information about the ghc-commits mailing list