Commit 348f2dbb authored by niteria's avatar niteria

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
parent 93f40cb9
......@@ -87,9 +87,12 @@ import UniqDFM
import FastString
import Binary
import Util
import Data.List
import Data.Ord
import {-# SOURCE #-} Packages
import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..))
import Data.Coerce
import Data.Data
import Data.Map (Map)
import Data.Set (Set)
......@@ -243,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
......@@ -395,10 +395,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,71 +513,108 @@ 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
-- | A set of 'Module's
type ModuleSet = Set Module
type ModuleSet = Set NDModule
mkModuleSet :: [Module] -> ModuleSet
extendModuleSet :: ModuleSet -> Module -> ModuleSet
......@@ -588,10 +623,10 @@ moduleSetElts :: ModuleSet -> [Module]
elemModuleSet :: Module -> ModuleSet -> Bool
emptyModuleSet = Set.empty
mkModuleSet = Set.fromList
extendModuleSet s m = Set.insert m s
moduleSetElts = Set.toList
elemModuleSet = Set.member
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
......
......@@ -39,6 +39,7 @@ import Pair
import Panic
import VarSet
import Control.Monad
import Unique
import Data.Set (Set)
import qualified Data.Set as Set
......@@ -122,7 +123,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
......@@ -130,12 +130,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
......@@ -167,6 +195,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
......
......@@ -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'])
[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:
......
......@@ -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’
......
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
[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 )
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment