Make the Ord Module independent of Unique order (2nd try)

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].

This fixes #12191 - the regression, that the previous version of this
patch had.

Test Plan:
./validate
run nofib: P112

Reviewers: simonmar, bgamari, austin

Subscribers: thomie

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

GHC Trac Issues: #4012, #12191

(cherry picked from commit 348f2dbb835b1208f601bb1e8daa1d1d54507eda)

7 files changed, 122 insertions, 56 deletions

diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 00511474f4..c8504fd21e 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -86,13 +86,18 @@ import UniqFM
 import FastString
 import Binary
 import Util
+import Data.List
+import Data.Ord
 import {-# SOURCE #-} Packages
 import GHC.PackageDb (BinaryStringRep(..))
 
+import Data.Coerce
 import Data.Data
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 import System.FilePath
 
 -- Note [The identifier lexicon]
@@ -241,11 +246,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
@@ -389,10 +391,8 @@ newtype UnitId = PId FastString deriving( Eq, Typeable )
 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?
@@ -509,65 +509,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
@@ -576,7 +613,7 @@ foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
 foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e
 
 -- | A set of 'Module's
-type ModuleSet = Map Module ()
+type ModuleSet = Set NDModule
 
 mkModuleSet     :: [Module] -> ModuleSet
 extendModuleSet :: ModuleSet -> Module -> ModuleSet
@@ -584,11 +621,11 @@ emptyModuleSet  :: ModuleSet
 moduleSetElts   :: ModuleSet -> [Module]
 elemModuleSet   :: Module -> ModuleSet -> Bool
 
-emptyModuleSet    = Map.empty
-mkModuleSet ms    = Map.fromList [(m,()) | m <- ms ]
-extendModuleSet s m = Map.insert m () s
-moduleSetElts     = Map.keys
-elemModuleSet     = Map.member
+emptyModuleSet    = Set.empty
+mkModuleSet       = Set.fromList . coerce
+extendModuleSet s m = Set.insert (NDModule m) s
+moduleSetElts     = sort . coerce . Set.toList
+elemModuleSet     = Set.member . coerce
 
 {-
 A ModuleName has a Unique, so we can build mappings of these using
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 784bc817b4..5f7dc53a5f 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -40,6 +40,7 @@ import Pair
 import Panic
 import VarSet
 import Control.Monad
+import Unique
 import Data.Set (Set)
 import qualified Data.Set as Set
 
@@ -126,7 +127,6 @@ certain that the modules in our `HscTypes.dep_finsts' are consistent.)
 data ModulePair = ModulePair Module Module
                   -- Invariant: first Module < second Module
                   -- use the smart constructor
-  deriving (Ord, Eq)
 
 -- | Smart constructor that establishes the invariant
 modulePair :: Module -> Module -> ModulePair
@@ -134,12 +134,40 @@ modulePair a b
   | a < b = ModulePair a b
   | otherwise = ModulePair b a
 
+instance Eq ModulePair where
+  (ModulePair a1 b1) == (ModulePair a2 b2) = a1 == a2 && b1 == b2
+
+instance Ord ModulePair where
+  (ModulePair a1 b1) `compare` (ModulePair a2 b2) =
+    nonDetCmpModule a1 a2 `thenCmp`
+    nonDetCmpModule b1 b2
+    -- See Note [ModulePairSet determinism and performance]
+
 instance Outputable ModulePair where
   ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
 
--- Sets of module pairs
---
+-- Fast, nondeterministic comparison on Module. Don't use when the ordering
+-- can change the ABI. See Note [ModulePairSet determinism and performance]
+nonDetCmpModule :: Module -> Module -> Ordering
+nonDetCmpModule a b =
+  nonDetCmpUnique (getUnique $ moduleUnitId a) (getUnique $ moduleUnitId b)
+  `thenCmp`
+  nonDetCmpUnique (getUnique $ moduleName a) (getUnique $ moduleName b)
+
 type ModulePairSet = Set ModulePair
+{-
+Note [ModulePairSet determinism and performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The size of ModulePairSet is quadratic in the number of modules.
+The Ord instance for Module uses string comparison which is linear in the
+length of ModuleNames and UnitIds. This adds up to a significant cost, see
+#12191.
+
+To get reasonable performance ModulePairSet uses nondeterministic ordering
+on Module based on Uniques. It doesn't affect the ABI, because it only
+determines the order the modules are checked for family instance consistency.
+See Note [Unique Determinism] in Unique
+-}
 
 listToSet :: [ModulePair] -> ModulePairSet
 listToSet l = Set.fromList l
@@ -170,6 +198,7 @@ checkFamInstConsistency famInstMods directlyImpMods
              ; toCheckPairs  =
                  Set.elems $ criticalPairs `Set.difference` okPairs
                  -- the difference gives us the pairs we need to check now
+                 -- See Note [ModulePairSet determinism and performance]
              }
 
        ; mapM_ (check hpt_fam_insts) toCheckPairs
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 d98f66ca3c..35dd359a56 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 )