Make stronglyConnCompFromEdgedVertices deterministic

This makes it so the result of computing SCC's depends on the order
the nodes were passed to it, but not on the order on the user provided
key type.
The key type is usually `Unique` which is known to be nondeterministic.

Test Plan:
`text` and `aeson` become deterministic after this
./validate

Compare compile time for `text`:
```
$ cabal get text && cd text* && cabal sandbox init && cabal install
--dependencies-only && time cabal build
real    0m59.459s
user    0m57.862s
sys     0m1.185s
$ cabal clean && time cabal build
real    1m0.037s
user    0m58.350s
sys     0m1.199s
$ cabal clean && time cabal build
real    0m57.634s
user    0m56.118s
sys     0m1.202s
$ cabal get text && cd text* && cabal sandbox init && cabal install
--dependencies-only && time cabal build
real    0m59.867s
user    0m58.176s
sys     0m1.188s
$ cabal clean && time cabal build
real    1m0.157s
user    0m58.622s
sys     0m1.177s
$ cabal clean && time cabal build
real    1m0.950s
user    0m59.397s
sys     0m1.083s
```

Reviewers: ezyang, simonmar, austin, bgamari

Reviewed By: simonmar, bgamari

Subscribers: thomie

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

GHC Trac Issues: #4012

11 files changed, 124 insertions, 92 deletions

diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs
index d5924a95e2..c6e63fb753 100644
--- a/compiler/utils/Digraph.hs
+++ b/compiler/utils/Digraph.hs
@@ -51,7 +51,6 @@ import Control.Monad.ST
 import Data.Maybe
 import Data.Array
 import Data.List hiding (transpose)
-import Data.Ord
 import Data.Array.ST
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -97,7 +96,9 @@ emptyGraph :: Graph a
 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
 
 graphFromEdgedVertices
-        :: Ord key
+        :: 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
                                         -- out-list to contain keys which arent
                                         -- a vertex key, they are ignored
@@ -106,34 +107,30 @@ graphFromEdgedVertices []             = emptyGraph
 graphFromEdgedVertices 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
-        graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
+        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
+
 
 reduceNodesIntoVertices
         :: Ord key
         => [node]
         -> (node -> key)
-        -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
+        -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Vertex, node)])
 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
   where
     max_v           = length nodes - 1
     bounds          = (0, max_v) :: (Vertex, Vertex)
 
-    sorted_nodes    = sortBy (comparing key_extractor) nodes
-    numbered_nodes  = zipWith (,) [0..] sorted_nodes
-
-    key_map         = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
+    -- Keep the order intact to make the result depend on input order
+    -- instead of key order
+    numbered_nodes  = zip [0..] nodes
     vertex_map      = array bounds numbered_nodes
 
-    --key_vertex :: key -> Maybe Vertex
-    -- returns Nothing for non-interesting vertices
-    key_vertex k = find 0 max_v
-      where
-        find a b | a > b = Nothing
-                 | otherwise = let mid = (a + b) `div` 2
-                               in case compare k (key_map ! mid) of
-                                    LT -> find a (mid - 1)
-                                    EQ -> Just mid
-                                    GT -> find (mid + 1) b
+    key_map = Map.fromList
+      [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
+    key_vertex k = Map.lookup k key_map
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/determinism/Makefile b/testsuite/tests/determinism/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/determinism/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/determinism/all.T b/testsuite/tests/determinism/all.T
new file mode 100644
index 0000000000..3d4ff2010d
--- /dev/null
+++ b/testsuite/tests/determinism/all.T
@@ -0,0 +1,3 @@
+setTestOpts(extra_hc_opts('-package ghc'))
+
+test('determinism001', normal, compile_and_run, [''])
diff --git a/testsuite/tests/determinism/determinism001.hs b/testsuite/tests/determinism/determinism001.hs
new file mode 100644
index 0000000000..7d1c5896df
--- /dev/null
+++ b/testsuite/tests/determinism/determinism001.hs
@@ -0,0 +1,23 @@
+module Main where
+
+import Digraph
+
+main = mapM_ print
+  [ test001
+  , test002
+  , test003
+  , test004
+  ]
+
+-- These check that the result of SCCs doesn't depend on the order of the key
+-- type (Int here).
+
+test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])]
+
+test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])]
+
+test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]
+
+test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]
+
+testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices
diff --git a/testsuite/tests/determinism/determinism001.stdout b/testsuite/tests/determinism/determinism001.stdout
new file mode 100644
index 0000000000..c94a1fe80b
--- /dev/null
+++ b/testsuite/tests/determinism/determinism001.stdout
@@ -0,0 +1,4 @@
+["c","b","a"]
+["c","b","a"]
+["a","c","b"]
+["a","c","b"]
diff --git a/testsuite/tests/indexed-types/should_compile/T7837.stderr b/testsuite/tests/indexed-types/should_compile/T7837.stderr
index eff5d02d4f..838a8fb88e 100644
--- a/testsuite/tests/indexed-types/should_compile/T7837.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T7837.stderr
@@ -1,3 +1,3 @@
-Rule fired: Class op abs
 Rule fired: Class op signum
