Commit b58b0e18 authored by niteria's avatar niteria

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
parent 4ac0e815
......@@ -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
......
......@@ -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?
......
......@@ -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
......
......@@ -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
......
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