Commit 35d1564c authored by niteria's avatar niteria

Provide Uniquable version of SCC

We want to remove the `Ord Unique` instance because there's
no way to implement it in deterministic way and it's too
easy to use by accident.

We sometimes compute SCC for datatypes whose Ord instance
is implemented in terms of Unique. The Ord constraint on
SCC is just an artifact of some internal data structures.
We can have an alternative implementation with a data
structure that uses Uniquable instead.

This does exactly that and I'm pleased that I didn't have
to introduce any duplication to do that.

Test Plan:
./validate
I looked at performance tests and it's a tiny bit better.

Reviewers: bgamari, simonmar, ezyang, austin, goldfire

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2359

GHC Trac Issues: #4012
parent 7fc20b02
......@@ -66,7 +66,7 @@ depAnal :: (node -> [Name]) -- Defs
--
-- The get_defs and get_uses functions are called only once per node
depAnal get_defs get_uses nodes
= stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
= stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes)
where
keyed_nodes = nodes `zip` [(1::Int)..]
mk_node (node, key) = (node, key, mapMaybe (lookupNameEnv key_map) (get_uses node))
......
......@@ -273,7 +273,7 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
g = stronglyConnCompFromEdgedVertices
g = stronglyConnCompFromEdgedVerticesOrd
[ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
......
......@@ -411,7 +411,7 @@ unscramble dflags vertices = mapM_ do_component components
stmt1 `mustFollow` stmt2 ]
components :: [SCC Vrtx]
components = stronglyConnCompFromEdgedVertices edges
components = stronglyConnCompFromEdgedVerticesUniq edges
-- do_components deal with one strongly-connected component
-- Not cyclic, or singleton? Just do it
......
......@@ -416,7 +416,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
where n = ifName d
-- strongly-connected groups of declarations, in dependency order
groups = stronglyConnCompFromEdgedVertices edges
groups = stronglyConnCompFromEdgedVerticesUniq edges
global_hash_fn = mkHashFun hsc_env eps
......
......@@ -1479,7 +1479,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
-- the specified node.
let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
| otherwise = throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVertices (seq root (reachableG graph root))
in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
type SummaryNode = (ModSummary, Int, [Int])
......@@ -1491,7 +1491,8 @@ summaryNodeSummary (s, _, _) = s
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
moduleGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
numbered_summaries = zip summaries [1..]
......
......@@ -764,7 +764,7 @@ sccBlocks
, BlockId
, [BlockId])]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
sccBlocks blocks = stronglyConnCompFromEdgedVerticesUniqR (map mkNode blocks)
-- we're only interested in the last instruction of
-- the block, and only if it has a single destination.
......
......@@ -169,7 +169,7 @@ joinToTargets_again
--
-- We need to do the R2 -> R3 move before R1 -> R2.
--
let sccs = stronglyConnCompFromEdgedVerticesR graph
let sccs = stronglyConnCompFromEdgedVerticesOrdR graph
{- -- debugging
pprTrace
......@@ -313,7 +313,7 @@ handleComponent delta instr
instrLoad <- loadR (RegReal dreg) slot
remainingFixUps <- mapM (handleComponent delta instr)
(stronglyConnCompFromEdgedVerticesR rest)
(stronglyConnCompFromEdgedVerticesOrdR rest)
-- make sure to do all the reloads after all the spills,
-- so we don't end up clobbering the source values.
......
......@@ -679,13 +679,13 @@ sccBlocks blocks entries = map (fmap get_node) sccs
nodes = [ (block, id, getOutEdges instrs)
| block@(BasicBlock id instrs) <- blocks ]
g1 = graphFromEdgedVertices nodes
g1 = graphFromEdgedVerticesUniq nodes
reachable :: BlockSet
reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]
g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes
, id `setMember` reachable ]
g2 = graphFromEdgedVerticesUniq [ node | node@(_,id,_) <- nodes
, id `setMember` reachable ]
sccs = stronglyConnCompG g2
......
......@@ -49,7 +49,8 @@ import DynFlags
import Util ( debugIsOn, partitionWith )
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
import Digraph ( SCC, flattenSCC, flattenSCCs
, stronglyConnCompFromEdgedVerticesUniq )
import UniqFM
import qualified GHC.LanguageExtensions as LangExt
......@@ -1338,7 +1339,7 @@ depAnalTyClDecls :: GlobalRdrEnv
-> [SCC (LTyClDecl Name)]
-- See Note [Dependency analysis of type, class, and instance decls]
depAnalTyClDecls rdr_env ds_w_fvs
= stronglyConnCompFromEdgedVertices edges
= stronglyConnCompFromEdgedVerticesUniq edges
where
edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUFM fvs))
| (d, fvs) <- ds_w_fvs ]
......
......@@ -34,7 +34,7 @@ import VarEnv
import Var
import Demand ( argOneShots, argsOneShots )
import Maybes ( orElse )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesUniqR )
import Unique
import UniqFM
import Util
......@@ -193,10 +193,12 @@ occAnalRecBind env imp_rule_edges pairs body_usage
bndr_set = mkVarSet (map fst pairs)
sccs :: [SCC (Node Details)]
sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes
sccs = {-# SCC "occAnalBind.scc" #-}
stronglyConnCompFromEdgedVerticesUniqR nodes
nodes :: [Node Details]
nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rule_edges bndr_set) pairs
nodes = {-# SCC "occAnalBind.assoc" #-}
map (makeNode env imp_rule_edges bndr_set) pairs
{-
Note [Dead code]
......@@ -863,7 +865,7 @@ loopBreakNodes :: Int
-> [Binding]
-- Return the bindings sorted into a plausible order, and marked with loop breakers.
loopBreakNodes depth bndr_set weak_fvs nodes binds
= go (stronglyConnCompFromEdgedVerticesR nodes) binds
= go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds
where
go [] binds = binds
go (scc:sccs) binds = loop_break_scc scc (go sccs binds)
......
......@@ -441,7 +441,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
isPatSyn _ = False
sccs :: [SCC (LHsBind Name)]
sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
......
......@@ -687,7 +687,7 @@ evVarsOfTerms = mapUnionVarSet evVarsOfTerm
-- | Do SCC analysis on a bag of 'EvBind's.
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
where
edges :: [(EvBind, EvVar, [EvVar])]
edges = foldrBag ((:) . mk_node) [] bs
......
......@@ -2473,7 +2473,7 @@ checkForCyclicBinds ev_binds
= pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
where
cycles :: [[EvBind]]
cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]
coercion_cycles = [c | c <- cycles, any is_co_bind c]
is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
......
......@@ -141,7 +141,7 @@ mkSynEdges syn_decls = [ (ldecl, name, nonDetEltsUFM fvs)
-- Note [Deterministic SCC] in Digraph.
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges
calcSynCycles = stronglyConnCompFromEdgedVerticesUniq . mkSynEdges
{- Note [Superclass cycle check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -471,7 +471,8 @@ findLoopBreakers deps
= go [(tc,tc,ds) | (tc,ds) <- deps]
where
go edges = [ name
| CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompFromEdgedVerticesR edges,
| CyclicSCC ((tc,_,_) : edges') <-
stronglyConnCompFromEdgedVerticesUniqR edges,
name <- tyConName tc : go edges']
{-
......
......@@ -1847,7 +1847,7 @@ isVoidTy ty = case repType ty of
toposortTyVars :: [TyVar] -> [TyVar]
toposortTyVars tvs = reverse $
[ tv | (tv, _, _) <- topologicalSortG $
graphFromEdgedVertices nodes ]
graphFromEdgedVerticesOrd nodes ]
where
var_ids :: VarEnv Int
var_ids = mkVarEnv (zip tvs [1..])
......
......@@ -3,7 +3,7 @@
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Digraph(
Graph, graphFromEdgedVertices,
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
SCC(..), Node, flattenSCC, flattenSCCs,
stronglyConnCompG,
......@@ -17,7 +17,10 @@ module Digraph(
findCycle,
-- For backwards compatability with the simpler version of Digraph
stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
stronglyConnCompFromEdgedVerticesOrd,
stronglyConnCompFromEdgedVerticesOrdR,
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
) where
#include "HsVersions.h"
......@@ -57,6 +60,8 @@ import qualified Data.Set as Set
import qualified Data.Graph as G
import Data.Graph hiding (Graph, Edge, transposeG, reachable)
import Data.Tree
import Unique
import UniqFM
{-
************************************************************************
......@@ -96,29 +101,71 @@ emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
-- See Note [Deterministic SCC]
graphFromEdgedVertices
:: Ord key -- We only use Ord for efficiency,
-- it doesn't effect the result, so
-- it can be safely used with Unique's.
=> [Node key payload] -- The graph; its ok for the
:: ReduceFn key payload
-> [Node key payload] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
-> Graph (Node key payload)
graphFromEdgedVertices [] = emptyGraph
graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
graphFromEdgedVertices _reduceFn [] = emptyGraph
graphFromEdgedVertices reduceFn edged_vertices =
Graph graph vertex_fn (key_vertex . key_extractor)
where key_extractor (_, k, _) = k
(bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
(bounds, vertex_fn, key_vertex, numbered_nodes) =
reduceFn edged_vertices key_extractor
graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
| (v, (_, _, ks)) <- numbered_nodes]
-- We normalize outgoing edges by sorting on node order, so
-- that the result doesn't depend on the order of the edges
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
graphFromEdgedVerticesOrd
:: Ord key
=> [Node key payload] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
-> Graph (Node key payload)
graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
graphFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
-> Graph (Node key payload)
graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq
type ReduceFn key payload =
[Node key payload] -> (Node key payload -> key) ->
(Bounds, Vertex -> Node key payload
, key -> Maybe Vertex, [(Vertex, Node key payload)])
{-
Note [reduceNodesIntoVertices implementations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
reduceNodesIntoVertices is parameterized by the container type.
This is to accomodate key types that don't have an Ord instance
and hence preclude the use of Data.Map. An example of such type
would be Unique, there's no way to implement Ord Unique
deterministically.
For such types, there's a version with a Uniquable constraint.
This leaves us with two versions of every function that depends on
reduceNodesIntoVertices, one with Ord constraint and the other with
Uniquable constraint.
For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
The Uniq version should be a tiny bit more efficient since it uses
Data.IntMap internally.
-}
reduceNodesIntoVertices
:: Ord key
=> [node]
-> (node -> key)
-> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Vertex, node)])
reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
:: ([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex)
-> ReduceFn key payload
reduceNodesIntoVertices fromList lookup nodes key_extractor =
(bounds, (!) vertex_map, key_vertex, numbered_nodes)
where
max_v = length nodes - 1
bounds = (0, max_v) :: (Vertex, Vertex)
......@@ -128,9 +175,17 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte
numbered_nodes = zip [0..] nodes
vertex_map = array bounds numbered_nodes
key_map = Map.fromList
key_map = fromList
[ (key_extractor node, v) | (v, node) <- numbered_nodes ]
key_vertex k = Map.lookup k key_map
key_vertex k = lookup k key_map
-- See Note [reduceNodesIntoVertices implementations]
reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
-- See Note [reduceNodesIntoVertices implementations]
reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
{-
************************************************************************
......@@ -204,7 +259,10 @@ edges going from them to earlier ones.
{-
Note [Deterministic SCC]
~~~~~~~~~~~~~~~~~~~~~~~~
stronglyConnCompFromEdgedVertices and stronglyConnCompFromEdgedVerticesR
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
stronglyConnCompFromEdgedVerticesOrd and
stronglyConnCompFromEdgedVerticesOrdR
provide a following guarantee:
Given a deterministically ordered list of nodes it returns a deterministically
ordered list of strongly connected components, where the list of vertices
......@@ -230,22 +288,47 @@ decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
-- The following two versions are provided for backwards compatability:
-- See Note [Deterministic SCC]
stronglyConnCompFromEdgedVertices
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVertices
= map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
stronglyConnCompFromEdgedVerticesOrd
= map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR
where get_node (n, _, _) = n
-- The following two versions are provided for backwards compatability:
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
= map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR
where get_node (n, _, _) = n
-- The "R" interface is used when you expect to apply SCC to
-- (some of) the result of SCC, so you dont want to lose the dependency info
-- See Note [Deterministic SCC]
stronglyConnCompFromEdgedVerticesR
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesOrdR
:: Ord key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
stronglyConnCompFromEdgedVerticesOrdR =
stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
-- The "R" interface is used when you expect to apply SCC to
-- (some of) the result of SCC, so you dont want to lose the dependency info
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesUniqR
:: Uniquable key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR =
stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
{-
************************************************************************
......
......@@ -96,7 +96,7 @@ type TyConGroup = ([TyCon], UniqSet TyCon)
-- Compute mutually recursive groups of tycons in topological order.
--
tyConGroups :: [TyCon] -> [TyConGroup]
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVertices edges)
tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)
where
edges = [((tc, ds), tc, nonDetEltsUFM ds) | tc <- tcs
, let ds = tyConsOfTyCon tc]
......
......@@ -20,4 +20,4 @@ test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]
test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]
testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices
testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment