Make Arrow desugaring deterministic

This kills two instances of varSetElems that turned out to be
nondeterministic. I've tried to untangle this before, but it's
a bit hard with the fixDs in the middle. Fortunately I now have
a test case that proves that we need determinism here.

Test Plan: ./validate, new testcase

Reviewers: simonpj, simonmar, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2258

GHC Trac Issues: #4012

4 files changed, 51 insertions, 0 deletions

diff --git a/testsuite/tests/determinism/determ018/A.hs b/testsuite/tests/determinism/determ018/A.hs
new file mode 100644
index 0000000000..7017f5719c
--- /dev/null
+++ b/testsuite/tests/determinism/determ018/A.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE
+    Arrows
+  , TypeOperators
+  #-}
+-- This is extracted from arrow-list package
+-- The problem was that some internal tuples that Arrows desugaring
+-- generates the components in different orders depending on the order
+-- of Uniques.
+module A
+(
+ ifA
+)
+where
+
+import Control.Arrow
+import Prelude hiding (id, (.))
+
+class Arrow arr => ArrowList arr where
+  arrL :: (a -> [b]) -> a `arr` b
+  mapL :: ([b] -> [c]) -> (a `arr` b) -> (a `arr` c)
+
+
+empty :: ArrowList arr => (a `arr` b) -> a `arr` Bool
+empty = mapL (\xs -> [if null xs then True else False])
+
+
+ifA :: (ArrowList arr, ArrowChoice arr)
+    => (a `arr` c)  -- ^ Arrow used as condition.
+    -> (a `arr` b)  -- ^ Arrow to use when condition has results.
+    -> (a `arr` b)  -- ^ Arrow to use when condition has no results.
+    -> a `arr` b
+ifA c t e = proc i -> do x <- empty c -< i; if x then e -< i else t -< i
diff --git a/testsuite/tests/determinism/determ018/Makefile b/testsuite/tests/determinism/determ018/Makefile
new file mode 100644
index 0000000000..227c0903fa
--- /dev/null
+++ b/testsuite/tests/determinism/determ018/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))
+
+determ018:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ018/all.T b/testsuite/tests/determinism/determ018/all.T
new file mode 100644
index 0000000000..96c35feb3a
--- /dev/null
+++ b/testsuite/tests/determinism/determ018/all.T
@@ -0,0 +1,4 @@
+test('determ018',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ018'])
diff --git a/testsuite/tests/determinism/determ018/determ018.stdout b/testsuite/tests/determinism/determ018/determ018.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ018/determ018.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )