[commit: ghc] master: Make simplifyInstanceContexts deterministic (b58b0e1)
git at git.haskell.org
git at git.haskell.org
Tue May 10 12:31:20 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/b58b0e18a568bbf6381a85eea7adc72679355671/ghc
>---------------------------------------------------------------
commit b58b0e18a568bbf6381a85eea7adc72679355671
Author: Bartosz Nitka <niteria at gmail.com>
Date: Tue May 10 05:32:28 2016 -0700
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
>---------------------------------------------------------------
b58b0e18a568bbf6381a85eea7adc72679355671
compiler/basicTypes/Unique.hs | 15 ++++++++-------
compiler/basicTypes/Var.hs | 14 ++++++++++++--
compiler/typecheck/TcDeriv.hs | 31 ++++++++++++++++++++++++++++---
compiler/types/Type.hs | 16 ++++++++++++++--
4 files changed, 62 insertions(+), 14 deletions(-)
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index ca74373..eddf265 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 e641976..0af961e 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 06f87a3..7cc034c 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 49c7267..124015f 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 )
@@ -2086,6 +2087,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 *.
@@ -2148,7 +2159,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
@@ -2200,10 +2211,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
More information about the ghc-commits
mailing list