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

Commits:

4 changed files:

Changes:

  • compiler/GHC/Core/Opt/OccurAnal.hs
    ... ... @@ -9,6 +9,8 @@
    9 9 
     -- many /other/ arguments the function has.  Inconsistent unboxing is very
    10 10 
     -- bad for performance, so I increased the limit to allow it to unbox
    11 11 
     -- consistently.
    12 
    +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant.
    13 
    +
    12 14
    13 15 
     {-
    14 16 
     (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    ... ... @@ -62,6 +64,7 @@ import GHC.Utils.Misc
    62 64
    63 65 
     import GHC.Builtin.Names( runRWKey )
    64 66 
     import GHC.Unit.Module( Module )
    67 
    +import GHC.Data.Graph.UnVar as UnVar
    65 68
    66 69 
     import Data.List (mapAccumL)
    67 70 
     import Data.List.NonEmpty (NonEmpty (..))
    ... ... @@ -984,7 +987,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
    984 987 
       = -- Analyse the RHS and /then/ the body
    985 988 
         let -- Analyse the rhs first, generating rhs_uds
    986 989 
             !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs
    987 
    -        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of
    990 
    +        rhs_uds = foldl1' orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of
    988 991 
                                                -- Note [Occurrence analysis for join points]
    989 992
    990 993 
             -- Now analyse the body, adding the join point
    ... ... @@ -3610,6 +3613,7 @@ localTailCallInfo :: LocalOcc -> TailCallInfo
    3610 3613 
     localTailCallInfo (OneOccL  { lo_tail = tci }) = tci
    3611 3614 
     localTailCallInfo (ManyOccL tci)               = tci
    3612 3615
    3616 
    +-- type ZappedSet = UnVar.UnVarSet -- Values are ignored
    3613 3617 
     type ZappedSet = OccInfoEnv -- Values are ignored
    3614 3618
    3615 3619 
     data UsageDetails
    ... ... @@ -3650,8 +3654,8 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a
    3650 3654 
     -------------------
    3651 3655 
     -- UsageDetails API
    3652 3656
    3653 
    -andUDs, orUDs
    3654 
    -        :: UsageDetails -> UsageDetails -> UsageDetails
    3657 
    +andUDs:: UsageDetails -> UsageDetails -> UsageDetails
    3658 
    +orUDs :: UsageDetails -> UsageDetails -> UsageDetails
    3655 3659 
     andUDs = combineUsageDetailsWith andLocalOcc
    3656 3660 
     orUDs  = combineUsageDetailsWith orLocalOcc
    3657 3661
    ... ... @@ -3760,16 +3764,20 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
    3760 3764 
     combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
    3761 3765 
                             -> UsageDetails -> UsageDetails -> UsageDetails
    3762 3766 
     {-# INLINE combineUsageDetailsWith #-}
    3767 
    +{-# SCC combineUsageDetailsWith #-}
    3763 3768 
     combineUsageDetailsWith plus_occ_info
    3764 3769 
         uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })
    3765 3770 
         uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })
    3766 3771 
       | isEmptyVarEnv env1 = uds2
    3767 3772 
       | isEmptyVarEnv env2 = uds1
    3768 3773 
       | otherwise
    3769 
    -  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2
    3770 
    -       , ud_z_many    = plusVarEnv z_many1   z_many2
    3771 
    -       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2
    3772 
    -       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }
    3774 
    +  -- Typically we end up forcing those values later anyway. So we can avoid storking thunks retaining
    3775 
    +  -- the original LocalOcc by using a strict combination function here. The fields themselves are already
    3776 
    +  -- strict so no need to force those explicitly.
    3777 
    +  = UD { ud_env       = {-# SCC ud_env #-} strictPlusVarEnv_C plus_occ_info env1 env2
    3778 
    +       , ud_z_many    = {-# SCC ud_z_many #-} strictPlusVarEnv z_many1   z_many2
    3779 
    +       , ud_z_in_lam  = {-# SCC ud_z_in_lam #-} strictPlusVarEnv z_in_lam1 z_in_lam2
    3780 
    +       , ud_z_tail    = {-# SCC ud_z_tail #-} strictPlusVarEnv z_tail1   z_tail2 }
    3773 3781
    3774 3782 
     lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
    3775 3783 
     -- Don't use locally-generated occ_info for exported (visible-elsewhere)

  • compiler/GHC/Data/Graph/UnVar.hs
    ... ... @@ -17,8 +17,8 @@ equal to g, but twice as expensive and large.
    17 17 
     module GHC.Data.Graph.UnVar
    18 18 
         ( UnVarSet
    19 19 
         , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets
    20 
    -    , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList
    21 
    -    , elemUnVarSet, isEmptyUnVarSet
    20 
    +    , extendUnVarSet, extendUnVarSet_Directly, extendUnVarSetList, delUnVarSet, delUnVarSetList
    21 
    +    , elemUnVarSet, elemUnVarSet_Directly, isEmptyUnVarSet
    22 22 
         , UnVarGraph
    23 23 
         , emptyUnVarGraph
    24 24 
         , unionUnVarGraph, unionUnVarGraphs
    ... ... @@ -60,6 +60,9 @@ emptyUnVarSet = UnVarSet S.empty
    60 60 
     elemUnVarSet :: Var -> UnVarSet -> Bool
    61 61 
     elemUnVarSet v (UnVarSet s) = k v `S.member` s
    62 62
    63 
    +{-# INLINE elemUnVarSet_Directly #-}
    64 
    +elemUnVarSet_Directly :: Uniquable key => key -> UnVarSet -> Bool
    65 
    +elemUnVarSet_Directly v (UnVarSet s) = (getKey $ getUnique v) `S.member` s
    63 66
    64 67 
     isEmptyUnVarSet :: UnVarSet -> Bool
    65 68 
     isEmptyUnVarSet (UnVarSet s) = S.null s
    ... ... @@ -82,6 +85,10 @@ mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
    82 85 
     extendUnVarSet :: Var -> UnVarSet -> UnVarSet
    83 86 
     extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s
    84 87
    88 
    +{-# INLINE extendUnVarSet_Directly #-}
    89 
    +extendUnVarSet_Directly :: Uniquable key => key -> UnVarSet -> UnVarSet
    90 
    +extendUnVarSet_Directly u (UnVarSet s) = UnVarSet $ S.insert (getKey $ getUnique u) s
    91 
    +
    85 92 
     extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet
    86 93 
     extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs
    87 94

  • compiler/GHC/Types/Unique/FM.hs
    ... ... @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM (
    51 51 
             delListFromUFM,
    52 52 
             delListFromUFM_Directly,
    53 53 
             plusUFM,
    54 
    +        strictPlusUFM,
    54 55 
             plusUFM_C,
    56 
    +        strictPlusUFM_C,
    55 57 
             plusUFM_CD,
    56 58 
             plusUFM_CD2,
    57 59 
             mergeUFM,
    ... ... @@ -251,16 +253,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly
    251 253 
     delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt
    252 254 
     delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
    253 255
    254 
    --- Bindings in right argument shadow those in the left
    256 
    +-- | Bindings in right argument shadow those in the left.
    257 
    +--
    258 
    +-- Unlike containers this union is right-biased for historic reasons.
    255 259 
     plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt
    256 
    --- M.union is left-biased, plusUFM should be right-biased.
    257 260 
     plusUFM (UFM x) (UFM y) = UFM (M.union y x)
    258 261 
          -- Note (M.union y x), with arguments flipped
    259 262 
          -- M.union is left-biased, plusUFM should be right-biased.
    260 263
    264 
    +-- | Right biased
    265 
    +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt
    266 
    +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x)
    267 
    +
    261 268 
     plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
    262 269 
     plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
    263 270
    271 
    +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
    272 
    +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y)
    273 
    +
    264 274 
     -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
    265 275 
     -- combinding function and `d1` resp. `d2` as the default value if
    266 276 
     -- 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 (
    12 12 
             elemVarEnv, disjointVarEnv, anyVarEnv,
    13 13 
             extendVarEnv, extendVarEnv_C, extendVarEnv_Acc,
    14 14 
             extendVarEnvList,
    15 
    -        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C,
    15 
    +        strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C,
    16 
    +        plusVarEnv_CD, plusMaybeVarEnv_C,
    16 17 
             plusVarEnvList, alterVarEnv,
    17 18 
             delVarEnvList, delVarEnv,
    18 19 
             minusVarEnv,
    ... ... @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a
    511 512 
     extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
    512 513 
     extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
    513 514 
     plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a
    515 
    +strictPlusVarEnv  :: VarEnv a -> VarEnv a -> VarEnv a
    514 516 
     plusVarEnvList    :: [VarEnv a] -> VarEnv a
    515 517 
     extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
    516 518 
     varEnvDomain      :: VarEnv elt -> UnVarSet
    ... ... @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a
    522 524 
     delVarEnv         :: VarEnv a -> Var -> VarEnv a
    523 525 
     minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a
    524 526 
     plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
    527 
    +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
    525 528 
     plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
    526 529 
     plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a
    527 530 
     mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b
    ... ... @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C
    548 551 
     extendVarEnv_Acc = addToUFM_Acc
    549 552 
     extendVarEnvList = addListToUFM
    550 553 
     plusVarEnv_C     = plusUFM_C
    554 
    +strictPlusVarEnv_C = strictPlusUFM_C
    551 555 
     plusVarEnv_CD    = plusUFM_CD
    552 556 
     plusMaybeVarEnv_C = plusMaybeUFM_C
    553 557 
     delVarEnvList    = delListFromUFM
    ... ... @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM
    556 560 
     delVarEnv        = delFromUFM
    557 561 
     minusVarEnv      = minusUFM
    558 562 
     plusVarEnv       = plusUFM
    563 
    +strictPlusVarEnv = strictPlusUFM
    559 564 
     plusVarEnvList   = plusUFMList
    560 565 
     -- lookupVarEnv is very hot (in part due to being called by substTyVar),
    561 566 
     -- if it's not inlined than the mere allocation of the Just constructor causes

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help