diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-01-12 20:56:02 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-17 11:22:23 -0500 |
commit | a70bab97a0617bb9516b65d1d211b5e26ab51641 (patch) | |
tree | c689c34f54c7c4df5299254907e5654ee9ef91b4 | |
parent | fb94d102b932ee4e4193199c926369c9cd09b9dc (diff) | |
download | haskell-a70bab97a0617bb9516b65d1d211b5e26ab51641.tar.gz |
UnVarGraph: Improve asymptotics
This is a redesign of the UnVarGraph data structure used by the call
arity analysis to avoid the pathologically-poor performance observed in
issue #18789. Specifically, deletions were previously O(n) in the case
of graphs consisting of many complete (bipartite) sub-graphs. Together
with the nature of call arity this would produce quadratic behavior.
We now encode deletions specifically, taking care to do some light
normalization of empty structures. In the case of the
`Network.AWS.EC2.Types.Sum` module from #19203, this brings the
runtime of the call-arity analysis from over 50 seconds down to less
than 2 seconds.
Metric Decrease:
T15164
WWRec
-rw-r--r-- | compiler/GHC/Data/Graph/UnVar.hs | 96 |
1 files changed, 66 insertions, 30 deletions
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs index 3d6c805a20..05bafe98bc 100644 --- a/compiler/GHC/Data/Graph/UnVar.hs +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -34,7 +34,6 @@ import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Data.Bag import GHC.Types.Unique import qualified Data.IntSet as S @@ -64,12 +63,21 @@ isEmptyUnVarSet (UnVarSet s) = S.null s delUnVarSet :: UnVarSet -> Var -> UnVarSet delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s +minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s' + +sizeUnVarSet :: UnVarSet -> Int +sizeUnVarSet (UnVarSet s) = S.size s + mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs varEnvDom :: VarEnv a -> UnVarSet varEnvDom ae = UnVarSet $ ufmToSet_Directly ae +extendUnVarSet :: Var -> UnVarSet -> UnVarSet +extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s + unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) @@ -80,14 +88,13 @@ instance Outputable UnVarSet where ppr (UnVarSet s) = braces $ hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) +data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph + | CG !UnVarSet -- ^ complete graph + | Union UnVarGraph UnVarGraph + | Del !UnVarSet UnVarGraph emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag +emptyUnVarGraph = CG emptyUnVarSet unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph {- @@ -101,45 +108,74 @@ unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) = pprTrace "unionUnVarGraph fired2" empty $ completeGraph (s1 `unionUnVarSet` s2) -} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) +unionUnVarGraph a b + | is_null a = b + | is_null b = a + | otherwise = Union a b unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph -- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 +completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2 completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s +completeGraph s = prune $ CG s +-- (v' ∈ neighbors G v) <=> v--v' ∈ G neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) +neighbors = go + where + go (Del d g) v + | v `elemUnVarSet` d = emptyUnVarSet + | otherwise = go g v `minusUnVarSet` d + go (Union g1 g2) v = go g1 v `unionUnVarSet` go g2 v + go (CG s) v = if v `elemUnVarSet` s then s else emptyUnVarSet + go (CBPG s1 s2) v = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet` + (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet) -- hasLoopAt G v <=> v--v ∈ G hasLoopAt :: UnVarGraph -> Var -> Bool -hasLoopAt (UnVarGraph g) v = any go $ bagToList g - where go (CG s) = v `elemUnVarSet` s - go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 - +hasLoopAt = go + where + go (Del d g) v + | v `elemUnVarSet` d = False + | otherwise = go g v + go (Union g1 g2) v = go g1 v || go g2 v + go (CG s) v = v `elemUnVarSet` s + go (CBPG s1 s2) v = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) +delNode (Del d g) v = Del (extendUnVarSet v d) g +delNode g v + | is_null g = emptyUnVarGraph + | otherwise = Del (mkUnVarSet [v]) g +-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …` prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) +prune = go emptyUnVarSet + where + go :: UnVarSet -> UnVarGraph -> UnVarGraph + go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g + go dels (Union g1 g2) + | is_null g1' = g2' + | is_null g2' = g1' + | otherwise = Union g1' g2' + where + g1' = go dels g1 + g2' = go dels g2 + go dels (CG s) = CG (s `minusUnVarSet` dels) + go dels (CBPG s1 s2) = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels) + +-- | Shallow empty check. +is_null :: UnVarGraph -> Bool +is_null (CBPG s1 s2) = isEmptyUnVarSet s1 || isEmptyUnVarSet s2 +is_null (CG s) = isEmptyUnVarSet s +is_null _ = False -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g + ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g) + ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b) + ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s) + ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b) |