summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Builtin/Types/Literals.hs10
-rw-r--r--compiler/GHC/Cmm/CLabel.hs18
-rw-r--r--compiler/GHC/Core/Coercion/Axiom.hs4
-rw-r--r--compiler/GHC/Core/Map.hs17
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs2
-rw-r--r--compiler/GHC/Core/Rules.hs4
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs8
-rw-r--r--compiler/GHC/Data/FastString.hs77
-rw-r--r--compiler/GHC/Driver/Backpack.hs6
-rw-r--r--compiler/GHC/Hs/Lit.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs6
-rw-r--r--compiler/GHC/Iface/Ext/Debug.hs5
-rw-r--r--compiler/GHC/Iface/Ext/Types.hs45
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs26
-rw-r--r--compiler/GHC/Iface/Make.hs2
-rw-r--r--compiler/GHC/Iface/Recomp.hs5
-rw-r--r--compiler/GHC/IfaceToCore.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs9
-rw-r--r--compiler/GHC/Tc/TyCl.hs3
-rw-r--r--compiler/GHC/Types/CostCentre.hs7
-rw-r--r--compiler/GHC/Types/Literal.hs2
-rw-r--r--compiler/GHC/Types/Name/Occurrence.hs2
-rw-r--r--compiler/GHC/Types/SrcLoc.hs10
-rw-r--r--compiler/GHC/Unit/Info.hs8
-rw-r--r--compiler/GHC/Unit/Module/Name.hs2
-rw-r--r--compiler/GHC/Unit/State.hs13
-rw-r--r--compiler/GHC/Unit/Types.hs8
-rw-r--r--compiler/GHC/Utils/Binary.hs5
-rw-r--r--compiler/GHC/Utils/Encoding.hs33
-rw-r--r--compiler/GHC/Utils/Outputable.hs6
-rw-r--r--ghc/GHCi/UI.hs2
m---------utils/haddock0
32 files changed, 237 insertions, 113 deletions
diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs
index ef6fb962fd..cbb9f9e847 100644
--- a/compiler/GHC/Builtin/Types/Literals.hs
+++ b/compiler/GHC/Builtin/Types/Literals.hs
@@ -32,6 +32,7 @@ import GHC.Core.Coercion ( Role(..) )
import GHC.Tc.Types.Constraint ( Xi )
import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
import GHC.Types.Name ( Name, BuiltInSyntax(..) )
+import GHC.Types.Unique.FM
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders )
import GHC.Builtin.Names
@@ -50,7 +51,6 @@ import GHC.Builtin.Names
, typeSymbolAppendFamNameKey
)
import GHC.Data.FastString
-import qualified Data.Map as Map
import Data.Maybe ( isJust )
import Control.Monad ( guard )
import Data.List ( isPrefixOf, isSuffixOf )
@@ -401,7 +401,7 @@ axCmpSymbolDef =
s2' <- isStrLitTy s2
t2' <- isStrLitTy t2
return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===
- ordering (compare s2' t2')) }
+ ordering (lexicalCompareFS s2' t2')) }
axAppendSymbolDef = CoAxiomRule
{ coaxrName = fsLit "AppendSymbolDef"
@@ -457,8 +457,8 @@ axAppendSymbol0L = mkAxiom1 "Concat0L"
-- The list of built-in type family axioms that GHC uses.
-- If you define new axioms, make sure to include them in this list.
-- See Note [Adding built-in type families]
-typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule
-typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))
+typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule
+typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x))
[ axAddDef
, axMulDef
, axExpDef
@@ -706,7 +706,7 @@ matchFamCmpNat _ = Nothing
matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
matchFamCmpSymbol [s,t]
| Just x <- mbX, Just y <- mbY =
- Just (axCmpSymbolDef, [s,t], ordering (compare x y))
+ Just (axCmpSymbolDef, [s,t], ordering (lexicalCompareFS x y))
| tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)
where mbX = isStrLitTy s
mbY = isStrLitTy t
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 5f2eb565c5..2782da2ea4 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -311,19 +311,19 @@ instance Ord CLabel where
compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =
compare a1 a2 `thenCmp`
compare b1 b2 `thenCmp`
- compare c1 c2 `thenCmp`
+ uniqCompareFS c1 c2 `thenCmp`
compare d1 d2
compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
- compare a1 a2 `thenCmp`
+ uniqCompareFS a1 a2 `thenCmp`
compare b1 b2 `thenCmp`
compare c1 c2 `thenCmp`
compare d1 d2
compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
compare a1 a2 `thenCmp`
- compare b1 b2
+ uniqCompareFS b1 b2
compare (StringLitLabel u1) (StringLitLabel u2) =
nonDetCmpUnique u1 u2
compare (CC_Label a1) (CC_Label a2) =
@@ -451,13 +451,11 @@ data RtsLabelInfo
| RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks
| RtsApEntry Bool{-updatable-} Int{-arity-}
- | RtsPrimOp PrimOp
- | RtsApFast FastString -- ^ _fast versions of generic apply
+ | RtsPrimOp PrimOp
+ | RtsApFast NonDetFastString -- ^ _fast versions of generic apply
| RtsSlowFastTickyCtr String
- deriving (Eq, Ord)
- -- NOTE: Eq on PtrString compares the pointer only, so this isn't
- -- a real equality.
+ deriving (Eq,Ord)
-- | What type of Cmm label we're dealing with.
@@ -708,7 +706,7 @@ mkCCLabel cc = CC_Label cc
mkCCSLabel ccs = CCS_Label ccs
mkRtsApFastLabel :: FastString -> CLabel
-mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))
mkRtsSlowFastTickyCtrLabel :: String -> CLabel
mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
@@ -1308,7 +1306,7 @@ pprCLabel_common platform = \case
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
- (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
+ (RtsLabel (RtsApFast (NonDetFastString str))) -> ftext str <> text "_fast"
(RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
hcat [text "stg_sel_", text (show offset),
diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs
index a1ace3ccfd..2bf31f8cc1 100644
--- a/compiler/GHC/Core/Coercion/Axiom.hs
+++ b/compiler/GHC/Core/Coercion/Axiom.hs
@@ -568,7 +568,9 @@ instance Eq CoAxiomRule where
x == y = coaxrName x == coaxrName y
instance Ord CoAxiomRule where
- compare x y = compare (coaxrName x) (coaxrName y)
+ -- we compare lexically to avoid non-deterministic output when sets of rules
+ -- are printed
+ compare x y = lexicalCompareFS (coaxrName x) (coaxrName y)
instance Outputable CoAxiomRule where
ppr = ppr . coaxrName
diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs
index 092a5a9773..ad5cd6fd53 100644
--- a/compiler/GHC/Core/Map.hs
+++ b/compiler/GHC/Core/Map.hs
@@ -55,6 +55,7 @@ import GHC.Utils.Panic
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
+import GHC.Types.Unique.FM
import GHC.Types.Var.Env
import GHC.Types.Name.Env
import Control.Monad( (>=>) )
@@ -605,7 +606,7 @@ fdT k m = foldTM k (tm_var m)
------------------------
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
- , tlm_string :: Map.Map FastString a
+ , tlm_string :: UniqFM FastString a
}
instance TrieMap TyLitMap where
@@ -617,27 +618,27 @@ instance TrieMap TyLitMap where
mapTM = mapTyLit
emptyTyLitMap :: TyLitMap a
-emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }
+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }
mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b
mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })
- = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts }
+ = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts }
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
NumTyLit n -> tlm_number >.> Map.lookup n
- StrTyLit n -> tlm_string >.> Map.lookup n
+ StrTyLit n -> tlm_string >.> (`lookupUFM` n)
xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
xtTyLit l f m =
case l of
- NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }
- StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n }
+ NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }
+ StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n }
foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
-foldTyLit l m = flip (Map.foldr l) (tlm_string m)
- . flip (Map.foldr l) (tlm_number m)
+foldTyLit l m = flip (foldUFM l) (tlm_string m)
+ . flip (Map.foldr l) (tlm_number m)
-------------------------------------------------
-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 54487652f0..7e37592878 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -528,7 +528,7 @@ cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
-cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
+cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b
cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 4ad942c212..1ca0c67ebb 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -69,7 +69,7 @@ import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Utils.Misc
import Data.List
-import Data.Ord
+import Data.Function ( on )
import Control.Monad ( guard )
{-
@@ -271,7 +271,7 @@ pprRulesForUser :: [CoreRule] -> SDoc
pprRulesForUser rules
= withPprStyle defaultUserStyle $
pprRules $
- sortBy (comparing ruleName) $
+ sortBy (lexicalCompareFS `on` ruleName) $
tidyRules emptyTidyEnv rules
{-
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 5931d8c94a..5215b5ce2e 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -252,7 +252,13 @@ instance Outputable Type where
data TyLit
= NumTyLit Integer
| StrTyLit FastString
- deriving (Eq, Ord, Data.Data)
+ deriving (Eq, Data.Data)
+
+instance Ord TyLit where
+ compare (NumTyLit _) (StrTyLit _) = LT
+ compare (StrTyLit _) (NumTyLit _) = GT
+ compare (NumTyLit x) (NumTyLit y) = compare x y
+ compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y
instance Outputable TyLit where
ppr = pprTyLit
diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs
index 1907ef91c9..604c8f3e25 100644
--- a/compiler/GHC/Data/FastString.hs
+++ b/compiler/GHC/Data/FastString.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,
GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -12,8 +13,12 @@
-- ['FastString']
--
-- * A compact, hash-consed, representation of character strings.
--- * Comparison is O(1), and you can get a 'GHC.Types.Unique.Unique' from them.
-- * Generated by 'fsLit'.
+-- * You can get a 'GHC.Types.Unique.Unique' from them.
+-- * Equality test is O(1) (it uses the Unique).
+-- * Comparison is O(1) or O(n):
+-- * O(n) but deterministic with lexical comparison (`lexicalCompareFS`)
+-- * O(1) but non-deterministic with Unique comparison (`uniqCompareFS`)
-- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'.
--
-- ['PtrString']
@@ -50,6 +55,8 @@ module GHC.Data.FastString
-- * FastStrings
FastString(..), -- not abstract, for now.
+ NonDetFastString (..),
+ LexicalFastString (..),
-- ** Construction
fsLit,
@@ -74,6 +81,8 @@ module GHC.Data.FastString
consFS,
nilFS,
isUnderscoreFS,
+ lexicalCompareFS,
+ uniqCompareFS,
-- ** Outputting
hPutFS,
@@ -135,7 +144,7 @@ import GHC.Base (unpackCString#,unpackNBytes#)
import GHC.Exts
import GHC.IO
--- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'
+-- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString'
bytesFS, fastStringToByteString :: FastString -> ByteString
bytesFS = fastStringToByteString
@@ -196,17 +205,10 @@ data FastString = FastString {
instance Eq FastString where
f1 == f2 = uniq f1 == uniq f2
-instance Ord FastString where
- -- Compares lexicographically, not by unique
- a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
- a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
- a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
- a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
- max x y | x >= y = x
- | otherwise = y
- min x y | x <= y = x
- | otherwise = y
- compare a b = cmpFS a b
+-- We don't provide any "Ord FastString" instance to force you to think about
+-- which ordering you want:
+-- * lexical: deterministic, O(n). Cf lexicalCompareFS and LexicalFastString.
+-- * by unique: non-deterministic, O(1). Cf uniqCompareFS and NonDetFastString.
instance IsString FastString where
fromString = fsLit
@@ -231,12 +233,51 @@ instance Data FastString where
instance NFData FastString where
rnf fs = seq fs ()
--- | Compare FastString lexicographically
-cmpFS :: FastString -> FastString -> Ordering
-cmpFS fs1 fs2 =
+-- | Compare FastString lexically
+--
+-- If you don't care about the lexical ordering, use `uniqCompareFS` instead.
+lexicalCompareFS :: FastString -> FastString -> Ordering
+lexicalCompareFS fs1 fs2 =
if uniq fs1 == uniq fs2 then EQ else
- compare (unpackFS fs1) (unpackFS fs2)
- -- compare as String, not as ShortByteString (cf #18562)
+ utf8CompareShortByteString (fs_sbs fs1) (fs_sbs fs2)
+ -- perform a lexical comparison taking into account the Modified UTF-8
+ -- encoding we use (cf #18562)
+
+-- | Compare FastString by their Unique (not lexically).
+--
+-- Much cheaper than `lexicalCompareFS` but non-deterministic!
+uniqCompareFS :: FastString -> FastString -> Ordering
+uniqCompareFS fs1 fs2 = compare (uniq fs1) (uniq fs2)
+
+-- | Non-deterministic FastString
+--
+-- This is a simple FastString wrapper with an Ord instance using
+-- `uniqCompareFS` (i.e. which compares FastStrings on their Uniques). Hence it
+-- is not deterministic from one run to the other.
+newtype NonDetFastString
+ = NonDetFastString FastString
+ deriving (Eq,Data)
+
+instance Ord NonDetFastString where
+ compare (NonDetFastString fs1) (NonDetFastString fs2) = uniqCompareFS fs1 fs2
+
+instance Show NonDetFastString where
+ show (NonDetFastString fs) = show fs
+
+-- | Lexical FastString
+--
+-- This is a simple FastString wrapper with an Ord instance using
+-- `lexicalCompareFS` (i.e. which compares FastStrings on their String
+-- representation). Hence it is deterministic from one run to the other.
+newtype LexicalFastString
+ = LexicalFastString FastString
+ deriving (Eq,Data)
+
+instance Ord LexicalFastString where
+ compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2
+
+instance Show LexicalFastString where
+ show (LexicalFastString fs) = show fs
-- -----------------------------------------------------------------------------
-- Construction
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index bfc58a3f42..743ce77926 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -560,7 +560,7 @@ msgInclude (i,n) uid = do
-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId
-type PackageNameMap a = Map PackageName a
+type PackageNameMap a = UniqFM PackageName a
-- For now, something really simple, since we're not actually going
-- to use this for anything
@@ -569,7 +569,7 @@ unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
= (pn, HsComponentId pn (Indefinite (UnitId fs)))
bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
-bkpPackageNameMap units = Map.fromList (map unitDefines units)
+bkpPackageNameMap units = listToUFM (map unitDefines units)
renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
@@ -577,7 +577,7 @@ renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
renamePackageName :: PackageName -> HsComponentId
renamePackageName pn =
- case Map.lookup pn m of
+ case lookupUFM m pn of
Nothing ->
case lookupPackageName pkgstate pn of
Nothing -> error "no package name"
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index a529b138fb..4ceaac4264 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -223,7 +223,7 @@ instance Ord OverLitVal where
compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
compare (HsFractional _) (HsIntegral _) = GT
compare (HsFractional _) (HsIsString _ _) = LT
- compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2
+ compare (HsIsString _ s1) (HsIsString _ s2) = s1 `uniqCompareFS` s2
compare (HsIsString _ _) (HsIntegral _) = GT
compare (HsIsString _ _) (HsFractional _) = GT
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 452e649f5d..448ae5dc54 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -342,7 +342,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
, exps
]
- modulify file xs' = do
+ modulify (HiePath file) xs' = do
top_ev_asts <-
toHie $ EvBindContext ModuleScope Nothing
@@ -363,12 +363,12 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
case mergeSortAsts $ moduleNode : xs of
[x] -> return x
- xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
+ xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs)
asts' <- sequence
$ M.mapWithKey modulify
$ M.fromListWith (++)
- $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+ $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts
let asts = HieASTs $ resolveTyVarScopes asts'
return asts
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
index 903413eaab..b10b4c982c 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ b/compiler/GHC/Iface/Ext/Debug.hs
@@ -11,7 +11,6 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Unit.Module
-import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
@@ -28,7 +27,7 @@ type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
-diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))
+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a))
diffAsts f = diffList (diffAst f) `on` M.elems
diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
@@ -106,7 +105,7 @@ validAst (Node _ span children) = do
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
-validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
+validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc]
validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index fe11bd094c..75331a273e 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -10,13 +10,15 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
module GHC.Iface.Ext.Types where
import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
-import GHC.Data.FastString ( FastString )
+import GHC.Data.FastString
import GHC.Builtin.Utils
import GHC.Iface.Type
import GHC.Unit.Module ( ModuleName, Module )
@@ -211,9 +213,18 @@ instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
--- | Mapping from filepaths (represented using 'FastString') to the
--- corresponding AST
-newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
+
+-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
+-- non-determinism when printing or storing HieASTs which are sorted by their
+-- HiePath.
+type HiePath = LexicalFastString
+
+{-# COMPLETE HiePath #-}
+pattern HiePath :: FastString -> HiePath
+pattern HiePath fs = LexicalFastString fs
+
+-- | Mapping from filepaths to the corresponding AST
+newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) }
deriving (Functor, Foldable, Traversable)
instance Binary (HieASTs TypeIndex) where
@@ -285,13 +296,35 @@ instance Binary NodeOrigin where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+-- | A node annotation
+data NodeAnnotation = NodeAnnotation
+ { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor
+ , nodeAnnotType :: !FastString -- ^ name of the AST node Type
+ }
+ deriving (Eq)
+
+instance Ord NodeAnnotation where
+ compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)
+ = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]
+
+instance Outputable NodeAnnotation where
+ ppr (NodeAnnotation c t) = ppr (c,t)
+
+instance Binary NodeAnnotation where
+ put_ bh (NodeAnnotation c t) = do
+ put_ bh c
+ put_ bh t
+ get bh = NodeAnnotation
+ <$> get bh
+ <*> get bh
+
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
-- (see Note [Efficient serialization of redundant type info]).
data NodeInfo a = NodeInfo
- { nodeAnnotations :: S.Set (FastString,FastString)
- -- ^ (name of the AST node constructor, name of the AST node Type)
+ { nodeAnnotations :: S.Set NodeAnnotation
+ -- ^ Annotations
, nodeType :: [a]
-- ^ The Haskell types of this node, if any.
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index d1b6db6fb7..9245a11f7b 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -85,7 +85,7 @@ foldType f (Roll t) = f $ fmap (foldType f) t
selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
selectPoint hf (sl,sc) = getFirst $
- flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $
+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $
case selectSmallestContaining (sp fs) ast of
Nothing -> Nothing
Just ast' -> Just ast'
@@ -248,12 +248,12 @@ getTypeIndex t
return $ HCastTy i
go (CoercionTy _) = return HCoercionTy
-resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
+resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)
resolveTyVarScopes asts = M.map go asts
where
go ast = resolveTyVarScopeLocal ast asts
-resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
+resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a
resolveTyVarScopeLocal ast asts = go ast
where
resolveNameScope dets = dets{identInfo =
@@ -278,12 +278,12 @@ resolveTyVarScopeLocal ast asts = go ast
where
idents = M.map resolveNameScope $ nodeIdentifiers i
-getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
+getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span
getNameBinding n asts = do
(_,msp) <- getNameScopeAndBinding n asts
msp
-getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
+getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]
getNameScope n asts = do
(scopes,_) <- getNameScopeAndBinding n asts
return scopes
@@ -291,10 +291,10 @@ getNameScope n asts = do
getNameBindingInClass
:: Name
-> Span
- -> M.Map FastString (HieAST a)
+ -> M.Map HiePath (HieAST a)
-> Maybe Span
getNameBindingInClass n sp asts = do
- ast <- M.lookup (srcSpanFile sp) asts
+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts
getFirst $ foldMap First $ do
child <- flattenAst ast
dets <- maybeToList
@@ -304,11 +304,11 @@ getNameBindingInClass n sp asts = do
getNameScopeAndBinding
:: Name
- -> M.Map FastString (HieAST a)
+ -> M.Map HiePath (HieAST a)
-> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding n asts = case nameSrcSpan n of
RealSrcSpan sp _ -> do -- @Maybe
- ast <- M.lookup (srcSpanFile sp) asts
+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts
defNode <- selectLargestContainedBy sp ast
getFirst $ foldMap First $ do -- @[]
node <- flattenAst defNode
@@ -369,9 +369,9 @@ selectSmallestContaining sp node
| sp `containsSpan` nodeSpan node = Nothing
| otherwise = Nothing
-definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
+definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
definedInAsts asts n = case nameSrcSpan n of
- RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts
+ RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts
_ -> False
getEvidenceBindDeps :: ContextInfo -> [Name]
@@ -515,7 +515,7 @@ mergeSortAsts = go . map pure
mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
simpleNodeInfo :: FastString -> FastString -> NodeInfo a
-simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
+simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty
locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
locOnly (RealSrcSpan span _) = do
@@ -568,7 +568,7 @@ makeTypeNode x spn etyp = do
org <- ask
pure $ case spn of
RealSrcSpan span _ ->
- [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
_ -> []
where
cons = mkFastString . show . toConstr $ x
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index a179beff18..3fd0eaac29 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -292,7 +292,7 @@ mkIface_ hsc_env
mi_final_exts = (),
mi_ext_fields = emptyExtensibleFields }
where
- cmp_rule = comparing ifRuleName
+ cmp_rule = lexicalCompareFS `on` ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
-- because the latter is not stable across compilations:
cmp_inst = comparing (nameOccName . ifDFun)
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 2ffb094b11..7e72633622 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -39,6 +39,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique
import GHC.Utils.Misc hiding ( eqListBy )
import GHC.Data.Maybe
+import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
@@ -1081,11 +1082,11 @@ getOrphanHashes hsc_env mods = do
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
- = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d),
+ = Deps { dep_mods = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d),
- dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
+ dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) }
{-
************************************************************************
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index de32ae9e15..ae6461ce3a 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -81,7 +81,6 @@ import GHC.Fingerprint
import qualified GHC.Data.BooleanFormula as BF
import Control.Monad
-import qualified Data.Map as Map
{-
This module takes
@@ -1752,7 +1751,7 @@ tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
-- there are a fixed set of CoAxiomRules,
-- currently enumerated in typeNatCoAxiomRules
tcIfaceCoAxiomRule n
- = case Map.lookup n typeNatCoAxiomRules of
+ = case lookupUFM typeNatCoAxiomRules n of
Just ax -> return ax
_ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index f1030538e0..6ef43c634e 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -84,12 +84,11 @@ import GHC.Utils.Panic
import GHC.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
+import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
-import qualified Data.Set as Set
{-
************************************************************************
@@ -2818,11 +2817,11 @@ badFieldsUpd rbinds data_cons
-- For each field, which constructors contain the field?
membership :: [(FieldLabelString, [Bool])]
membership = sortMembership $
- map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
+ map (\fld -> (fld, map (elementOfUniqSet fld) fieldLabelSets)) $
map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
- fieldLabelSets :: [Set.Set FieldLabelString]
- fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
+ fieldLabelSets :: [UniqSet FieldLabelString]
+ fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
-- Sort in order of increasing number of True, so that a smaller
-- conflicting set can be found.
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 113fadd20d..50eeb60930 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -61,6 +61,7 @@ import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
+import GHC.Data.FastString
import GHC.Unit
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -3947,7 +3948,7 @@ checkValidTyCon tc
data_cons = tyConDataCons tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
- cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2
+ cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2
get_fields con = dataConFieldLabels con `zip` repeat con
-- dataConFieldLabels may return the empty list, which is fine
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs
index 730c469a04..0bb615a1c4 100644
--- a/compiler/GHC/Types/CostCentre.hs
+++ b/compiler/GHC/Types/CostCentre.hs
@@ -30,7 +30,6 @@ import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Data.FastString
-import GHC.Utils.Misc
import GHC.Types.CostCentre.State
import Data.Data
@@ -95,7 +94,11 @@ cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1}
NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2}
-- first key is module name, then centre name, then flavour
- = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
+ = mconcat
+ [ m1 `compare` m2
+ , n1 `lexicalCompareFS` n2 -- compare lexically to avoid non-determinism
+ , f1 `compare` f2
+ ]
cmpCostCentre other_1 other_2
= let
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 2c5471c52b..16d4539630 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -671,7 +671,7 @@ cmpLit (LitString a) (LitString b) = a `compare` b
cmpLit (LitNullAddr) (LitNullAddr) = EQ
cmpLit (LitFloat a) (LitFloat b) = a `compare` b
cmpLit (LitDouble a) (LitDouble b) = a `compare` b
-cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b
+cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `uniqCompareFS` b
cmpLit (LitNumber nt1 a) (LitNumber nt2 b)
| nt1 == nt2 = a `compare` b
| otherwise = nt1 `compare` nt2
diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs
index 9756900ad8..83037a0704 100644
--- a/compiler/GHC/Types/Name/Occurrence.hs
+++ b/compiler/GHC/Types/Name/Occurrence.hs
@@ -239,7 +239,7 @@ instance Eq OccName where
instance Ord OccName where
-- Compares lexicographically, *not* by Unique of the string
compare (OccName sp1 s1) (OccName sp2 s2)
- = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2)
+ = (s1 `lexicalCompareFS` s2) `thenCmp` (sp1 `compare` sp2)
instance Data OccName where
-- don't traverse?
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index 46a362026f..30db87d827 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -147,7 +147,7 @@ this is the obvious stuff:
--
-- Represents a single point within a file
data RealSrcLoc
- = SrcLoc FastString -- A precise location (file name)
+ = SrcLoc LexicalFastString -- A precise location (file name)
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
deriving (Eq, Ord)
@@ -244,7 +244,7 @@ mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing
mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
-mkRealSrcLoc x line col = SrcLoc x line col
+mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col
getBufPos :: SrcLoc -> Maybe BufPos
getBufPos (RealSrcLoc _ mbpos) = mbpos
@@ -262,7 +262,7 @@ mkGeneralSrcLoc = UnhelpfulLoc
-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
-srcLocFile (SrcLoc fname _ _) = fname
+srcLocFile (SrcLoc (LexicalFastString fname) _ _) = fname
-- | Raises an error when used on a "bad" 'SrcLoc'
srcLocLine :: RealSrcLoc -> Int
@@ -309,7 +309,7 @@ lookupSrcSpan (RealSrcSpan l _) = Map.lookup l
lookupSrcSpan (UnhelpfulSpan _) = const Nothing
instance Outputable RealSrcLoc where
- ppr (SrcLoc src_path src_line src_col)
+ ppr (SrcLoc (LexicalFastString src_path) src_line src_col)
= hcat [ pprFastFilePath src_path <> colon
, int src_line <> colon
, int src_col ]
@@ -458,7 +458,7 @@ srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)
realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
-realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
+realSrcLocSpan (SrcLoc (LexicalFastString file) line col) = RealSrcSpan' file line col line col
-- | Create a 'SrcSpan' between two points in a file
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
index 034b61e145..abb2122ef0 100644
--- a/compiler/GHC/Unit/Info.hs
+++ b/compiler/GHC/Unit/Info.hs
@@ -86,15 +86,11 @@ mapUnitInfo f = mapGenericUnitInfo
id -- module name
(fmap (mapGenUnit f)) -- instantiating modules
--- TODO: there's no need for these to be FastString, as we don't need the uniq
--- feature, but ghc doesn't currently have convenient support for any
--- other compact string types, e.g. plain ByteString or Text.
-
-newtype PackageId = PackageId FastString deriving (Eq, Ord)
+newtype PackageId = PackageId FastString deriving (Eq)
newtype PackageName = PackageName
{ unPackageName :: FastString
}
- deriving (Eq, Ord)
+ deriving (Eq)
instance Uniquable PackageId where
getUnique (PackageId n) = getUnique n
diff --git a/compiler/GHC/Unit/Module/Name.hs b/compiler/GHC/Unit/Module/Name.hs
index ad09fa7549..76c40f6a87 100644
--- a/compiler/GHC/Unit/Module/Name.hs
+++ b/compiler/GHC/Unit/Module/Name.hs
@@ -59,7 +59,7 @@ instance NFData ModuleName where
stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
-- ^ Compares module names lexically, rather than by their 'Unique's
-stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
+stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2
pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 6e3a53310c..c95c9e4031 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -415,7 +415,7 @@ data UnitState = UnitState {
-- | A mapping of 'PackageName' to 'IndefUnitId'. This is used when
-- users refer to packages in Backpack includes.
- packageNameMap :: Map PackageName IndefUnitId,
+ packageNameMap :: UniqFM PackageName IndefUnitId,
-- | A mapping from database unit keys to wired in unit ids.
wireMap :: Map UnitId UnitId,
@@ -460,7 +460,7 @@ emptyUnitState :: UnitState
emptyUnitState = UnitState {
unitInfoMap = Map.empty,
preloadClosure = emptyUniqSet,
- packageNameMap = Map.empty,
+ packageNameMap = emptyUFM,
wireMap = Map.empty,
unwireMap = Map.empty,
preloadUnits = [],
@@ -533,7 +533,7 @@ unsafeLookupUnitId state uid = case lookupUnitId state uid of
-- | Find the unit we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId
-lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
+lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n
-- | Search for units with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
@@ -1587,10 +1587,9 @@ mkUnitState ctx printer cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
- let pkgname_map = foldl' add Map.empty pkgs2
- where add pn_map p
- = Map.insert (unitPackageName p) (unitInstanceOf p) pn_map
-
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
-- The explicitUnits accurately reflects the set of units we have turned
-- on; as such, it also is the only way one can come up with requirements.
-- The requirement context is directly based off of this: we simply
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index f80a3b5b9d..aa725b429c 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -290,7 +290,7 @@ instance Eq (GenInstantiatedUnit unit) where
u1 == u2 = instUnitKey u1 == instUnitKey u2
instance Ord (GenInstantiatedUnit unit) where
- u1 `compare` u2 = instUnitFS u1 `compare` instUnitFS u2
+ u1 `compare` u2 = instUnitFS u1 `uniqCompareFS` instUnitFS u2
instance Binary InstantiatedUnit where
put_ bh indef = do
@@ -328,7 +328,7 @@ instance NFData Unit where
-- | Compares unit ids lexically, rather than by their 'Unique's
stableUnitCmp :: Unit -> Unit -> Ordering
-stableUnitCmp p1 p2 = unitFS p1 `compare` unitFS p2
+stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2
instance Outputable Unit where
ppr pk = pprUnit pk
@@ -504,7 +504,9 @@ instance Eq UnitId where
uid1 == uid2 = getUnique uid1 == getUnique uid2
instance Ord UnitId where
- u1 `compare` u2 = unitIdFS u1 `compare` unitIdFS u2
+ -- we compare lexically to avoid non-deterministic output when sets of
+ -- unit-ids are printed (dependencies, etc.)
+ u1 `compare` u2 = unitIdFS u1 `lexicalCompareFS` unitIdFS u2
instance Uniquable UnitId where
getUnique = getUnique . unitIdFS
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index d73939c53c..d4afa624cf 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -5,6 +5,8 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- We always optimise this, otherwise performance of a non-optimised
@@ -1207,6 +1209,9 @@ instance Binary FastString where
case getUserData bh of
UserData { ud_get_fs = get_fs } -> get_fs bh
+deriving instance Binary NonDetFastString
+deriving instance Binary LexicalFastString
+
-- Here to avoid loop
instance Binary LeftOrRight where
put_ bh CLeft = putByte bh 0
diff --git a/compiler/GHC/Utils/Encoding.hs b/compiler/GHC/Utils/Encoding.hs
index 24637a3bff..592b0bd40e 100644
--- a/compiler/GHC/Utils/Encoding.hs
+++ b/compiler/GHC/Utils/Encoding.hs
@@ -19,6 +19,7 @@ module GHC.Utils.Encoding (
utf8DecodeChar,
utf8DecodeByteString,
utf8DecodeShortByteString,
+ utf8CompareShortByteString,
utf8DecodeStringLazy,
utf8EncodeChar,
utf8EncodeString,
@@ -164,6 +165,38 @@ utf8DecodeStringLazy fp offset (I# len#)
-- withForeignPtr would provide here. That's why we use touchForeignPtr to
-- keep the fp alive until the last character has actually been decoded.
+utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering
+utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0#
+ -- UTF-8 has the property that sorting by bytes values also sorts by
+ -- code-points.
+ -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property
+ -- doesn't hold and we must explicitly check this case here.
+ -- Note that decoding every code point would also work but it would be much
+ -- more costly.
+ where
+ !sz1 = sizeofByteArray# a1
+ !sz2 = sizeofByteArray# a2
+ go off1 off2
+ | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ
+ | isTrue# (off1 >=# sz1) = LT
+ | isTrue# (off2 >=# sz2) = GT
+ | otherwise =
+ let !b1_1 = indexWord8Array# a1 off1
+ !b2_1 = indexWord8Array# a2 off2
+ in case b1_1 of
+ 0xC0## -> case b2_1 of
+ 0xC0## -> go (off1 +# 1#) (off2 +# 1#)
+ _ -> case indexWord8Array# a1 (off1 +# 1#) of
+ 0x80## -> LT
+ _ -> go (off1 +# 1#) (off2 +# 1#)
+ _ -> case b2_1 of
+ 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of
+ 0x80## -> GT
+ _ -> go (off1 +# 1#) (off2 +# 1#)
+ _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT
+ | isTrue# (b1_1 `ltWord#` b2_1) -> LT
+ | otherwise -> go (off1 +# 1#) (off2 +# 1#)
+
utf8DecodeShortByteString :: ShortByteString -> [Char]
utf8DecodeShortByteString (SBS ba#)
= unsafeDupablePerformIO $
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index af146ed72a..8723f16233 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -1,5 +1,8 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-
(c) The University of Glasgow 2006-2012
@@ -926,6 +929,9 @@ instance Outputable FastString where
ppr fs = ftext fs -- Prints an unadorned string,
-- no double quotes or anything
+deriving newtype instance Outputable NonDetFastString
+deriving newtype instance Outputable LexicalFastString
+
instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
ppr m = ppr (M.toList m)
instance (Outputable elt) => Outputable (IM.IntMap elt) where
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 948cc74a71..d4aa14682f 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -2464,7 +2464,7 @@ browseModule bang modl exports_only = do
annotate mts = concatMap (\(m,ts)->labels m:ts)
$ sortBy cmpQualifiers $ grp mts
where cmpQualifiers =
- compare `on` (map (fmap (map moduleNameFS)) . fst)
+ compare `on` (map (fmap (map (unpackFS . moduleNameFS))) . fst)
grp [] = []
grp mts@((m,_):_) = (m,map snd g) : grp ng
where (g,ng) = partition ((==m).fst) mts
diff --git a/utils/haddock b/utils/haddock
-Subproject 323aa89cbb4a3e8c8f32295e42a42635f05c849
+Subproject 54468d1e60cb10093120137766cfc9dd91671c9