Delete Ord Unique

Ord Unique can be a source of invisible, accidental
nondeterminism as explained in Note [No Ord for Unique].
This removes it, leaving a note with rationale.

It's unfortunate that I had to write Ord instances for
codegen data structures by hand, but I believe that it's a
right trade-off here.

Test Plan: ./validate

Reviewers: simonmar, austin, bgamari

Reviewed By: simonmar

Subscribers: thomie

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

GHC Trac Issues: #4012

9 files changed, 169 insertions, 35 deletions

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 1e103d5eb1..2b508d6abd 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -627,13 +627,6 @@ instance Eq DataCon where
     a == b = getUnique a == getUnique b
     a /= b = getUnique a /= getUnique b
 
-instance Ord DataCon where
-    a <= b = getUnique a <= getUnique b
-    a <  b = getUnique a <  getUnique b
-    a >= b = getUnique a >= getUnique b
-    a >  b = getUnique a > getUnique b
-    compare a b = getUnique a `compare` getUnique b
-
 instance Uniquable DataCon where
     getUnique = dcUnique
 
diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot
index 7f512c2b42..0938b9b963 100644
--- a/compiler/basicTypes/DataCon.hs-boot
+++ b/compiler/basicTypes/DataCon.hs-boot
@@ -26,7 +26,6 @@ dataConFullSig :: DataCon
                -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type)
 
 instance Eq DataCon
-instance Ord DataCon
 instance Uniquable DataCon
 instance NamedThing DataCon
 instance Outputable DataCon
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 787a62b83a..59ed840626 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -537,8 +537,8 @@ newtype NDModule = NDModule { unNDModule :: Module }
 
 instance Ord NDModule where
   compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) =
-    (getUnique p1 `compare` getUnique p2) `thenCmp`
-    (getUnique n1 `compare` getUnique n2)
+    (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp`
+    (getUnique n1 `nonDetCmpUnique` getUnique n2)
 
 filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
 filterModuleEnv f (ModuleEnv e) =
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index eddf265bc6..b919da2144 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -196,31 +196,54 @@ use `deriving' because we want {\em precise} control of ordering
 -- As such, to get deterministic builds, the order of the allocated
 -- @Uniques@ should not affect the final result.
 -- see also wiki/DeterministicBuilds
-
-eqUnique, ltUnique, leUnique :: Unique -> Unique -> Bool
+--
+-- Note [Unique Determinism and code generation]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The goal of the deterministic builds (wiki/DeterministicBuilds, #4012)
+-- is to get ABI compatible binaries given the same inputs and environment.
+-- The motivation behind that is that if the ABI doesn't change the
+-- binaries can be safely reused.
+-- Note that this is weaker than bit-for-bit identical binaries and getting
+-- bit-for-bit identical binaries is not a goal for now.
+-- This means that we don't care about nondeterminism that happens after
+-- the interface files are created, in particular we don't care about
+-- register allocation and code generation.
+-- To track progress on bit-for-bit determinism see #12262.
+
+eqUnique :: Unique -> Unique -> Bool
 eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
-ltUnique (MkUnique u1) (MkUnique u2) = u1 <  u2
-leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
 
 -- Provided here to make it explicit at the call-site that it can
 -- introduce non-determinism.
 -- See Note [Unique Determinism]
+-- See Note [No Ord for Unique]
 nonDetCmpUnique :: Unique -> Unique -> Ordering
 nonDetCmpUnique (MkUnique u1) (MkUnique u2)
   = if u1 == u2 then EQ else if u1 < u2 then LT else GT
 
+{-
+Note [No Ord for Unique]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+As explained in Note [Unique Determinism] the relative order of Uniques
+is nondeterministic. To prevent from accidental use the Ord Unique
+instance has been removed.
+This makes it easier to maintain deterministic builds, but comes with some
+drawbacks.
+The biggest drawback is that Maps keyed by Uniques can't directly be used.
+The alternatives are:
+
+  1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which
+  2) Create a newtype wrapper based on Unique ordering where nondeterminism
+     is controlled. See Module.ModuleEnv
+  3) Change the algorithm to use nonDetCmpUnique and document why it's still
+     deterministic
+  4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel
+-}
+
 instance Eq Unique where
     a == b = eqUnique a b
     a /= b = not (eqUnique a b)
 
