Make the Ord Module independent of Unique order

The `Ord Module` instance currently uses `Unique`s for comparison.
We don't want to use the `Unique` order because it can introduce nondeterminism.
This switches `Ord ModuleName` and `Ord UnitId` to use lexicographic ordering
making `Ord Module` deterministic transitively.

I've run `nofib` and it doesn't make a measurable difference.

See also Note [ModuleEnv determinism and performance].

Test Plan:
./validate
run nofib: P112

Reviewers: simonpj, simonmar, austin, bgamari

Subscribers: thomie

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

GHC Trac Issues: #4012

7 files changed, 92 insertions, 58 deletions

diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 74b15bcd3a..132ce762cf 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -87,6 +87,8 @@ import UniqDFM
 import FastString
 import Binary
 import Util
+import Data.List
+import Data.Ord
 import {-# SOURCE #-} Packages
 import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..))
 
@@ -243,11 +245,8 @@ instance Uniquable ModuleName where
 instance Eq ModuleName where
   nm1 == nm2 = getUnique nm1 == getUnique nm2
 
--- Warning: gives an ordering relation based on the uniques of the
--- FastStrings which are the (encoded) module names.  This is _not_
--- a lexicographical ordering.
 instance Ord ModuleName where
-  nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+  nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2
 
 instance Outputable ModuleName where
   ppr = pprModuleName
@@ -395,10 +394,8 @@ newtype UnitId = PId FastString deriving Eq
 instance Uniquable UnitId where
  getUnique pid = getUnique (unitIdFS pid)
 
--- Note: *not* a stable lexicographic ordering, a faster unique-based
--- ordering.
 instance Ord UnitId where
-  nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+  nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2
 
 instance Data UnitId where
   -- don't traverse?
@@ -515,65 +512,102 @@ wiredInUnitIds = [ primUnitId,
 -}
 
 -- | A map keyed off of 'Module's
-newtype ModuleEnv elt = ModuleEnv (Map Module elt)
+newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
+{-
+Note [ModuleEnv performance and determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To prevent accidental reintroduction of nondeterminism the Ord instance
+for Module was changed to not depend on Unique ordering and to use the
+lexicographic order. This is potentially expensive, but when measured
+there was no difference in performance.
+
+To be on the safe side and not pessimize ModuleEnv uses nondeterministic
+ordering on Module and normalizes by doing the lexicographic sort when
+turning the env to a list.
+See Note [Unique Determinism] for more information about the source of
+nondeterminismand and Note [Deterministic UniqFM] for explanation of why
+it matters for maps.
+-}
+
+newtype NDModule = NDModule { unNDModule :: Module }
+  deriving Eq
+  -- A wrapper for Module with faster nondeterministic Ord.
+  -- Don't export, See [ModuleEnv performance and determinism]
+
+instance Ord NDModule where
+  compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =
+    (getUnique p1 `compare` getUnique p2) `thenCmp`
+    (getUnique n1 `compare` getUnique n2)
 
 filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
-filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e)
+filterModuleEnv f (ModuleEnv e) =
+  ModuleEnv (Map.filterWithKey (f . unNDModule) e)
 
 elemModuleEnv :: Module -> ModuleEnv a -> Bool
-elemModuleEnv m (ModuleEnv e) = Map.member m e
+elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e
 
 extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
-extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e)
+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e)
 
-extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
-extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e)
+extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a
+                    -> ModuleEnv a
+extendModuleEnvWith f (ModuleEnv e) m x =
+  ModuleEnv (Map.insertWith f (NDModule m) x e)
 
 extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
-extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e)
+extendModuleEnvList (ModuleEnv e) xs =
+  ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e)
 
 extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
                       -> ModuleEnv a
-extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e)
+extendModuleEnvList_C f (ModuleEnv e) xs =
+  ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e)
 
 plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
-plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2)
+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) =
+  ModuleEnv (Map.unionWith f e1 e2)
 
 delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
-delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e)
+delModuleEnvList (ModuleEnv e) ms =
+  ModuleEnv (Map.deleteList (map NDModule ms) e)
 
 delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
-delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e)
+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e)
 
 plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
 plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
 
 lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
-lookupModuleEnv (ModuleEnv e) m = Map.lookup m e
+lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e
 
 lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
-lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e
+lookupWithDefaultModuleEnv (ModuleEnv e) x m =
+  Map.findWithDefault x (NDModule m) e
 
 mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
 mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
 
 mkModuleEnv :: [(Module, a)] -> ModuleEnv a
-mkModuleEnv xs = ModuleEnv (Map.fromList xs)
+mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs])
 
 emptyModuleEnv :: ModuleEnv a
 emptyModuleEnv = ModuleEnv Map.empty
 
 moduleEnvKeys :: ModuleEnv a -> [Module]
-moduleEnvKeys (ModuleEnv e) = Map.keys e
+moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e
+  -- See Note [ModuleEnv performance and determinism]
 
 moduleEnvElts :: ModuleEnv a -> [a]
-moduleEnvElts (ModuleEnv e) = Map.elems e
+moduleEnvElts e = map snd $ moduleEnvToList e
+  -- See Note [ModuleEnv performance and determinism]
 
 moduleEnvToList :: ModuleEnv a -> [(Module, a)]
-moduleEnvToList (ModuleEnv e) = Map.toList e
+moduleEnvToList (ModuleEnv e) =
+  sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e]
+  -- See Note [ModuleEnv performance and determinism]
 
 unitModuleEnv :: Module -> a -> ModuleEnv a
-unitModuleEnv m x = ModuleEnv (Map.singleton m x)
+unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)
 
 isEmptyModuleEnv :: ModuleEnv a -> Bool
 isEmptyModuleEnv (ModuleEnv e) = Map.null e
diff --git a/testsuite/tests/driver/sigof01/all.T b/testsuite/tests/driver/sigof01/all.T
index 077263a17f..61a012d264 100644
--- a/testsuite/tests/driver/sigof01/all.T
+++ b/testsuite/tests/driver/sigof01/all.T
@@ -4,6 +4,6 @@ test('sigof01',
      ['$MAKE -s --no-print-directory sigof01'])
 
 test('sigof01m',
-     [ clean_cmd('rm -rf tmp_sigof01m'), normalise_slashes ],
+     [ expect_broken(12189), clean_cmd('rm -rf tmp_sigof01m'), normalise_slashes ],
      run_command,
      ['$MAKE -s --no-print-directory sigof01m'])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
index 9d8e8bd6c3..9be384b500 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr
@@ -1,6 +1,6 @@
 [1 of 4] Compiling OverloadedRecFldsFail10_A ( OverloadedRecFldsFail10_A.hs, OverloadedRecFldsFail10_A.o )
-[2 of 4] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o )
-[3 of 4] Compiling OverloadedRecFldsFail10_B ( OverloadedRecFldsFail10_B.hs, OverloadedRecFldsFail10_B.o )
+[2 of 4] Compiling OverloadedRecFldsFail10_B ( OverloadedRecFldsFail10_B.hs, OverloadedRecFldsFail10_B.o )
+[3 of 4] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o )
 [4 of 4] Compiling Main             ( overloadedrecfldsfail10.hs, overloadedrecfldsfail10.o )
 
 overloadedrecfldsfail10.hs:6:20: error:
diff --git a/testsuite/tests/rename/should_fail/T11071.stderr b/testsuite/tests/rename/should_fail/T11071.stderr
index 2feeadd040..0e77fae7de 100644
--- a/testsuite/tests/rename/should_fail/T11071.stderr
+++ b/testsuite/tests/rename/should_fail/T11071.stderr
@@ -13,7 +13,7 @@ T11071.hs:21:12: error:
 
 T11071.hs:22:12: error:
     Not in scope: ‘M'.foobar’
-    Neither ‘Data.IntMap’, ‘Data.Map’ nor ‘System.IO’ exports ‘foobar’.
+    Neither ‘System.IO’, ‘Data.IntMap’ nor ‘Data.Map’ exports ‘foobar’.
 
 T11071.hs:23:12: error:
     Not in scope: ‘Data.List.sort’
diff --git a/testsuite/tests/rename/should_fail/T11071a.stderr b/testsuite/tests/rename/should_fail/T11071a.stderr
index 9db69ae578..853a79d3d7 100644
--- a/testsuite/tests/rename/should_fail/T11071a.stderr
+++ b/testsuite/tests/rename/should_fail/T11071a.stderr
@@ -1,26 +1,26 @@
 
 T11071a.hs:12:12: error:
-    Variable not in scope: intersperse
-    Perhaps you want to add ‘intersperse’ to the import list
-    in the import of ‘Data.List’ (T11071a.hs:3:1-24).
+    • Variable not in scope: intersperse
+    • Perhaps you want to add ‘intersperse’ to the import list
+      in the import of ‘Data.List’ (T11071a.hs:3:1-24).
 
 T11071a.hs:13:12: error:
-    Variable not in scope: foldl'
-    Perhaps you meant one of these:
-      ‘foldl’ (imported from Prelude), ‘foldl1’ (imported from Prelude),
-      ‘foldr’ (imported from Prelude)
-    Perhaps you want to add ‘foldl'’ to one of these import lists:
-      ‘Data.IntMap’ (T11071a.hs:4:1-21)
-      ‘Data.List’ (T11071a.hs:3:1-24)
+    • Variable not in scope: foldl'
+    • Perhaps you meant one of these:
+        ‘foldl’ (imported from Prelude), ‘foldl1’ (imported from Prelude),
+        ‘foldr’ (imported from Prelude)
+      Perhaps you want to add ‘foldl'’ to one of these import lists:
+        ‘Data.List’ (T11071a.hs:3:1-24)
+        ‘Data.IntMap’ (T11071a.hs:4:1-21)
 
 T11071a.hs:14:12: error:
-    Data constructor not in scope: Down
-    Perhaps you want to remove ‘Down’ from the explicit hiding list
-    in the import of ‘Data.Ord’ (T11071a.hs:5:1-29).
+    • Data constructor not in scope: Down
+    • Perhaps you want to remove ‘Down’ from the explicit hiding list
+      in the import of ‘Data.Ord’ (T11071a.hs:5:1-29).
 
 T11071a.hs:15:12: error:
-    Data constructor not in scope: True
-    Perhaps you want to remove ‘True’ from the explicit hiding list
-    in the import of ‘Prelude’ (T11071a.hs:6:1-28).
+    • Data constructor not in scope: True
+    • Perhaps you want to remove ‘True’ from the explicit hiding list
+      in the import of ‘Prelude’ (T11071a.hs:6:1-28).
 
 T11071a.hs:16:12: error: Variable not in scope: foobar
diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr
index 3bd6b40a82..e5bf51cf09 100644
--- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr
@@ -1,6 +1,6 @@
 [1 of 5] Compiling T6018Bfail       ( T6018Bfail.hs, T6018Bfail.o )
-[2 of 5] Compiling T6018Dfail       ( T6018Dfail.hs, T6018Dfail.o )
-[3 of 5] Compiling T6018Cfail       ( T6018Cfail.hs, T6018Cfail.o )
+[2 of 5] Compiling T6018Cfail       ( T6018Cfail.hs, T6018Cfail.o )
+[3 of 5] Compiling T6018Dfail       ( T6018Dfail.hs, T6018Dfail.o )
 [4 of 5] Compiling T6018Afail       ( T6018Afail.hs, T6018Afail.o )
 [5 of 5] Compiling T6018fail        ( T6018fail.hs, T6018fail.o )
 
diff --git a/testsuite/tests/typecheck/should_run/T7861.stderr b/testsuite/tests/typecheck/should_run/T7861.stderr
index e0aac9a558..e9ee5e91a7 100644
--- a/testsuite/tests/typecheck/should_run/T7861.stderr
+++ b/testsuite/tests/typecheck/should_run/T7861.stderr
@@ -1,13 +1,13 @@
 T7861: T7861.hs:10:5: error:
-    Couldn't match type ‘a’ with ‘[a]’
-    ‘a’ is a rigid type variable bound by
-      the type signature for:
-        f :: forall a. (forall b. a) -> a
-      at T7861.hs:9:6
-    Expected type: (forall b. a) -> a
-      Actual type: (forall b. a) -> [a]
-    In the expression: doA
-    In an equation for ‘f’: f = doA
-    Relevant bindings include
-      f :: (forall b. a) -> a (bound at T7861.hs:10:1)
+    • Couldn't match type ‘a’ with ‘[a]’
+      ‘a’ is a rigid type variable bound by
+        the type signature for:
+          f :: forall a. (forall b. a) -> a
+        at T7861.hs:9:1-23
+      Expected type: (forall b. a) -> a
+        Actual type: (forall b. a) -> [a]
+    • In the expression: doA
+      In an equation for ‘f’: f = doA
+    • Relevant bindings include
+        f :: (forall b. a) -> a (bound at T7861.hs:10:1)
 (deferred type error)