[Git][ghc/ghc][wip/T22404] Partition into OneOccs and ManyOccs

[Sebastian Graf (@sgraf812)]

Sebastian Graf pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC


Commits:
0ada2fca by Sebastian Graf at 2023-01-09T20:59:44+01:00
Partition into OneOccs and ManyOccs

- - - - -


1 changed file:

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


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -755,15 +755,16 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
   = let -- Analyse the rhs first, generating rhs_uds
         rhs_env = setRhsCtxt OccVanilla env
         WithUsageDetails rhs_uds rhs' = occAnalRhs rhs_env NonRecursive mb_join rhs
+        !(!one_uds, !many_uds) = partitionOneOccUDs rhs_uds
 
         -- Now analyse the body, adding the
         -- join-point into the environment with addJoinPoint
         (tagged_bndr, body_wuds)
            = occAnalNonRecBody env lvl bndr $ \env ->
-             thing_inside (addJoinPoint env bndr rhs_uds)
+             thing_inside (addJoinPoint env bndr one_uds)
 
         -- Build the WithUsageDetails for the join-point binding
-        bind_wuds = WithUsageDetails emptyDetails [NonRec tagged_bndr rhs']
+        bind_wuds = WithUsageDetails many_uds [NonRec tagged_bndr rhs']
     in
     finishNonRec combine tagged_bndr bind_wuds body_wuds
 
@@ -3167,6 +3168,15 @@ lookupDetails ud id
 usedIn :: Id -> UsageDetails -> Bool
 v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
 
+partitionOneOccUDs :: UsageDetails -> (UsageDetails, UsageDetails)
+partitionOneOccUDs uds
+  = (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)



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ada2fca7ae72f643558dbfdc7adf07d63882272
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/20230109/e4fb8381/attachment-0001.html>