[Git][ghc/ghc][wip/T22404] 2 commits: Wibbles

[Simon Peyton Jones (@simonpj)]

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


Commits:
59662e48 by Simon Peyton Jones at 2023-07-13T16:37:05+01:00
Wibbles

- - - - -
8c50df16 by Simon Peyton Jones at 2023-07-13T16:40:12+01:00
Comments only

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Core.Predicate   ( isDictId )
 import GHC.Core.Type
 import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )
 
-import GHC.Data.Maybe( isJust, orElse )
+import GHC.Data.Maybe( isJust, isNothing, orElse )
 import GHC.Data.Graph.Directed ( SCC(..), Node(..)
                                , stronglyConnCompFromEdgedVerticesUniq
                                , stronglyConnCompFromEdgedVerticesUniqR )
@@ -954,7 +954,8 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
   = let !(WUD body_uds res) = addInScope env [bndr] thing_inside
     in WUD body_uds (combine [NonRec bndr rhs] res)
 
-  -- Non-recursive join points
+  -- /Existing/ non-recursive join points
+  -- Analyse the RHS and /then/ the body
   | NotTopLevel <- lvl
   , mb_join@(Just {}) <- isJoinId_maybe bndr
   , not (isStableUnfolding (realIdUnfolding bndr))
@@ -971,17 +972,18 @@ 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 WUD (rhs_uds `orUDs` body_uds)
+    else WUD (rhs_uds `orUDs` body_uds)    -- Note `orUDs`
              (combine [NonRec tagged_bndr rhs'] body)
 
-  -- The normal case
+  -- The normal case, including newly-discovered join points
+  -- Analyse the body and /then/ the RHS
   | otherwise
   = let WUD body_uds (tagged_bndr, body) = occAnalNonRecBody env lvl bndr thing_inside
         WUD bind_uds binds               = occAnalNonRecRhs  env ire tagged_bndr rhs
     in
     if isDeadBinder tagged_bndr      -- Drop dead code; see Note [Dead code]
     then WUD body_uds body
-    else WUD (bind_uds `andUDs` body_uds)
+    else WUD (bind_uds `andUDs` body_uds)      -- Note `andUDs`
              (combine binds body)
 
 -----------------
@@ -3500,24 +3502,26 @@ markAllInsideLamIf  False ud = ud
 markAllNonTailIf True  ud = markAllNonTail ud
 markAllNonTailIf False ud = ud
 
+lookupLocalDetails :: UsageDetails -> Id -> Maybe LocalOcc
+lookupLocalDetails uds id = lookupVarEnv (ud_env uds) id
+
+lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
+lookupTailCallInfo uds id
+  | not (id `elemVarEnv` ud_z_tail uds)
+  , Just (OneOccL { lo_tail = tail_info }) <- lookupLocalDetails uds id
+  = tail_info
+  | otherwise
+  = NoTailCallInfo
+
 lookupDetails :: UsageDetails -> Id -> OccInfo
 lookupDetails ud id
-  = case lookupVarEnv (ud_env ud) id of
+  = case lookupLocalDetails ud id of
       Just occ -> mkOccInfo ud id occ
       Nothing  -> IAmDead
 
 usedIn :: Id -> UsageDetails -> Bool
 v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
 
-{- Commenting out
-  = (emptyDetails{ud_env = interesting_env}, emptyDetails{ud_env = boring_env})
-  where
-    UD{ud_env=env} = flattenUsageDetails uds
-    (interesting_env,boring_env) = partitionVarEnv interesting env
-    interesting OneOcc{} = True
-    interesting _        = False
--}
-
 udFreeVars :: VarSet -> UsageDetails -> VarSet
 -- Find the subset of bndrs that are mentioned in uds
 udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)
@@ -3696,8 +3700,7 @@ tagRecBinders lvl body_uds details_s
          -- Can't use willBeJoinId_maybe here because we haven't tagged
          -- the binder yet (the tag depends on these adjustments!)
        | will_be_joins
-       , let occ = lookupDetails unadj_uds bndr
-       , AlwaysTailCalled arity <- tailCallInfo occ
+       , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr
        = Just arity
        | otherwise
        = assert (not will_be_joins) -- Should be AlwaysTailCalled if
@@ -3762,11 +3765,11 @@ decideJoinPointHood NotTopLevel usage bndrs
   where
     bndr1 = NE.head bndrs
     lost_join_point
-      | isDeadOcc (lookupDetails usage bndr1) = False
-      | all_ok                                = False
+      | isNothing (lookupLocalDetails usage bndr1) = False  -- Dead
+      | all_ok                                     = False
       | otherwise
       = pprTrace "djph"
-          (let arity = case (tailCallInfo (lookupDetails usage bndr1)) of
+          (let arity = case lookupTailCallInfo usage bndr1 of
                          AlwaysTailCalled ar -> ar
                          NoTailCallInfo -> 0
            in vcat [ text "bndr1:" <+> ppr bndr1
@@ -3784,7 +3787,7 @@ decideJoinPointHood NotTopLevel usage bndrs
 
     ok bndr
       | -- Invariant 1: Only tail calls, all same join arity
-        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)
+        AlwaysTailCalled arity <- lookupTailCallInfo usage bndr
 
       , -- Invariant 1 as applied to LHSes of rules
         all (ok_rule arity) (idCoreRules bndr)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4075814dd598d9eb904dc2587d7ff365cc850f4...8c50df1664c28550853d0b3daaf5cf2d97b19683

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4075814dd598d9eb904dc2587d7ff365cc850f4...8c50df1664c28550853d0b3daaf5cf2d97b19683
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/20230713/535992cb/attachment-0001.html>