[Git][ghc/ghc][wip/andreask/occ_anal_tuning] OccAnal: Be stricter when combining usageDetails.

8 Oct 2025

Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC


Commits:
19b591cd by Andreas Klebinger at 2025-10-08T09:05:48+02:00
OccAnal: Be stricter when combining usageDetails.

In combineUsageDetails when combining the underlying adds we compute a
new `LocalOcc` for each entry by combining the two existing ones.

Rather than wait for those entries to be forced down the road we now
force them immediately. Speeding up T26425 by about 10% with little
effect on the common case.

-------------------------
Metric Decrease:
    T26425
-------------------------

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Var/Env.hs


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -10,6 +10,10 @@
 -- bad for performance, so I increased the limit to allow it to unbox
 -- consistently.
 
+-- {-# OPTIONS_GHC -ddump-simpl -ddump-stg -dumpdir dumps -ddump-to-file #-}
+-- {-# OPTIONS_GHC -fdistinct-constructor-tables -finfo-table-map #-}
+-- {-# OPTIONS_GHC -ticky -ticky-allocd -ticky-LNE #-}
+
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
@@ -984,7 +988,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
   = -- Analyse the RHS and /then/ the body
     let -- Analyse the rhs first, generating rhs_uds
         !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs
-        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of
+        rhs_uds = foldl1' orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of
                                            -- Note [Occurrence analysis for join points]
 
         -- Now analyse the body, adding the join point
@@ -3650,8 +3654,10 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a
 -------------------
 -- UsageDetails API
 
-andUDs, orUDs
-        :: UsageDetails -> UsageDetails -> UsageDetails
+-- {-# NOINLINE andUDs #-}
+-- {-# NOINLINE orUDs #-}
+andUDs:: UsageDetails -> UsageDetails -> UsageDetails
+orUDs :: UsageDetails -> UsageDetails -> UsageDetails
 andUDs = combineUsageDetailsWith andLocalOcc
 orUDs  = combineUsageDetailsWith orLocalOcc
 
@@ -3760,16 +3766,17 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
 combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
                         -> UsageDetails -> UsageDetails -> UsageDetails
 {-# INLINE combineUsageDetailsWith #-}
+{-# SCC combineUsageDetailsWith #-}
 combineUsageDetailsWith plus_occ_info
     uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })
     uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })
   | isEmptyVarEnv env1 = uds2
   | isEmptyVarEnv env2 = uds1
   | otherwise
-  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2
-       , ud_z_many    = plusVarEnv z_many1   z_many2
-       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2
-       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }
+  = UD { ud_env       = {-# SCC ud_env #-} strictPlusVarEnv_C plus_occ_info env1 env2
+       , ud_z_many    = {-# SCC ud_z_many #-} strictPlusVarEnv z_many1   z_many2
+       , ud_z_in_lam  = {-# SCC ud_z_in_lam #-} strictPlusVarEnv z_in_lam1 z_in_lam2
+       , ud_z_tail    = {-# SCC ud_z_tail #-} strictPlusVarEnv z_tail1   z_tail2 }
 
 lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
 -- Don't use locally-generated occ_info for exported (visible-elsewhere)


=====================================
compiler/GHC/Data/Word64Map/Internal.hs
=====================================
@@ -3,6 +3,7 @@
 
 {-# OPTIONS_HADDOCK not-home #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -ddump-simpl -ddump-stg-final -ddump-to-file -dumpdir dumps #-}
 
 
 -----------------------------------------------------------------------------


=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -51,7 +51,9 @@ module GHC.Types.Unique.FM (
         delListFromUFM,
         delListFromUFM_Directly,
         plusUFM,
+        strictPlusUFM,
         plusUFM_C,
+        strictPlusUFM_C,
         plusUFM_CD,
         plusUFM_CD2,
         mergeUFM,
@@ -251,16 +253,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly
 delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt
 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)

--- Bindings in right argument shadow those in the left
+-- | Bindings in right argument shadow those in the left.
+--
+-- Unlike containers this union is right-biased for historic reasons.
 plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt
--- M.union is left-biased, plusUFM should be right-biased.
 plusUFM (UFM x) (UFM y) = UFM (M.union y x)
      -- Note (M.union y x), with arguments flipped
      -- M.union is left-biased, plusUFM should be right-biased.
 
+-- | Right biased
+strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt
+strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x)
+
 plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
 
+strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
+strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y)
+
 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
 -- combinding function and `d1` resp. `d2` as the default value if
 -- there is no entry in `m1` reps. `m2`. The domain is the union of


=====================================
compiler/GHC/Types/Var/Env.hs
=====================================
@@ -12,7 +12,8 @@ module GHC.Types.Var.Env (
         elemVarEnv, disjointVarEnv, anyVarEnv,
         extendVarEnv, extendVarEnv_C, extendVarEnv_Acc,
         extendVarEnvList,
-        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,
+        strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C,
+        plusVarEnv_CD, plusMaybeVarEnv_C,
         plusVarEnvList, alterVarEnv,
         delVarEnvList, delVarEnv,
         minusVarEnv,
@@ -511,6 +512,7 @@ extendVarEnv      :: VarEnv a -> Var -> a -> VarEnv a
 extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
 extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
 plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a
+strictPlusVarEnv  :: VarEnv a -> VarEnv a -> VarEnv a
 plusVarEnvList    :: [VarEnv a] -> VarEnv a
 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
 varEnvDomain      :: VarEnv elt -> UnVarSet
@@ -522,6 +524,7 @@ delVarEnvList     :: Foldable f => VarEnv a -> f Var -> VarEnv a
 delVarEnv         :: VarEnv a -> Var -> VarEnv a
 minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a
 plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
+strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
 plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
 plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a
 mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b
@@ -548,6 +551,7 @@ extendVarEnv_C   = addToUFM_C
 extendVarEnv_Acc = addToUFM_Acc
 extendVarEnvList = addListToUFM
 plusVarEnv_C     = plusUFM_C
+strictPlusVarEnv_C = strictPlusUFM_C
 plusVarEnv_CD    = plusUFM_CD
 plusMaybeVarEnv_C = plusMaybeUFM_C
 delVarEnvList    = delListFromUFM
@@ -556,6 +560,7 @@ delVarEnvList    = delListFromUFM
 delVarEnv        = delFromUFM
 minusVarEnv      = minusUFM
 plusVarEnv       = plusUFM
+strictPlusVarEnv = strictPlusUFM
 plusVarEnvList   = plusUFMList
 -- lookupVarEnv is very hot (in part due to being called by substTyVar),
 -- if it's not inlined than the mere allocation of the Just constructor causes



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19b591cd6036700f788cc082cb819ed0...
You're receiving this email because of your account on gitlab.haskell.org.

    

Andreas Klebinger (＠AndreasK)

tags

participants (1)