Commit 5b2b7e33 authored by Bartosz Nitka's avatar Bartosz Nitka
Browse files

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
parent 96e67c01
......@@ -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
......
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
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'])
[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 )
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)
......@@ -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
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)
......@@ -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
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