-instance Ord Unique where
-    a  < b = ltUnique a b
-    a <= b = leUnique a b
-    a  > b = not (leUnique a b)
-    a >= b = not (ltUnique a b)
-    compare a b = nonDetCmpUnique a b
-
------------------
 instance Uniquable Unique where
     getUnique u = u
 
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index df0020301f..b262371b65 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -244,8 +244,91 @@ data CLabel
   | LargeBitmapLabel
         {-# UNPACK #-} !Unique
 
-  deriving (Eq, Ord)
-
+  deriving Eq
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord CLabel where
+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2 `thenCmp`
+    compare d1 d2
+  compare (CaseLabel u1 a1) (CaseLabel u2 a2) =
+    nonDetCmpUnique u1 u2 `thenCmp`
+    compare a1 a2
+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare (StringLitLabel u1) (StringLitLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (PlainModuleInitLabel a1) (PlainModuleInitLabel a2) =
+    compare a1 a2
+  compare (CC_Label a1) (CC_Label a2) =
+    compare a1 a2
+  compare (CCS_Label a1) (CCS_Label a2) =
+    compare a1 a2
+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare PicBaseLabel PicBaseLabel = EQ
+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =
+    compare a1 a2
+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =
+    compare a1 a2
+  compare (SRTLabel u1) (SRTLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (LargeSRTLabel u1) (LargeSRTLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare IdLabel{} _ = LT
+  compare _ IdLabel{} = GT
+  compare CmmLabel{} _ = LT
+  compare _ CmmLabel{} = GT
+  compare RtsLabel{} _ = LT
+  compare _ RtsLabel{} = GT
+  compare ForeignLabel{} _ = LT
+  compare _ ForeignLabel{} = GT
+  compare CaseLabel{} _ = LT
+  compare _ CaseLabel{} = GT
+  compare AsmTempLabel{} _ = LT
+  compare _ AsmTempLabel{} = GT
+  compare AsmTempDerivedLabel{} _ = LT
+  compare _ AsmTempDerivedLabel{} = GT
+  compare StringLitLabel{} _ = LT
+  compare _ StringLitLabel{} = GT
+  compare PlainModuleInitLabel{} _ = LT
+  compare _ PlainModuleInitLabel{} = GT
+  compare CC_Label{} _ = LT
+  compare _ CC_Label{} = GT
+  compare CCS_Label{} _ = LT
+  compare _ CCS_Label{} = GT
+  compare DynamicLinkerLabel{} _ = LT
+  compare _ DynamicLinkerLabel{} = GT
+  compare PicBaseLabel{} _ = LT
+  compare _ PicBaseLabel{} = GT
+  compare DeadStripPreventer{} _ = LT
+  compare _ DeadStripPreventer{} = GT
+  compare HpcTicksLabel{} _ = LT
+  compare _ HpcTicksLabel{} = GT
+  compare SRTLabel{} _ = LT
+  compare _ SRTLabel{} = GT
+  compare LargeSRTLabel{} _ = LT
+  compare _ LargeSRTLabel{} = GT
 
 -- | Record where a foreign label is stored.
 data ForeignLabelSource
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 6c4742edad..3217c9394a 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -21,6 +21,8 @@ import Data.Word
 import qualified Data.Map as M
 import Outputable
 import UniqFM
+import UniqDFM
+import qualified TrieMap as TM
 import Unique
 import Control.Arrow (first, second)
 
@@ -285,10 +287,10 @@ copyTicks env g
 
 -- Group by [Label]
 groupByLabel :: [(Key, a)] -> [(Key, [a])]
-groupByLabel = go M.empty
+groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)
   where
-    go !m [] = M.elems m
-    go !m ((k,v) : entries) = go (M.alter adjust k' m) entries
+    go !m [] = TM.foldTM (:) m []
+    go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries
       where k' = map getUnique k
             adjust Nothing       = Just (k,[v])
             adjust (Just (_,vs)) = Just (k,v:vs)
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 4b3897fce4..7e4587eef4 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -250,8 +250,11 @@ data LocalReg
 instance Eq LocalReg where
   (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
 
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
 instance Ord LocalReg where
-  compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
 
 instance Uniquable LocalReg where
   getUnique (LocalReg uniq _) = uniq
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index b2e5cfb546..bba9bd77c3 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -34,8 +34,10 @@ import qualified Unique as U
 
 import Compiler.Hoopl
 import Data.Maybe
-import Data.List (tails,sort)
+import Data.List (tails,sortBy)
 import Prelude hiding (succ)
+import Unique (nonDetCmpUnique)
+import Util
 
 
 ------------------------
@@ -652,15 +654,23 @@ instance Eq CmmTickScope where
   (SubScope u _) == (SubScope u' _) = u == u'
   (SubScope _ _) == _               = False
   _              == (SubScope _ _)  = False
-  scope          == scope'          = sort (scopeUniques scope) ==
-                                      sort (scopeUniques scope')
+  scope          == scope'          =
+    sortBy nonDetCmpUnique (scopeUniques scope) ==
+    sortBy nonDetCmpUnique (scopeUniques scope')
+    -- This is still deterministic because
+    -- the order is the same for equal lists
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
 instance Ord CmmTickScope where
   compare GlobalScope    GlobalScope     = EQ
   compare GlobalScope    _               = LT
   compare _              GlobalScope     = GT
-  compare (SubScope u _) (SubScope u' _) = compare u u'
-  compare scope scope'                   = compare (sort $ scopeUniques scope)
-                                                   (sort $ scopeUniques scope')
+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
+  compare scope scope'                   = cmpList nonDetCmpUnique
+     (sortBy nonDetCmpUnique $ scopeUniques scope)
+     (sortBy nonDetCmpUnique $ scopeUniques scope')
 
 instance Outputable CmmTickScope where
   ppr GlobalScope     = text "global"
diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs
index e8d0187641..ea32d1045b 100644
--- a/compiler/nativeGen/Reg.hs
+++ b/compiler/nativeGen/Reg.hs
@@ -55,7 +55,28 @@ data VirtualReg
         | VirtualRegF  {-# UNPACK #-} !Unique
         | VirtualRegD  {-# UNPACK #-} !Unique
         | VirtualRegSSE {-# UNPACK #-} !Unique
-        deriving (Eq, Show, Ord)
+        deriving (Eq, Show)
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord VirtualReg where
+  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b
+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b
+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b
+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b
+  compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b
+  compare VirtualRegI{} _ = LT
+  compare _ VirtualRegI{} = GT
+  compare VirtualRegHi{} _ = LT
+  compare _ VirtualRegHi{} = GT
+  compare VirtualRegF{} _ = LT
+  compare _ VirtualRegF{} = GT
+  compare VirtualRegD{} _ = LT
+  compare _ VirtualRegD{} = GT
+
 
 instance Uniquable VirtualReg where
         getUnique reg