diff options
author | Bartosz Nitka <bnitka@fb.com> | 2015-12-02 06:20:55 -0800 |
---|---|---|
committer | Bartosz Nitka <bnitka@fb.com> | 2015-12-04 06:06:40 -0800 |
commit | 5b2b7e338c822c34f86e8bd3ff442a979711d1fe (patch) | |
tree | 39dabae92cf385731229c6b2320dc24f7ee6e7b7 | |
parent | 96e67c014e9b8022599bbe19f67d1635f4955ce0 (diff) | |
download | haskell-5b2b7e338c822c34f86e8bd3ff442a979711d1fe.tar.gz |
Make callToPats deterministic in SpecConstr
This fixes a non-determinism bug where where depending on the
order of uniques allocated, the specialized workers would have different
order of arguments.
Compare:
```
$s$wgo_s1CN :: Int# -> Int -> Int#
[LclId, Arity=2, Str=DmdType <L,U><L,U>]
$s$wgo_s1CN =
\ (sc_s1CI :: Int#) (sc_s1CJ :: Int) ->
case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] {
False ->
$wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ);
True -> 0#
}
```
vs
```
$s$wgo_s18mTj :: Int -> Int# -> Int#
[LclId, Arity=2, Str=DmdType <L,U><L,U>]
$s$wgo_s18mTj =
\ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) ->
case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] {
False ->
$wgo_s18mUc
(Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn);
True -> 0#
}
```
Test Plan:
I've added a new testcase
./validate
Reviewers: simonmar, simonpj, austin, goldfire, bgamari
Reviewed By: bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1508
GHC Trac Issues: #4012
8 files changed, 90 insertions, 25 deletions
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index b3adc36e02..1760b0e596 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -25,7 +25,7 @@ import CoreSyn import CoreSubst import CoreUtils import CoreUnfold ( couldBeSmallEnoughToInline ) -import CoreFVs ( exprsFreeVars ) +import CoreFVs ( exprsFreeVarsList ) import CoreMonad import Literal ( litIsLifted ) import HscTypes ( ModGuts(..) ) @@ -1835,7 +1835,13 @@ callToPats env bndr_occs (Call _ args con_env) | otherwise = do { let in_scope = substInScope (sc_subst env) ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs - ; let pat_fvs = varSetElems (exprsFreeVars pats) + ; let pat_fvs = exprsFreeVarsList pats + -- To get determinism we need the list of free variables in + -- deterministic order. Otherwise we end up creating + -- lambdas with different argument orders. See + -- determinism/simplCore/should_compile/spec-inline-determ.hs + -- for an example. For explanation of determinism + -- considerations See Note [Unique Determinism] in Unique. in_scope_vars = getInScopeVars in_scope qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs -- Quantify over variables that are not in scope diff --git a/testsuite/tests/determinism/simplCore/should_compile/Makefile b/testsuite/tests/determinism/simplCore/should_compile/Makefile new file mode 100644 index 0000000000..4512271217 --- /dev/null +++ b/testsuite/tests/determinism/simplCore/should_compile/Makefile @@ -0,0 +1,13 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +determ006: + $(RM) spec-inline-determ.hi spec-inline-determ.o + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O2 spec-inline-determ.hs + $(CP) spec-inline-determ.hi spec-inline-determ.old.hi + $(RM) spec-inline-determ.o + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777206 -dunique-increment=-1 -O2 spec-inline-determ.hs + diff spec-inline-determ.hi spec-inline-determ.old.hi diff --git a/testsuite/tests/determinism/simplCore/should_compile/all.T b/testsuite/tests/determinism/simplCore/should_compile/all.T new file mode 100644 index 0000000000..e0d5238bf8 --- /dev/null +++ b/testsuite/tests/determinism/simplCore/should_compile/all.T @@ -0,0 +1,4 @@ +test('determ006', + extra_clean(['spec-inline-determ.o', 'spec-inline-determ.hi', 'spec-inline-determ.normal.hi']), + run_command, + ['$MAKE -s --no-print-directory determ006']) diff --git a/testsuite/tests/determinism/simplCore/should_compile/determ006.stdout b/testsuite/tests/determinism/simplCore/should_compile/determ006.stdout new file mode 100644 index 0000000000..138d4023c5 --- /dev/null +++ b/testsuite/tests/determinism/simplCore/should_compile/determ006.stdout @@ -0,0 +1,2 @@ +[1 of 1] Compiling Roman ( spec-inline-determ.hs, spec-inline-determ.o ) +[1 of 1] Compiling Roman ( spec-inline-determ.hs, spec-inline-determ.o ) diff --git a/testsuite/tests/determinism/simplCore/should_compile/spec-inline-determ.hs b/testsuite/tests/determinism/simplCore/should_compile/spec-inline-determ.hs new file mode 100644 index 0000000000..9bc79018de --- /dev/null +++ b/testsuite/tests/determinism/simplCore/should_compile/spec-inline-determ.hs @@ -0,0 +1,40 @@ +module Roman where + +-- This is a simplified version of simplCore/should_compile/spec-inline.hs +-- +-- It reproduces a problem where workers get specialized in different ways +-- depending on the values of uniques. +-- +-- Compare: +-- +-- $s$wgo_s1CN :: Int# -> Int -> Int# +-- [LclId, Arity=2, Str=DmdType <L,U><L,U>] +-- $s$wgo_s1CN = +-- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> +-- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); +-- True -> 0# +-- } +-- +-- vs +-- +-- $s$wgo_s18mTj :: Int -> Int# -> Int# +-- [LclId, Arity=2, Str=DmdType <L,U><L,U>] +-- $s$wgo_s18mTj = +-- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> +-- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s18mUc +-- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); +-- True -> 0# +-- } + +foo :: Int -> Int +foo n = + go (Just n) (Just (6::Int)) + where + go Nothing (Just x) = go (Just 10) (Just x) + go (Just n) (Just x) + | n <= 0 = 0 + | otherwise = go (Just (n-1)) (Just x) diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 334935ddd4..878bd18cce 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -31,14 +31,14 @@ T4908.$trModule = Module T4908.$trModule2 T4908.$trModule1 Rec { -- RHS size: {terms: 19, types: 5, coercions: 0} -T4908.f_$s$wf [Occ=LoopBreaker] :: Int# -> Int -> Int# -> Bool -[GblId, Arity=3, Caf=NoCafRefs, Str=DmdType <S,1*U><L,A><L,U>] +T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> Bool +[GblId, Arity=3, Caf=NoCafRefs, Str=DmdType <L,A><L,U><S,1*U>] T4908.f_$s$wf = - \ (sc :: Int#) (sc1 :: Int) (sc2 :: Int#) -> - case sc of ds { + \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) -> + case sc2 of ds { __DEFAULT -> - case sc2 of ds1 { - __DEFAULT -> T4908.f_$s$wf (-# ds 1#) sc1 ds1; + case sc1 of ds1 { + __DEFAULT -> T4908.f_$s$wf sc ds1 (-# ds 1#); 0# -> True }; 0# -> True @@ -60,7 +60,7 @@ T4908.$wf = case w of _ [Occ=Dead] { (a, b) -> case b of _ [Occ=Dead] { I# ds1 -> case ds1 of ds2 { - __DEFAULT -> T4908.f_$s$wf (-# ds 1#) a ds2; + __DEFAULT -> T4908.f_$s$wf a ds2 (-# ds 1#); 0# -> True } } @@ -86,8 +86,8 @@ f = ------ Local rules for imported ids -------- "SC:$wf0" [0] - forall (sc :: Int#) (sc1 :: Int) (sc2 :: Int#). - T4908.$wf sc (sc1, I# sc2) + forall (sc :: Int) (sc1 :: Int#) (sc2 :: Int#). + T4908.$wf sc2 (sc, I# sc1) = T4908.f_$s$wf sc sc1 sc2 diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout index 80171b499f..b4252a9cdc 100644 --- a/testsuite/tests/simplCore/should_compile/T7865.stdout +++ b/testsuite/tests/simplCore/should_compile/T7865.stdout @@ -1,4 +1,4 @@ expensive [InlPrag=NOINLINE] :: Int -> Int expensive = - a = case expensive sc of _ [Occ=Dead] { I# x -> I# (*# x 2#) } } in + case expensive sc1 of _ [Occ=Dead] { I# x -> I# (*# x 2#) } } in (case expensive x of _ [Occ=Dead] { I# x1 -> I# (*# x1 2#) }, x) diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 7ae0e9c920..17d3dbbdc5 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -44,16 +44,16 @@ Roman.foo_$s$wgo = let { a :: Int# [LclId, Str=DmdType] - a = +# (+# (+# (+# (+# (+# sc1 sc1) sc1) sc1) sc1) sc1) sc1 } in - case tagToEnum# @ Bool (<=# sc 0#) of _ [Occ=Dead] { + a = +# (+# (+# (+# (+# (+# sc sc) sc) sc) sc) sc) sc } in + case tagToEnum# @ Bool (<=# sc1 0#) of _ [Occ=Dead] { False -> - case tagToEnum# @ Bool (<# sc 100#) of _ [Occ=Dead] { + case tagToEnum# @ Bool (<# sc1 100#) of _ [Occ=Dead] { False -> - case tagToEnum# @ Bool (<# sc 500#) of _ [Occ=Dead] { - False -> Roman.foo_$s$wgo (-# sc 1#) (+# a a); - True -> Roman.foo_$s$wgo (-# sc 3#) a + case tagToEnum# @ Bool (<# sc1 500#) of _ [Occ=Dead] { + False -> Roman.foo_$s$wgo (+# a a) (-# sc1 1#); + True -> Roman.foo_$s$wgo a (-# sc1 3#) }; - True -> Roman.foo_$s$wgo (-# sc 2#) sc1 + True -> Roman.foo_$s$wgo sc (-# sc1 2#) }; True -> 0# } @@ -77,7 +77,7 @@ Roman.$wgo = [LclId, Str=DmdType] a = +# (+# (+# (+# (+# (+# ipv ipv) ipv) ipv) ipv) ipv) ipv } in case w of _ [Occ=Dead] { - Nothing -> Roman.foo_$s$wgo 10# a; + Nothing -> Roman.foo_$s$wgo a 10#; Just n -> case n of _ [Occ=Dead] { I# x2 -> case tagToEnum# @ Bool (<=# x2 0#) of _ [Occ=Dead] { @@ -85,10 +85,10 @@ Roman.$wgo = case tagToEnum# @ Bool (<# x2 100#) of _ [Occ=Dead] { False -> case tagToEnum# @ Bool (<# x2 500#) of _ [Occ=Dead] { - False -> Roman.foo_$s$wgo (-# x2 1#) (+# a a); - True -> Roman.foo_$s$wgo (-# x2 3#) a + False -> Roman.foo_$s$wgo (+# a a) (-# x2 1#); + True -> Roman.foo_$s$wgo a (-# x2 3#) }; - True -> Roman.foo_$s$wgo (-# x2 2#) ipv + True -> Roman.foo_$s$wgo ipv (-# x2 2#) }; True -> 0# } @@ -145,14 +145,14 @@ foo :: Int -> Int foo = \ (n :: Int) -> case n of _ [Occ=Dead] { I# ipv -> - case Roman.foo_$s$wgo ipv 6# of ww { __DEFAULT -> I# ww } + case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> I# ww } } ------ Local rules for imported ids -------- "SC:$wgo0" [0] forall (sc :: Int#) (sc1 :: Int#). - Roman.$wgo (Just @ Int (I# sc)) (Just @ Int (I# sc1)) + Roman.$wgo (Just @ Int (I# sc1)) (Just @ Int (I# sc)) = Roman.foo_$s$wgo sc sc1 |