Commit 9cb192ce authored by niteria's avatar niteria Committed by Ben Gamari
Browse files

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
parent 0499aa7c
......@@ -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
{-
************************************************************************
......
TOP=../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
setTestOpts(extra_hc_opts('-package ghc'))
test('determinism001', normal, compile_and_run, [''])
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
["c","b","a"]
["c","b","a"]
["a","c","b"]
["a","c","b"]
Rule fired: Class op abs
Rule fired: Class op signum
Rule fired: Class op abs
Rule fired: normalize/Double
==================== 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
......@@ -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,[''])
......
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##
......@@ -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
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#
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