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