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