Desugar ApplicativeDo and RecDo deterministically

This fixes a problem described in
Note [Deterministic ApplicativeDo and RecursiveDo desugaring].

Test Plan: ./validate + new testcase

Reviewers: simonpj, bgamari, austin, simonmar

Reviewed By: simonmar

Subscribers: thomie

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

GHC Trac Issues: #4012

(cherry picked from commit e684f5469399b9d239693eb54f9d1b4d55253ac4)

7 files changed, 117 insertions, 8 deletions

diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index eb820d4670..5ae8557548 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -412,8 +412,10 @@ mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
 cmpName :: Name -> Name -> Ordering
 cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2
 
+-- | Compare Names lexicographically
+-- This only works for Names that originate in the source code or have been
+-- tidied.
 stableNameCmp :: Name -> Name -> Ordering
--- Compare lexicographically
 stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
               (Name { n_sort = s2, n_occ = occ2 })
   = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)
diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs
index b764bd9a7f..4cd2dff445 100644
--- a/compiler/basicTypes/NameSet.hs
+++ b/compiler/basicTypes/NameSet.hs
@@ -88,6 +88,8 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
 intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
 
 -- | Get the elements of a NameSet with some stable ordering.
+-- This only works for Names that originate in the source code or have been
+-- tidied.
 -- See Note [Deterministic UniqFM] to learn about nondeterminism
 nameSetElemsStable :: NameSet -> [Name]
 nameSetElemsStable ns =
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 5921718b40..1ca677aeaa 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -647,6 +647,27 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 ************************************************************************
 -}
 
+{-
+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both ApplicativeDo and RecursiveDo need to create tuples not
+present in the source text.
+
+For ApplicativeDo we create:
+
+  (a,b,c) <- (\c b a -> (a,b,c)) <$>
+
+For RecursiveDo we create:
+
+  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
+
+The order of the components in those tuples needs to be stable
+across recompilations, otherwise they can get optimized differently
+and we end up with incompatible binaries.
+To get a stable order we use nameSetElemsStable.
+See Note [Deterministic UniqFM] to learn more about nondeterminism.
+-}
+
 -- | Rename some Stmts
 rnStmts :: Outputable (body RdrName)
         => HsStmtContext Name
@@ -828,8 +849,11 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
         -- (This set may not be empty, because we're in a recursive
         -- context.)
         ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do
-        { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
-                                            emptyNameSet segs
+        { let bndrs = nameSetElemsStable $
+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))
+                              emptyNameSet
+                              segs
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
         ; (thing, fvs_later) <- thing_inside bndrs
         ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
         -- We aren't going to try to group RecStmts with
@@ -1186,8 +1210,11 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
   | otherwise
   = ([ L loc $
        empty_rec_stmt { recS_stmts = ss
-                      , recS_later_ids = nameSetElems (defs `intersectNameSet` fvs_later)
-                      , recS_rec_ids   = nameSetElems (defs `intersectNameSet` uses) }]
+                      , recS_later_ids = nameSetElemsStable
+                                           (defs `intersectNameSet` fvs_later)
+                      , recS_rec_ids   = nameSetElemsStable
+                                           (defs `intersectNameSet` uses) }]
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
     , uses `plusFV` fvs_later)
 
   where
@@ -1312,8 +1339,9 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
     new_stmt | non_rec   = head ss
              | otherwise = L (getLoc (head ss)) rec_stmt
     rec_stmt = empty_rec_stmt { recS_stmts     = ss
-                              , recS_later_ids = nameSetElems used_later
-                              , recS_rec_ids   = nameSetElems fwds }
+                              , recS_later_ids = nameSetElemsStable used_later
+                              , recS_rec_ids   = nameSetElemsStable fwds }
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
     non_rec    = isSingleton ss && isEmptyNameSet fwds
     used_later = defs `intersectNameSet` later_uses
                                 -- The ones needed after the RecStmt
@@ -1595,7 +1623,8 @@ stmtTreeToStmts ctxt (StmtTreeApplicative trees) tail tail_fvs = do
      let stmts = flattenStmtTree tree
          pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
                      `intersectNameSet` tail_fvs
-         pvars = nameSetElems pvarset
+         pvars = nameSetElemsStable pvarset
+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
          pat = mkBigLHsVarPatTup pvars
          tup = mkBigLHsVarTup pvars
      (stmts',fvs2) <- stmtTreeToStmts ctxt tree [] pvarset
diff --git a/testsuite/tests/determinism/determ019/A.hs b/testsuite/tests/determinism/determ019/A.hs
new file mode 100644
index 0000000000..9984780204
--- /dev/null
+++ b/testsuite/tests/determinism/determ019/A.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TupleSections #-}
+module A where
+
+import Control.Arrow (first)
+import Control.Monad.Fix
+import Control.Monad
+
+-- Reduced example from rev-state package.
+-- Reproduces an issue where the tuples generated when desugaring
+-- mdo have nondeterministic order of components.
+--
+-- Consider:
+--
+--    do rec
+--      a <- f b
+--      b <- f a
+--      return a
+--
+-- Compare:
+--
+--  do
+--    (a, b) <- mfix $ \ ~(a, b) -> do
+--      a <- f b
+--      b <- f a
+--      return (a, b)
+--    return a
+--
+-- vs
+--
+--  do
+--    (b, a) <- mfix $ \ ~(b, a) -> do
+--      a <- f b
+--      b <- f a
+--      return (b, a)
+--    return a
+
+newtype StateT s m a = StateT
+  { runStateT :: s -> m (a, s) }
+
+instance MonadFix m => Monad (StateT s m) where
+  return x = StateT $ \s -> pure (x, s)
+  m >>= f = StateT $ \s -> do
+    rec
+      (x, s'') <- runStateT m s'
+      (x', s') <- runStateT (f x) s
+    return (x', s'')
+
+instance MonadFix m => Applicative (StateT s m) where
+  (<*>) = ap
+  pure = return
+
+instance Functor m => Functor (StateT s m) where
+  -- this instance is hand-written
+  -- so we don't have to rely on m being MonadFix
+  fmap f m = StateT $ \s -> first f `fmap` runStateT m s
diff --git a/testsuite/tests/determinism/determ019/Makefile b/testsuite/tests/determinism/determ019/Makefile
new file mode 100644
index 0000000000..df018e225b
--- /dev/null
+++ b/testsuite/tests/determinism/determ019/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))
+
+determ019:
+	$(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/determ019/all.T b/testsuite/tests/determinism/determ019/all.T
new file mode 100644
index 0000000000..caa03add26
--- /dev/null
+++ b/testsuite/tests/determinism/determ019/all.T
@@ -0,0 +1,4 @@
+test('determ019',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ019'])
diff --git a/testsuite/tests/determinism/determ019/determ019.stdout b/testsuite/tests/determinism/determ019/determ019.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ019/determ019.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )