Desugar ApplicativeDo and RecDo deterministically
authorBartosz Nitka <niteria@gmail.com>
Mon, 6 Jun 2016 13:08:54 +0000 (06:08 -0700)
committerBartosz Nitka <niteria@gmail.com>
Mon, 6 Jun 2016 13:13:48 +0000 (06:13 -0700)
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

compiler/basicTypes/Name.hs
compiler/basicTypes/NameSet.hs
compiler/rename/RnExpr.hs
testsuite/driver/extra_files.py
testsuite/tests/determinism/determ019/A.hs [new file with mode: 0644]
testsuite/tests/determinism/determ019/Makefile [new file with mode: 0644]
testsuite/tests/determinism/determ019/all.T [new file with mode: 0644]
testsuite/tests/determinism/determ019/determ019.stdout [new file with mode: 0644]

index 7dee877..24dc8aa 100644 (file)
@@ -410,8 +410,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)
index 27a2c3b..7bfd915 100644 (file)
@@ -93,6 +93,8 @@ nameSetAll :: (Name -> Bool) -> NameSet -> Bool
 nameSetAll = uniqSetAll
 
 -- | 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 =
index 32277b4..c92f69e 100644 (file)
@@ -633,6 +633,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
@@ -814,8 +835,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
@@ -1172,8 +1196,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
@@ -1298,8 +1325,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
@@ -1581,7 +1609,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
index 650ba45..3d38fcf 100644 (file)
@@ -190,6 +190,7 @@ extra_src_files = {
   'determ006': ['spec-inline-determ.hs'],
   'determ010': ['A.hs'],
   'determ018': ['A.hs'],
+  'determ019': ['A.hs'],
   'dodgy': ['DodgyA.hs'],
   'driver011': ['A011.hs'],
   'driver012': ['A012.hs'],
diff --git a/testsuite/tests/determinism/determ019/A.hs b/testsuite/tests/determinism/determ019/A.hs
new file mode 100644 (file)
index 0000000..9984780
--- /dev/null
@@ -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 (file)
index 0000000..df018e2
--- /dev/null
@@ -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 (file)
index 0000000..caa03ad
--- /dev/null
@@ -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 (file)
index 0000000..60c2bc3
--- /dev/null
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )