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

1 files changed, 105 insertions, 22 deletions

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
 
 {-
 ************************************************************************