Remove "Ord FastString" instance

FastStrings can be compared in 2 ways: by Unique or lexically. We don't
want to bless one particular way with an "Ord" instance because it leads
to bugs (#18562) or to suboptimal code (e.g. using lexical comparison
while a Unique comparison would suffice).

UTF-8 encoding has the advantage that sorting strings by their encoded
bytes also sorts them by their Unicode code points, without having to
decode the actual code points. BUT GHC uses Modified UTF-8 which
diverges from UTF-8 by encoding \0 as 0xC080 instead of 0x00 (to avoid
null bytes in the middle of a String so that the string can still be
null-terminated). This patch adds a new `utf8CompareShortByteString`
function that performs sorting by bytes but that also takes Modified
UTF-8 into account. It is much more performant than decoding the strings
into [Char] to perform comparisons (which we did in the previous patch).

Bump haddock submodule

6 files changed, 61 insertions, 28 deletions

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) }
 
 {-
 ************************************************************************