diff options
| author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-02-26 09:39:55 +0300 |
|---|---|---|
| committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-03-08 14:29:22 +0300 |
| commit | e6034341627c46f0ad81ff088add2552623c2342 (patch) | |
| tree | b20705a7cf515620961ee0021aeca652631ae8fe | |
| parent | 3e082f8ff5ea2f42c5e6430094683b26b5818fb8 (diff) | |
| download | haskell-wip/cmp-tylit.tar.gz | |
Replace Ord TyLit with nonDetCmpTyLit (#19441)wip/cmp-tylit
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.hs | 30 | ||||
| -rw-r--r-- | compiler/GHC/Core/Type.hs | 2 |
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 |