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

18 files changed, 136 insertions, 48 deletions

diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs
index 46819a7b94..024e3d8e06 100644
--- a/compiler/basicTypes/NameEnv.hs
+++ b/compiler/basicTypes/NameEnv.hs
@@ -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))
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index dafaea3156..e756b06ac0 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 86c03ac2c4..5d6710197b 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -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
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 537d9601b7..1aa3111655 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -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
 
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index c02ad7a671..93f1cd44bb 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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..]
 
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 6bb7f8a875..2bf9e1cc2e 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -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.
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 07ff1ca887..ac38e2b450 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -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.
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index ed2ff7bf93..b97246012a 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -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
 
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 3b23bb602f..4790adad1f 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -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 ]
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index c9da7b7a42..27e5a7d97e 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -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)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index d23b9527c5..7c45ac7b59 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -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
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index f54ff5723f..71f5bb7b91 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -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
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index ea1220e14e..a8bb35ddd5 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -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)
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index c04c750bfe..d073473e98 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -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']
 
 {-
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 93161b7f7f..c67b4ef08b 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -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..])
diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs
index 1d6ef24e61..93906b237a 100644
--- a/compiler/utils/Digraph.hs
+++ b/compiler/utils/Digraph.hs
@@ -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
 
 {-
 ************************************************************************
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 75d43d4e36..7963ae7375 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -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]
diff --git a/testsuite/tests/determinism/determinism001.hs b/testsuite/tests/determinism/determinism001.hs
index 7d1c5896df..9ba9b7f09e 100644
--- a/testsuite/tests/determinism/determinism001.hs
+++ b/testsuite/tests/determinism/determinism001.hs
@@ -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