Make simplifyInstanceContexts deterministic

simplifyInstanceContexts used cmpType which is nondeterministic
for canonicalising typeclass constraints in derived instances.
Following changes make it deterministic as explained by the
Note [Deterministic simplifyInstanceContexts].

Test Plan: ./validate

Reviewers: simonmar, goldfire, simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: thomie

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

GHC Trac Issues: #4012

(cherry picked from commit b58b0e18a568bbf6381a85eea7adc72679355671)

4 files changed, 62 insertions, 14 deletions

diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index ca74373ce4..eddf265bc6 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -23,7 +23,7 @@ module Unique (
         Unique, Uniquable(..),
 
         -- ** Constructors, destructors and operations on 'Unique's
-        hasKey, cmpByUnique,
+        hasKey,
 
         pprUnique,
 
@@ -35,6 +35,7 @@ module Unique (
         deriveUnique,                   -- Ditto
         newTagUnique,                   -- Used in CgCase
         initTyVarUnique,
+        nonDetCmpUnique,
 
         -- ** Making built-in uniques
 
@@ -168,9 +169,6 @@ instance Uniquable FastString where
 instance Uniquable Int where
  getUnique i = mkUniqueGrimily i
 
-cmpByUnique :: Uniquable a => a -> a -> Ordering
-cmpByUnique x y = (getUnique x) `cmpUnique` (getUnique y)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -204,8 +202,11 @@ eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
 ltUnique (MkUnique u1) (MkUnique u2) = u1 <  u2
 leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
 
-cmpUnique :: Unique -> Unique -> Ordering
-cmpUnique (MkUnique u1) (MkUnique u2)
+-- Provided here to make it explicit at the call-site that it can
+-- introduce non-determinism.
+-- See Note [Unique Determinism]
+nonDetCmpUnique :: Unique -> Unique -> Ordering
+nonDetCmpUnique (MkUnique u1) (MkUnique u2)
   = if u1 == u2 then EQ else if u1 < u2 then LT else GT
 
 instance Eq Unique where
@@ -217,7 +218,7 @@ instance Ord Unique where
     a <= b = leUnique a b
     a  > b = not (leUnique a b)
     a >= b = not (ltUnique a b)
-    compare a b = cmpUnique a b
+    compare a b = nonDetCmpUnique a b
 
 -----------------
 instance Uniquable Unique where
diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index d6bd609c4c..c70a304090 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -64,7 +64,9 @@ module Var (
 
         -- ** Modifying 'TyVar's
         setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,
-        updateTyVarKindM
+        updateTyVarKindM,
+
+        nonDetCmpVar
 
     ) where
 
@@ -80,6 +82,7 @@ import Util
 import DynFlags
 import Outputable
 
+import Unique (nonDetCmpUnique)
 import Data.Data
 
 {-
@@ -269,7 +272,14 @@ instance Ord Var where
     a <  b = realUnique a <  realUnique b
     a >= b = realUnique a >= realUnique b
     a >  b = realUnique a >  realUnique b
-    a `compare` b = varUnique a `compare` varUnique b
+    a `compare` b = a `nonDetCmpVar` b
+
+-- | Compare Vars by their Uniques.
+-- This is what Ord Var does, provided here to make it explicit at the
+-- call-site that it can introduce non-determinism.
+-- See Note [Unique Determinism]
+nonDetCmpVar :: Var -> Var -> Ordering
+nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b
 
 instance Data Var where
   -- don't traverse?
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index c74b45064c..944c513768 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1862,6 +1862,29 @@ this by simplifying the RHS to a form in which
         - the list is sorted by tyvar (major key) and then class (minor key)
         - no duplicates, of course
 
+Note [Deterministic simplifyInstanceContexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Canonicalisation uses cmpType which is nondeterministic. Sorting
+with cmpType puts the returned lists in a nondeterministic order.
+If we were to return them, we'd get class constraints in
+nondeterministic order.
+
+Consider:
+
+  data ADT a b = Z a b deriving Eq
+
+The generated code could be either:
+
+  instance (Eq a, Eq b) => Eq (Z a b) where
+
+Or:
+
+  instance (Eq b, Eq a) => Eq (Z a b) where
+
+To prevent the order from being nondeterministic we only
+canonicalize when comparing and return them in the same order as
+simplifyDeriv returned them.
+See also Note [cmpType nondeterminism]
 -}
 
 
@@ -1909,8 +1932,10 @@ simplifyInstanceContexts infer_specs
              else
                 iterate_deriv (n+1) new_solns }
 
-    eqSolution = eqListBy (eqListBy eqType)
-
+    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
+       -- Canonicalise for comparison
+       -- See Note [Deterministic simplifyInstanceContexts]
+    canSolution = map (sortBy cmpType)
     ------------------------------------------------------------------
     gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType
     gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
@@ -1925,7 +1950,7 @@ simplifyInstanceContexts infer_specs
                 -- Claim: the result instance declaration is guaranteed valid
                 -- Hence no need to call:
                 --   checkValidInstance tyvars theta clas inst_tys
-           ; return (sortBy cmpType theta) }    -- Canonicalise before returning the solution
+           ; return theta }
       where
         the_pred = mkClassPred clas inst_tys
 
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index b4a123b048..69cf69f10a 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -223,6 +223,7 @@ import FastString
 import Pair
 import ListSetOps
 import Digraph
+import Unique ( nonDetCmpUnique )
 
 import Maybes           ( orElse )
 import Data.Maybe       ( isJust, mapMaybe )
@@ -2098,6 +2099,16 @@ eqVarBndrs _ _ _= Nothing
 
 -- Now here comes the real worker
 
+{-
+Note [cmpType nondeterminism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+cmpType is implemented in terms of cmpTypeX. cmpTypeX uses cmpTc which
+compares TyCons by their Unique value. Using Uniques for ordering leads
+to nondeterminism. We hit the same problem in the TyVarTy case, comparing
+type variables is nondeterministic, note the call to nonDetCmpVar in cmpTypeX.
+See Note [Unique Determinism] for more details.
+-}
+
 cmpType :: Type -> Type -> Ordering
 cmpType t1 t2
   -- we know k1 and k2 have the same kind, because they both have kind *.
@@ -2160,7 +2171,7 @@ cmpTypeX env orig_t1 orig_t2 =
       | Just t2' <- coreViewOneStarKind t2 = go env t1 t2'
 
     go env (TyVarTy tv1)       (TyVarTy tv2)
-      = liftOrdering $ rnOccL env tv1 `compare` rnOccR env tv2
+      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2
     go env (ForAllTy (Named tv1 _) t1) (ForAllTy (Named tv2 _) t2)
       = go env (tyVarKind tv1) (tyVarKind tv2)
         `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2
@@ -2211,10 +2222,11 @@ cmpTypesX _   _         []        = GT
 -- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms",
 -- as recognized by Kind.isStarKindSynonymTyCon. See Note
 -- [Kind Constraint and kind *] in Kind.
+-- See Note [cmpType nondeterminism]
 cmpTc :: TyCon -> TyCon -> Ordering
 cmpTc tc1 tc2
   = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) )
-    u1 `compare` u2
+    u1 `nonDetCmpUnique` u2
   where
     u1  = tyConUnique tc1
     u2  = tyConUnique tc2