summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/utils/Digraph.hs33
-rw-r--r--testsuite/tests/determinism/Makefile3
-rw-r--r--testsuite/tests/determinism/all.T3
-rw-r--r--testsuite/tests/determinism/determinism001.hs23
-rw-r--r--testsuite/tests/determinism/determinism001.stdout4
-rw-r--r--testsuite/tests/indexed-types/should_compile/T7837.stderr2
-rw-r--r--testsuite/tests/numeric/should_compile/T7116.stdout123
-rw-r--r--testsuite/tests/perf/compiler/all.T3
-rw-r--r--testsuite/tests/simplCore/should_compile/T8274.stdout2
-rw-r--r--testsuite/tests/simplCore/should_compile/T8848.stderr18
-rw-r--r--testsuite/tests/stranal/should_compile/T10482a.stdout2
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#
View Lorry Controller Status