+Rule fired: Class op abs
 Rule fired: normalize/Double
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 943908249d..6d4b412ba7 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -1,61 +1,62 @@
-

-==================== Tidy Core ====================

-Result size of Tidy Core = {terms: 22, types: 14, coercions: 0}

-

--- RHS size: {terms: 8, types: 3, coercions: 0}

-dl :: Double -> Double

-[GblId,

- Arity=1,

- Caf=NoCafRefs,

- Str=DmdType <S,1*U(U)>m,

- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,

-         WorkFree=True, Expandable=True,

-         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

-         Tmpl= \ (x [Occ=Once!] :: Double) ->

-                 case x of _ [Occ=Dead] { D# y -> D# (+## y y) }}]

-dl =

-  \ (x :: Double) -> case x of _ [Occ=Dead] { D# y -> D# (+## y y) }

-

--- RHS size: {terms: 1, types: 0, coercions: 0}

-dr :: Double -> Double

-[GblId,

- Arity=1,

- Caf=NoCafRefs,

- Str=DmdType <S,1*U(U)>m,

- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,

-         WorkFree=True, Expandable=True,

-         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

-         Tmpl= \ (x [Occ=Once!] :: Double) ->

-                 case x of _ [Occ=Dead] { D# x1 -> D# (+## x1 x1) }}]

-dr = dl

-

--- RHS size: {terms: 8, types: 3, coercions: 0}

-fl :: Float -> Float

-[GblId,

- Arity=1,

- Caf=NoCafRefs,

- Str=DmdType <S,1*U(U)>m,

- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,

-         WorkFree=True, Expandable=True,

-         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

-         Tmpl= \ (x [Occ=Once!] :: Float) ->

-                 case x of _ [Occ=Dead] { F# y -> F# (plusFloat# y y) }}]

-fl =

-  \ (x :: Float) ->

-    case x of _ [Occ=Dead] { F# y -> F# (plusFloat# y y) }

-

--- RHS size: {terms: 1, types: 0, coercions: 0}

-fr :: Float -> Float

-[GblId,

- Arity=1,

- Caf=NoCafRefs,

- Str=DmdType <S,1*U(U)>m,

- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,

-         WorkFree=True, Expandable=True,

-         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

-         Tmpl= \ (x [Occ=Once!] :: Float) ->

-                 case x of _ [Occ=Dead] { F# x1 -> F# (plusFloat# x1 x1) }}]

-fr = fl

-

-

-

+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 22, types: 14, coercions: 0}
+
+-- RHS size: {terms: 8, types: 3, coercions: 0}
+dr :: Double -> Double
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=DmdType <S,1*U(U)>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (x [Occ=Once!] :: Double) ->
+                 case x of _ [Occ=Dead] { D# x1 -> D# (+## x1 x1) }}]
+dr =
+  \ (x :: Double) ->
+    case x of _ [Occ=Dead] { D# x1 -> D# (+## x1 x1) }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+dl :: Double -> Double
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=DmdType <S,1*U(U)>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (x [Occ=Once!] :: Double) ->
+                 case x of _ [Occ=Dead] { D# y -> D# (+## y y) }}]
+dl = dr
+
+-- RHS size: {terms: 8, types: 3, coercions: 0}
+fr :: Float -> Float
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=DmdType <S,1*U(U)>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (x [Occ=Once!] :: Float) ->
+                 case x of _ [Occ=Dead] { F# x1 -> F# (plusFloat# x1 x1) }}]
+fr =
+  \ (x :: Float) ->
+    case x of _ [Occ=Dead] { F# x1 -> F# (plusFloat# x1 x1) }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+fl :: Float -> Float
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=DmdType <S,1*U(U)>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (x [Occ=Once!] :: Float) ->
+                 case x of _ [Occ=Dead] { F# y -> F# (plusFloat# y y) }}]
+fl = fr
+
+
+
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 7ded1feac4..296a6c2742 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -578,11 +578,12 @@ test('T9020',
           [(wordsize(32), 343005716, 10),
            # Original:    381360728
            # 2014-07-31:  343005716 (Windows) (general round of updates)
-           (wordsize(64), 680162056, 10)])
+           (wordsize(64), 786189008, 10)])
            # prev:        795469104
            # 2014-07-17:  728263536 (general round of updates)
            # 2014-09-10:  785871680 post-AMP-cleanup
            # 2014-11-03:  680162056 Further Applicative and Monad adjustments
+           # 2015-10-21:  786189008 Make stronglyConnCompFromEdgedVertices deterministic
       ],
       compile,[''])
 
diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout
index 9da4d97f9e..35f2412bc4 100644
--- a/testsuite/tests/simplCore/should_compile/T8274.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8274.stdout
@@ -1,2 +1,2 @@
-n = T8274.Negatives -4# -4.0# -4.0##
 p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
+n = T8274.Negatives -4# -4.0# -4.0##
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr
index 5bdd0076ce..abd6839db2 100644
--- a/testsuite/tests/simplCore/should_compile/T8848.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8848.stderr
@@ -3,18 +3,14 @@ Rule fired: Class op <*>
 Rule fired: Class op <*>
 Rule fired: SPEC map2
 Rule fired: Class op fmap
-Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
-Rule fired: Class op <*>
+Rule fired: Class op fmap
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
-Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
-Rule fired: Class op $p1Applicative
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
@@ -24,8 +20,12 @@ Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
-Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
+Rule fired: Class op $p1Applicative
+Rule fired: Class op $p1Applicative
 Rule fired: SPEC $cfmap @ 'Z
 Rule fired: SPEC $c<$ @ 'Z
 Rule fired: SPEC $fFunctorShape @ 'Z
@@ -41,21 +41,21 @@ Rule fired: SPEC $c<*> @ 'Z
 Rule fired: SPEC $c*> @ 'Z
 Rule fired: SPEC $c<* @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
-Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
+Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired: Class op $p1Applicative
 Rule fired: Class op <$
 Rule fired: Class op <*>
-Rule fired: SPEC $c<* @ 'Z
 Rule fired: SPEC $c*> @ 'Z
+Rule fired: SPEC $c<* @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
@@ -68,10 +68,10 @@ Rule fired: SPEC $fApplicativeShape @ 'Z
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))
 Rule fired: SPEC $fFunctorShape @ 'Z
 Rule fired: Class op fmap
 Rule fired: Class op fmap
diff --git a/testsuite/tests/stranal/should_compile/T10482a.stdout b/testsuite/tests/stranal/should_compile/T10482a.stdout
index bb19e36946..80ec26d661 100644
--- a/testsuite/tests/stranal/should_compile/T10482a.stdout
+++ b/testsuite/tests/stranal/should_compile/T10482a.stdout
@@ -1,4 +1,4 @@
+Foo.$wf4 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
 Foo.$wf2 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
 Foo.$wf1 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int#
 Foo.$wf3 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
-Foo.$wf4 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#