summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2021-02-26 09:39:55 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-09 18:51:55 -0500
commitaaa5fc21af8dda26bf6c497d1036833225c94fa1 (patch)
treedbd865e2054b84ddf8544eef7afcd0adb5f60add
parent7a728ca6a52ff8c1a1ad43c81cf9289a61dca107 (diff)
downloadhaskell-aaa5fc21af8dda26bf6c497d1036833225c94fa1.tar.gz
Replace Ord TyLit with nonDetCmpTyLit (#19441)
The Ord instance was non-deterministic, but it's easy assume that it is deterministic. In fact, haddock-api used to do exactly that before haddock/7e8c7c3491f3e769368b8e6c767c62a33e996c80
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs30
-rw-r--r--compiler/GHC/Core/Type.hs2
2 files changed, 21 insertions, 11 deletions
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 75d56ed501..493b2d767a 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -52,6 +52,7 @@ module GHC.Core.TyCo.Rep (
mkScaledFunTy,
mkVisFunTyMany, mkVisFunTysMany,
mkInvisFunTyMany, mkInvisFunTysMany,
+ nonDetCmpTyLit, cmpTyLit,
-- * Functions over binders
TyCoBinder(..), TyCoVarBinder, TyBinder,
@@ -192,16 +193,25 @@ data TyLit
| CharTyLit Char
deriving (Eq, Data.Data)
-instance Ord TyLit where
- compare (NumTyLit x) (NumTyLit y) = compare x y
- compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y
- compare (CharTyLit x) (CharTyLit y) = compare x y
- compare a b = compare (tag a) (tag b)
- where
- tag :: TyLit -> Int
- tag NumTyLit{} = 0
- tag StrTyLit{} = 1
- tag CharTyLit{} = 2
+-- Non-determinism arises due to uniqCompareFS
+nonDetCmpTyLit :: TyLit -> TyLit -> Ordering
+nonDetCmpTyLit = cmpTyLitWith NonDetFastString
+
+-- Slower than nonDetCmpTyLit but deterministic
+cmpTyLit :: TyLit -> TyLit -> Ordering
+cmpTyLit = cmpTyLitWith LexicalFastString
+
+{-# INLINE cmpTyLitWith #-}
+cmpTyLitWith :: Ord r => (FastString -> r) -> TyLit -> TyLit -> Ordering
+cmpTyLitWith _ (NumTyLit x) (NumTyLit y) = compare x y
+cmpTyLitWith w (StrTyLit x) (StrTyLit y) = compare (w x) (w y)
+cmpTyLitWith _ (CharTyLit x) (CharTyLit y) = compare x y
+cmpTyLitWith _ a b = compare (tag a) (tag b)
+ where
+ tag :: TyLit -> Int
+ tag NumTyLit{} = 0
+ tag StrTyLit{} = 1
+ tag CharTyLit{} = 2
instance Outputable TyLit where
ppr = pprTyLit
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 25276c155f..b0aa10c4cd 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -2562,7 +2562,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
-- Comparing multiplicities last because the test is usually true
go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)
= liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2
- go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2)
+ go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2)
go env (CastTy t1 _) t2 = hasCast $ go env t1 t2
go env t1 (CastTy t2 _) = hasCast $ go env t1 t2