compiler/GHC/Core/Map/Expr.hs

@@ -40,6 +40,7 @@ import GHC.Utils.Outputable
 import qualified Data.Map    as Map
 import GHC.Types.Name.Env
 import Control.Monad( (>=>) )
+import GHC.Types.Literal (Literal)
 
 {-
 This module implements TrieMaps over Core related data structures
@@ -128,6 +129,8 @@ instance TrieMap CoreMap where
 -- inside another 'TrieMap', this is the type you want.
 type CoreMapG = GenMap CoreMapX
 
+type LiteralMap = Map.Map Literal
+
 -- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
 -- the 'GenMap' optimization.
 data CoreMapX a

compiler/GHC/Core/TyCo/Rep.hs

@@ -952,13 +952,13 @@ data CoSel  -- See Note [SelCo]
 
   | SelForAll          -- Decomposes (forall a. co)
 
-  deriving( Eq, Data.Data )
+  deriving( Eq, Data.Data, Ord )
 
 data FunSel  -- See Note [SelCo]
   = SelMult  -- Multiplicity
   | SelArg   -- Argument of function
   | SelRes   -- Result of function
-  deriving( Eq, Data.Data )
+  deriving( Eq, Data.Data, Ord )
 
 type CoercionN = Coercion       -- always nominal
 type CoercionR = Coercion       -- always representational

compiler/GHC/CoreToIface.hs

@@ -121,7 +121,7 @@ toIfaceTvBndr :: TyVar -> IfaceTvBndr
 toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
 
 toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
-toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
+toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))
                           , toIfaceTypeX fr (tyVarKind tyvar)
                           )
 
@@ -133,7 +133,7 @@ toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
 
 toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
 toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)
-                          , occNameFS (getOccName covar)
+                          , mkIfLclName (occNameFS (getOccName covar))
                           , toIfaceTypeX fr (varType covar)
                           )
 
@@ -218,11 +218,11 @@ toIfaceTypeX fr (TyConApp tc tys)
     arity = tyConArity tc
     n_tys = length tys
 
-toIfaceTyVar :: TyVar -> FastString
-toIfaceTyVar = occNameFS . getOccName
+toIfaceTyVar :: TyVar -> IfLclName
+toIfaceTyVar = mkIfLclName . occNameFS . getOccName
 
-toIfaceCoVar :: CoVar -> FastString
-toIfaceCoVar = occNameFS . getOccName
+toIfaceCoVar :: CoVar -> IfLclName
+toIfaceCoVar = mkIfLclName . occNameFS . getOccName
 
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
@@ -264,7 +264,7 @@ toIfaceTyCon_name n = IfaceTyCon n info
 
 toIfaceTyLit :: TyLit -> IfaceTyLit
 toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
-toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x)
 toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
 
 ----------------
@@ -296,7 +296,7 @@ toIfaceCoercionX fr co
     go (InstCo co arg)      = IfaceInstCo (go co) (go arg)
     go (KindCo c)           = IfaceKindCo (go c)
     go (SubCo co)           = IfaceSubCo (go co)
-    go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)
+    go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (mkIfLclName (coaxrName co)) (map go cs)
     go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
     go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov p) r
                                           (toIfaceTypeX fr t1)
@@ -433,7 +433,7 @@ toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
 toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
 
 toIfaceLetBndr :: Id -> IfaceLetBndr
-toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
+toIfaceLetBndr id  = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))
                                (toIfaceType (idType id))
                                (toIfaceIdInfo (idInfo id))
                                (idJoinPointHood id)
@@ -444,7 +444,7 @@ toIfaceTopBndr :: Id -> IfaceTopBndrInfo
 toIfaceTopBndr id
   = if isExternalName name
       then IfGblTopBndr name
-      else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id))
+      else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id))
                         (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))
   where
     name = getName id
@@ -555,7 +555,7 @@ toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfac
 toIfaceExpr (App f a)       = toIfaceApp f [a]
 toIfaceExpr (Case s x ty as)
   | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
-  | otherwise               = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
+  | otherwise               = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as)
 toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
 toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
 toIfaceExpr (Tick t e)      = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
@@ -610,7 +610,7 @@ toIfaceTopBind b =
 
 ---------------------
 toIfaceAlt :: CoreAlt -> IfaceAlt
-toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)
+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)
 
 ---------------------
 toIfaceCon :: AltCon -> IfaceConAlt
@@ -655,7 +655,7 @@ toIfaceVar v
                                       -- Foreign calls have special syntax
 
     | isExternalName name             = IfaceExt name
-    | otherwise                       = IfaceLcl (occNameFS $ nameOccName name)
+    | otherwise                       = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name))
   where
     name = idName v
     ty   = idType v

compiler/GHC/Data/FastString.hs

@@ -283,13 +283,16 @@ instance Ord NonDetFastString where
 -- `lexicalCompareFS` (i.e. which compares FastStrings on their String
 -- representation). Hence it is deterministic from one run to the other.
 newtype LexicalFastString
-   = LexicalFastString FastString
+   = LexicalFastString { getLexicalFastString :: FastString }
    deriving newtype (Eq, Show)
    deriving stock Data
 
 instance Ord LexicalFastString where
    compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2
 
+instance NFData LexicalFastString where
+  rnf (LexicalFastString f) = rnf f
+
 -- -----------------------------------------------------------------------------
 -- Construction
 

compiler/GHC/Data/TrieMap.hs

@@ -13,8 +13,6 @@ module GHC.Data.TrieMap(
    MaybeMap,
    -- * Maps over 'List' values
    ListMap,
-   -- * Maps over 'Literal's
-   LiteralMap,
    -- * 'TrieMap' class
    TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
 
@@ -30,7 +28,6 @@ module GHC.Data.TrieMap(
 
 import GHC.Prelude
 
-import GHC.Types.Literal
 import GHC.Types.Unique.DFM
 import GHC.Types.Unique( Uniquable )
 
@@ -39,6 +36,8 @@ import qualified Data.IntMap as IntMap
 import GHC.Utils.Outputable
 import Control.Monad( (>=>) )
 import Data.Kind( Type )
+import Data.Functor.Compose
+import Data.Functor.Product
 
 import qualified Data.Semigroup as S
 
@@ -343,15 +342,87 @@ ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
 ftList f (LM { lm_nil = mnil, lm_cons = mcons })
   = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }
 
-{-
-************************************************************************
-*                                                                      *
-                   Basic maps
-*                                                                      *
-************************************************************************
--}
+{- Composition -}
+
+instance (TrieMap m, TrieMap n) => TrieMap (Compose m n) where
+  type Key (Compose m n) = (Key m, Key n)
+  emptyTM  = Compose emptyTM
+  lookupTM = lkCompose lookupTM lookupTM
+  {-# INLINE lookupTM #-}
+  alterTM  = xtCompose alterTM alterTM
+  {-# INLINE alterTM #-}
+  foldTM   = fdCompose
+  {-# INLINE foldTM #-}
+  filterTM = ftCompose
+  {-# INLINE filterTM #-}
+
+lkCompose :: Monad m => (t1 -> f (g a1) -> m a2) -> (t2 -> a2 -> m b) -> (t1, t2) -> Compose f g a1 -> m b
+lkCompose f g (a, b) (Compose m) = f a m >>= g b
+{-# INLINE lkCompose #-}
+
+xtCompose ::
+          (TrieMap m, TrieMap n)
+          => (forall a  . Key m -> XT a -> m a -> m a)
+          -> (forall a . Key n -> XT a -> n a -> n a)
+          -> Key (Compose m n)
+          -> XT a
+          -> Compose m n a
+          -> Compose m n a
+
+xtCompose f g (a, b) xt (Compose m) = Compose ((f a |>> g b xt) m)
+
+{-# INLINE xtCompose #-}
+
+fdCompose :: (TrieMap m1, TrieMap m2) => (a -> b -> b) -> Compose m1 m2 a -> b -> b
+fdCompose f (Compose m) = foldTM (foldTM f) m
+
+{-# INLINE fdCompose #-}
+
+
+ftCompose :: (TrieMap n, Functor m) => (a -> Bool) -> Compose m n a -> Compose m n a
+ftCompose f (Compose m) = Compose (fmap (filterTM f) m)
+
+{-# INLINE ftCompose #-}
+
+{- Product -}
+instance (TrieMap m, TrieMap n) => TrieMap (Product m n) where
+  type Key (Product m n) = Either (Key m) (Key n)
+  emptyTM  = Pair emptyTM emptyTM
+  lookupTM = lkProduct
+  {-# INLINE lookupTM #-}
+  alterTM  = xtProduct
+  {-# INLINE alterTM #-}
+  foldTM   = fdProduct
+  {-# INLINE foldTM #-}
+  filterTM = ftProduct
+  {-# INLINE filterTM #-}
+
+lkProduct :: (TrieMap m1, TrieMap m2) => Either (Key m1) (Key m2) -> Product m1 m2 b -> Maybe b
+lkProduct k (Pair am bm) =
+  case k of
+    Left a -> lookupTM a am
+    Right b -> lookupTM b bm
+
+{-# INLINE lkProduct #-}
+
+xtProduct :: (TrieMap f, TrieMap g) => Either (Key f) (Key g) -> XT a -> Product f g a -> Product f g a
+xtProduct k xt (Pair am bm) =
+  case k of
+    Left a -> Pair (alterTM a xt am) bm
+    Right b -> Pair am (alterTM b xt bm)
+
+{-# INLINE xtProduct #-}
+
+fdProduct :: (TrieMap f, TrieMap g) => (a -> c -> c) -> Product f g a -> c -> c
+fdProduct f (Pair am bm) = foldTM f am . foldTM f bm
+
+{-# INLINE fdProduct #-}
+
+ftProduct :: (TrieMap f, TrieMap g) => (a -> Bool) -> Product f g a -> Product f g a
+ftProduct f (Pair am bm) = Pair (filterTM f am) (filterTM f bm)
+
+{-# INLINE ftProduct #-}
 
-type LiteralMap  a = Map.Map Literal a
 
 {-
 ************************************************************************

compiler/GHC/Driver/DynFlags.hs

@@ -207,6 +207,7 @@ data DynFlags = DynFlags {
   dmdUnboxWidth         :: !Int,        -- ^ Whether DmdAnal should optimistically put an
                                         --   Unboxed demand on returned products with at most
                                         --   this number of fields
+  ifCompression         :: Int,
   specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr
   specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function
   specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types
@@ -546,6 +547,7 @@ defaultDynFlags mySettings =
         maxPmCheckModels        = 30,
         simplTickFactor         = 100,
         dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple
+        ifCompression           = 1,
         specConstrThreshold     = Just 2000,
         specConstrCount         = Just 3,
         specConstrRecursive     = 3,

compiler/GHC/Driver/Main.hs

@@ -163,7 +163,7 @@ import GHC.JS.Syntax
 
 import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )
 
-import GHC.Iface.Load   ( ifaceStats, writeIface )
+import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression )
 import GHC.Iface.Make
 import GHC.Iface.Recomp
 import GHC.Iface.Tidy
@@ -612,7 +612,7 @@ extract_renamed_stuff mod_summary tc_result = do
         -- enables the option which keeps the renamed source.
         hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
         let out_file = ml_hie_file $ ms_location mod_summary
-        liftIO $ writeHieFile out_file hieFile
+        liftIO $ writeHieFile (flagsToIfCompression dflags) out_file hieFile
         liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
 
         -- Validate HIE files
@@ -1207,7 +1207,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
           withTiming logger
               (text "WriteIface"<+>brackets (text iface_name))
               (const ())
-              (writeIface logger profile iface_name iface)
+              (writeIface logger profile (flagsToIfCompression dflags) iface_name iface)
 
     if (write_interface || force_write_interface) then do
 

compiler/GHC/Driver/Session.hs

@@ -1685,6 +1685,8 @@ dynamic_flags_deps = [
       (intSuffix (\n d -> d { dmdUnboxWidth = n }))
   , make_ord_flag defFlag "fspec-constr-threshold"
       (intSuffix (\n d -> d { specConstrThreshold = Just n }))
+  , make_ord_flag defFlag "fwrite-if-compression"
+      (intSuffix (\n d -> d { ifCompression = n }))
   , make_ord_flag defFlag "fno-spec-constr-threshold"
       (noArg (\d -> d { specConstrThreshold = Nothing }))
   , make_ord_flag defFlag "fspec-constr-count"

compiler/GHC/Iface/Binary.hs

@@ -14,6 +14,7 @@ module GHC.Iface.Binary (
         writeBinIface,
         readBinIface,
         readBinIfaceHeader,
+        CompressionIFace(..),
         getSymtabName,
         CheckHiWay(..),
         TraceBinIFace(..),
@@ -25,6 +26,8 @@ module GHC.Iface.Binary (
         putName,
         putSymbolTable,
         BinSymbolTable(..),
+        initWriteIfaceType, initReadIfaceTypeTable,
+        putAllTables,
     ) where
 
 import GHC.Prelude
@@ -46,14 +49,18 @@ import GHC.Types.SrcLoc
 import GHC.Platform
 import GHC.Settings.Constants
 import GHC.Utils.Fingerprint
+import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte)
 
+import Control.Monad
 import Data.Array
 import Data.Array.IO
 import Data.Array.Unsafe
 import Data.Char
-import Data.Word
 import Data.IORef
-import Control.Monad
+import Data.Map.Strict (Map)
+import Data.Word
+import System.IO.Unsafe
+
 
 -- ---------------------------------------------------------------------------
 -- Reading and writing binary interface files
@@ -66,6 +73,21 @@ data TraceBinIFace
    = TraceBinIFace (SDoc -> IO ())
    | QuietBinIFace
 
+data CompressionIFace
+  = NormalCompression
+  -- ^ Perform the normal compression operations,
+  -- such as deduplicating 'Name's and 'FastString's
+  | SafeExtraCompression
+  -- ^ Perform some extra compression steps that have minimal impact
+  -- on the run-time of 'ghc'.
+  --
+  -- This reduces the size of '.hi' files significantly in some cases
+  -- and reduces overall memory usage in certain scenarios.
+  | MaximalCompression
+  -- ^ Try to compress as much as possible.
+  --
+  -- Yields the smallest '.hi' files but at the cost of additional run-time.
+
 -- | Read an interface file header, checking the magic number, version, and
 -- way. Returns the hash of the source file and a BinHandle which points at the
 -- start of the rest of the interface file data.
@@ -158,9 +180,13 @@ getWithUserData name_cache bh = do
 -- Reading names has the side effect of adding them into the given NameCache.
 getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
 getTables name_cache bh = do
+    bhRef <- newIORef (error "used too soon")
+    -- It is important this is passed to 'getTable'
+    ud <- unsafeInterleaveIO (readIORef bhRef)
+
     fsReaderTable <- initFastStringReaderTable
     nameReaderTable <- initNameReaderTable name_cache
-
+    ifaceTypeReaderTable <- initReadIfaceTypeTable ud
 
     -- The order of these deserialisation matters!
     --
@@ -168,20 +194,27 @@ getTables name_cache bh = do
     fsTable <- Binary.forwardGet bh (getTable fsReaderTable bh)
     let
       fsReader = mkReaderFromTable fsReaderTable fsTable
-      bhFs = addReaderToUserData (mkSomeBinaryReader fsReader) bh
+      bhFs = addReaderToUserData fsReader bh
+
 
     nameTable <- Binary.forwardGet bh (getTable nameReaderTable bhFs)
     let
       nameReader = mkReaderFromTable nameReaderTable nameTable
-      bhName = addReaderToUserData (mkSomeBinaryReader nameReader) bhFs
+      bhName = addReaderToUserData nameReader bhFs
 
-    pure bhName
+    ifaceTypeTable <- Binary.forwardGet bh (getTable ifaceTypeReaderTable bhName)
+    let
+      ifaceTypeReader = mkReaderFromTable ifaceTypeReaderTable ifaceTypeTable
+      bhIfaceType = addReaderToUserData ifaceTypeReader bhName
+
+    writeIORef bhRef (getReaderUserData bhIfaceType)
+    pure bhIfaceType
 
 -- | Write an interface file.
 --
 -- See Note [Iface Binary Serialisation] for details.
-writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
-writeBinIface profile traceBinIface hi_path mod_iface = do
+writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO ()
+writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do
     bh <- openBinMem initBinMemSize
     let platform = profilePlatform profile
     put_ bh (binaryInterfaceMagic platform)
@@ -195,7 +228,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
     extFields_p_p <- tellBinWriter bh
     put_ bh extFields_p_p
 
-    putWithUserData traceBinIface bh mod_iface
+    putWithUserData traceBinIface compressionLevel bh mod_iface
 
     extFields_p <- tellBinWriter bh
     putAt bh extFields_p_p extFields_p
@@ -209,9 +242,9 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
 -- is necessary if you want to serialise Names or FastStrings.
 -- It also writes a symbol table and the dictionary.
 -- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
-putWithUserData traceBinIface bh payload = do
-  (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
+putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
+putWithUserData traceBinIface compressionLevel bh payload = do
+  (name_count, fs_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload)
 
   case traceBinIface of
     QuietBinIFace         -> return ()
@@ -234,15 +267,17 @@ putWithUserData traceBinIface bh payload = do
 -- It returns (number of names, number of FastStrings, payload write result)
 --
 -- See Note [Iface Binary Serialiser Order]
-putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
-putWithTables bh' put_payload = do
+putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
+putWithTables compressionLevel bh' put_payload = do
   (fast_wt, fsWriter) <- initFastStringWriterTable
   (name_wt, nameWriter) <- initNameWriterTable
+  (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel
 
   let writerUserData = mkWriterUserData
         [ mkSomeBinaryWriter @FastString fsWriter
         , mkSomeBinaryWriter @Name nameWriter
         , mkSomeBinaryWriter @BindingName  $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name))
+        , mkSomeBinaryWriter @IfaceType ifaceTypeWriter
         ]
   let bh = setWriterUserData bh' writerUserData
 
@@ -250,18 +285,24 @@ putWithTables bh' put_payload = do
     -- The order of these entries matters!
     --
     -- See Note [Iface Binary Serialiser Order] for details.
-    putAllTables bh [fast_wt, name_wt] $ do
+    putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do
       put_payload bh
 
   return (name_count, fs_count, r)
- where
-  putAllTables _ [] act = do
-    a <- act
-    pure ([], a)
-  putAllTables bh (x : xs) act = do
-    (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
-      putAllTables bh xs act
-    pure (r : res, a)
+
+-- | Write all deduplication tables to disk after serialising the
+-- main payload.
+--
+-- Writes forward pointers to the deduplication tables before writing the payload
+-- to allow deserialisation *before* the payload is read again.
+putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
+putAllTables _ [] act = do
+  a <- act
+  pure ([], a)
+putAllTables bh (x : xs) act = do
+  (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
+    putAllTables bh xs act
+  pure (r : res, a)
 
 -- | Initial ram buffer to allocate for writing interface files
 initBinMemSize :: Int
@@ -377,6 +418,42 @@ Here, a visualisation of the table structure we currently have:
 -- The symbol table
 --
 
+initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
+initReadIfaceTypeTable ud = do
+  pure $
+    ReaderTable
+      { getTable = getGenericSymbolTable (\bh -> getIfaceType (setReaderUserData bh ud))
+      , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
+      }
+
+initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)
+initWriteIfaceType compressionLevel = do
+  sym_tab <- initGenericSymbolTable @(Map IfaceType)
+  pure
+    ( WriterTable
+        { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
+        }
+    , mkWriter $ ifaceWriter sym_tab
+    )
+  where
+    ifaceWriter sym_tab = case compressionLevel of
+      NormalCompression -> literalIfaceTypeSerialiser
+      SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab
+      MaximalCompression -> fullIfaceTypeSerialiser sym_tab
+
+    ifaceTyConAppSerialiser sym_tab bh ty = case ty of
+      IfaceTyConApp {} -> do
+        put_ bh ifaceTypeSharedByte
+        putGenericSymTab sym_tab bh ty
+      _ -> putIfaceType bh ty
+
+
+    fullIfaceTypeSerialiser sym_tab bh ty = do
+      put_ bh ifaceTypeSharedByte
+      putGenericSymTab sym_tab bh ty
+
+    literalIfaceTypeSerialiser = putIfaceType
+
 
 initNameReaderTable :: NameCache -> IO (ReaderTable Name)
 initNameReaderTable cache = do

compiler/GHC/Iface/Decl.hs

@@ -45,7 +45,6 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Misc
 
-import GHC.Data.FastString
 import GHC.Data.Maybe
 import GHC.Data.BooleanFormula
 
@@ -147,7 +146,7 @@ tyConToIfaceDecl env tycon
   | Just fam_flav <- famTyConFlav_maybe tycon
   = ( tc_env1
     , IfaceFamily { ifName    = getName tycon,
-                    ifResVar  = if_res_var,
+                    ifResVar  = mkIfLclName <$> if_res_var,
                     ifFamFlav = to_if_fam_flav fam_flav,
                     ifBinders = if_binders,
                     ifResKind = if_res_kind,
@@ -288,7 +287,7 @@ classToIfaceDecl env clas
                 ifClassCtxt   = tidyToIfaceContext env1 sc_theta,
                 ifATs    = map toIfaceAT clas_ats,
                 ifSigs   = map toIfaceClassOp op_stuff,
-                ifMinDef = toIfaceBooleanFormula $ fmap getOccFS (classMinimalDef clas)
+                ifMinDef = toIfaceBooleanFormula $ fmap (mkIfLclName . getOccFS) (classMinimalDef clas)
             }
 
     (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -334,7 +333,7 @@ tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
 tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
 tidyTyConBinders = mapAccumL tidyTyConBinder
 
-tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar :: TidyEnv -> TyVar -> IfLclName
 tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
 
 toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula

compiler/GHC/Iface/Env.hs

@@ -34,7 +34,6 @@ import GHC.Runtime.Context
 import GHC.Unit.Module
 import GHC.Unit.Module.ModIface
 
-import GHC.Data.FastString
 import GHC.Data.FastString.Env
 
 import GHC.Types.Var
@@ -190,10 +189,10 @@ setNameModule (Just m) n =
 ************************************************************************
 -}
 
-tcIfaceLclId :: FastString -> IfL Id
+tcIfaceLclId :: IfLclName -> IfL Id
 tcIfaceLclId occ
   = do  { lcl <- getLclEnv
-        ; case lookupFsEnv (if_id_env lcl) occ of
+        ; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of
             Just ty_var -> return ty_var
             Nothing     -> failIfM $
               vcat
@@ -209,10 +208,10 @@ extendIfaceIdEnv ids
     in env { if_id_env = id_env' }
 
 
-tcIfaceTyVar :: FastString -> IfL TyVar
+tcIfaceTyVar :: IfLclName -> IfL TyVar
 tcIfaceTyVar occ
   = do  { lcl <- getLclEnv
-        ; case lookupFsEnv (if_tv_env lcl) occ of
+        ; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of
             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
         }
@@ -220,15 +219,15 @@ tcIfaceTyVar occ
 lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
 lookupIfaceTyVar (occ, _)
   = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+        ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
 
 lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
 lookupIfaceVar (IfaceIdBndr (_, occ, _))
   = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_id_env lcl) occ) }
+        ; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) }
 lookupIfaceVar (IfaceTvBndr (occ, _))
   = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+        ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
 
 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 extendIfaceTyVarEnv tyvars

compiler/GHC/Iface/Ext/Binary.hs

@@ -38,22 +38,21 @@ import Data.ByteString            ( ByteString )
 import qualified Data.ByteString  as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.Word                  ( Word8, Word32 )
-import Control.Monad              ( replicateM, when, forM_ )
+import Control.Monad              ( replicateM, when, forM_, foldM )
 import System.Directory           ( createDirectoryIfMissing )
 import System.FilePath            ( takeDirectory )
 
 import GHC.Iface.Ext.Types
+import GHC.Iface.Binary (initWriteIfaceType, putAllTables, initReadIfaceTypeTable, CompressionIFace)
+import GHC.Iface.Type (IfaceType)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import qualified GHC.Utils.Binary as Binary
 
 data HieSymbolTable = HieSymbolTable
   { hie_symtab_next :: !FastMutInt
   , hie_symtab_map  :: !(IORef (UniqFM Name (Int, HieName)))
   }
 
-data HieDictionary = HieDictionary
-  { hie_dict_next :: !FastMutInt -- The next index to use
-  , hie_dict_map  :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
-  }
-
 initBinMemSize :: Int
 initBinMemSize = 1024*1024
 
@@ -74,8 +73,8 @@ putBinLine bh xs = do
 
 -- | Write a `HieFile` to the given `FilePath`, with a proper header and
 -- symbol tables for `Name`s and `FastString`s
-writeHieFile :: FilePath -> HieFile -> IO ()
-writeHieFile hie_file_path hiefile = do
+writeHieFile :: CompressionIFace -> FilePath -> HieFile -> IO ()
+writeHieFile compression hie_file_path hiefile = do
   bh0 <- openBinMem initBinMemSize
 
   -- Write the header: hieHeader followed by the
@@ -84,58 +83,58 @@ writeHieFile hie_file_path hiefile = do
   putBinLine bh0 $ BSC.pack $ show hieVersion
   putBinLine bh0 $ ghcVersion
 
-  -- remember where the dictionary pointer will go
-  dict_p_p <- tellBinWriter bh0
-  put_ bh0 dict_p_p
+  (fs_tbl, fs_w) <- initFastStringWriterTable
+  (name_tbl, name_w) <- initWriteNameTable
+  (iface_tbl, iface_w) <- initWriteIfaceType compression
 
-  -- remember where the symbol table pointer will go
-  symtab_p_p <- tellBinWriter bh0
-  put_ bh0 symtab_p_p
+  let bh = setWriterUserData bh0 $ mkWriterUserData
+        [ mkSomeBinaryWriter @IfaceType iface_w
+        , mkSomeBinaryWriter @Name name_w
+        , mkSomeBinaryWriter @BindingName (simpleBindingNameWriter name_w)
+        , mkSomeBinaryWriter @FastString fs_w
+        ]
 
-  -- Make some initial state
-  symtab_next <- newFastMutInt 0
-  symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
-  let hie_symtab = HieSymbolTable {
-                      hie_symtab_next = symtab_next,
-                      hie_symtab_map  = symtab_map }
-  dict_next_ref <- newFastMutInt 0
-  dict_map_ref <- newIORef emptyUFM
-  let hie_dict = HieDictionary {
-                      hie_dict_next = dict_next_ref,
-                      hie_dict_map  = dict_map_ref }
-
-  -- put the main thing
-  let bh = setWriterUserData bh0
-          $ newWriteState (putName hie_symtab)
-                          (putName hie_symtab)
-                          (putFastString hie_dict)
-  put_ bh hiefile
-
-  -- write the symtab pointer at the front of the file
-  symtab_p <- tellBinWriter bh
-  putAt bh symtab_p_p symtab_p
-  seekBinWriter bh symtab_p
-
-  -- write the symbol table itself
-  symtab_next' <- readFastMutInt symtab_next
-  symtab_map'  <- readIORef symtab_map
-  putSymbolTable bh symtab_next' symtab_map'
-
-  -- write the dictionary pointer at the front of the file
-  dict_p <- tellBinWriter bh
-  putAt bh dict_p_p dict_p
-  seekBinWriter bh dict_p
-
-  -- write the dictionary itself
-  dict_next <- readFastMutInt dict_next_ref
-  dict_map  <- readIORef dict_map_ref
-  putDictionary bh dict_next dict_map
+  -- Discard number of written elements
+  -- Order matters! See Note [Iface Binary Serialiser Order]
+  _ <- putAllTables bh [fs_tbl, name_tbl, iface_tbl] $ do
+    put_ bh hiefile
 
   -- and send the result to the file
   createDirectoryIfMissing True (takeDirectory hie_file_path)
   writeBinMem bh hie_file_path
   return ()
 
+initWriteNameTable :: IO (WriterTable, BinaryWriter Name)
+initWriteNameTable = do
+  symtab_next <- newFastMutInt 0
+  symtab_map <- newIORef emptyUFM
+  let bin_symtab =
+        HieSymbolTable
+          { hie_symtab_next = symtab_next
+          , hie_symtab_map = symtab_map
+          }
+
+  let put_symtab bh = do
+        name_count <- readFastMutInt symtab_next
+        symtab_map <- readIORef symtab_map
+        putSymbolTable bh name_count symtab_map
+        pure name_count
+
+  return
+    ( WriterTable
+        { putTable = put_symtab
+        }
+    , mkWriter $ putName bin_symtab
+    )
+
+initReadNameTable :: NameCache -> IO (ReaderTable Name)
+initReadNameTable cache = do
+  return $
+    ReaderTable
+      { getTable = \bh -> getSymbolTable bh cache
+      , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl)
+      }
+
 data HieFileResult
   = HieFileResult
   { hie_file_result_version :: Integer
@@ -216,50 +215,32 @@ readHieFileHeader file bh0 = do
 
 readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile
 readHieFileContents bh0 name_cache = do
-  dict <- get_dictionary bh0
+  bhRef <- newIORef (error "used too soon")
+  -- It is important this is passed to 'getTable'
+  ud <- unsafeInterleaveIO (readIORef bhRef)
+
+  fsReaderTable <- initFastStringReaderTable
+  nameReaderTable <- initReadNameTable name_cache
+  ifaceTypeReaderTable <- initReadIfaceTypeTable ud
+
   -- read the symbol table so we are capable of reading the actual data
-  bh1 <- do
-      let bh1 = setReaderUserData bh0
-              $ newReadState (error "getSymtabName")
-                             (getDictFastString dict)
-      symtab <- get_symbol_table bh1
-      let bh1' = setReaderUserData bh1
-               $ newReadState (getSymTabName symtab)
-                              (getDictFastString dict)
-      return bh1'
+  bh1 <-
+    foldM (\bh tblReader -> tblReader bh) bh0
+      [ get_dictionary fsReaderTable
+      , get_dictionary nameReaderTable
+      , get_dictionary ifaceTypeReaderTable
+      ]
 
   -- load the actual data
   get bh1
   where
-    get_dictionary bin_handle = do
-      dict_p <- get bin_handle
-      data_p <- tellBinReader bin_handle
-      seekBinReader bin_handle dict_p
-      dict <- getDictionary bin_handle
-      seekBinReader bin_handle data_p
-      return dict
-
-    get_symbol_table bh1 = do
-      symtab_p <- get bh1
-      data_p'  <- tellBinReader bh1
-      seekBinReader bh1 symtab_p
-      symtab <- getSymbolTable bh1 name_cache
-      seekBinReader bh1 data_p'
-      return symtab
-
-putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
-putFastString HieDictionary { hie_dict_next = j_r,
-                              hie_dict_map  = out_r}  bh f
-  = do
-    out <- readIORef out_r
-    let !unique = getUnique f
-    case lookupUFM_Directly out unique of
-        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
-        Nothing -> do
-           j <- readFastMutInt j_r
-           put_ bh (fromIntegral j :: Word32)
-           writeFastMutInt j_r (j + 1)
-           writeIORef out_r $! addToUFM_Directly out unique (j, f)
+    get_dictionary tbl bin_handle = do
+      fsTable <- Binary.forwardGet bin_handle (getTable tbl bin_handle)
+      let
+        fsReader = mkReaderFromTable tbl fsTable
+        bhFs = addReaderToUserData fsReader bin_handle
+      pure bhFs
+
 
 putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
 putSymbolTable bh next_off symtab = do

compiler/GHC/Iface/Ext/Utils.hs

@@ -162,15 +162,15 @@ getEvidenceTree refmap var = go emptyNameSet var
 hieTypeToIface :: HieTypeFix -> IfaceType
 hieTypeToIface = foldType go
   where
-    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
+    go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))
     go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
     go (HLitTy l) = IfaceLitTy l
-    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
+    go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)
                                   in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
     go (HFunTy w a b)   = IfaceFunTy visArgTypeLike   w       a    b
     go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b
     go (HCastTy a) = a
-    go HCoercionTy = IfaceTyVar "<coercion type>"
+    go HCoercionTy = IfaceTyVar (mkIfLclName "<coercion type>")
     go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
 
     -- This isn't fully faithful - we can't produce the 'Inferred' case

compiler/GHC/Iface/Load.hs

@@ -26,6 +26,7 @@ module GHC.Iface.Load (
         loadInterface,
         loadSysInterface, loadUserInterface, loadPluginInterface,
         findAndReadIface, readIface, writeIface,
+        flagsToIfCompression,
         moduleFreeHolesPrecise,
         needWiredInHomeIface, loadWiredInHomeIface,
 
@@ -965,11 +966,18 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do
 
 
 -- | Write interface file
-writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()
-writeIface logger profile hi_file_path new_iface
+writeIface :: Logger -> Profile -> CompressionIFace -> FilePath -> ModIface -> IO ()
+writeIface logger profile compression_level hi_file_path new_iface
     = do createDirectoryIfMissing True (takeDirectory hi_file_path)
          let printer = TraceBinIFace (debugTraceMsg logger 3)
-         writeBinIface profile printer hi_file_path new_iface
+         writeBinIface profile printer compression_level hi_file_path new_iface
+
+flagsToIfCompression :: DynFlags -> CompressionIFace
+flagsToIfCompression dflags = case ifCompression dflags of
+  0 -> NormalCompression
+  1 -> NormalCompression
+  2 -> SafeExtraCompression
+  _ -> MaximalCompression
 
 -- | @readIface@ tries just the one file.
 --

compiler/GHC/Iface/Recomp.hs

@@ -1216,8 +1216,8 @@ addFingerprints hsc_env iface0
        getOcc (IfLclTopBndr fs _ _ details) =
         case details of
           IfRecSelId { ifRecSelFirstCon = first_con }
-            -> mkRecFieldOccFS (getOccFS first_con) fs
-          _ -> mkVarOccFS fs
+            -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs)
+          _ -> mkVarOccFS (ifLclNameFS fs)
 
        binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
        binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)

compiler/GHC/Iface/Recomp/Binary.hs

@@ -14,6 +14,7 @@ import GHC.Utils.Fingerprint
 import GHC.Utils.Binary
 import GHC.Types.Name
 import GHC.Utils.Panic.Plain
+import GHC.Iface.Type (putIfaceType)
 
 fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
 fingerprintBinMem bh = withBinBuffer bh f
@@ -34,8 +35,12 @@ computeFingerprint put_nonbinding_name a = do
     put_ bh a
     fingerprintBinMem bh
   where
-    set_user_data bh =
-      setWriterUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+    set_user_data bh = setWriterUserData bh $ mkWriterUserData
+      [ mkSomeBinaryWriter $ mkWriter putIfaceType
+      , mkSomeBinaryWriter $ mkWriter put_nonbinding_name
+      , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally
+      , mkSomeBinaryWriter $ mkWriter putFS
+      ]
 
 -- | Used when we want to fingerprint a structure without depending on the
 -- fingerprints of external Names that it refers to.

compiler/GHC/Iface/Syntax.hs

@@ -632,6 +632,7 @@ data IfaceExpr
   | IfaceFCall  ForeignCall IfaceType
   | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E
 
+
 data IfaceTickish
   = IfaceHpcTick    Module Int               -- from HpcTick x
   | IfaceSCC        CostCentre Bool Bool     -- from ProfNote
@@ -1026,7 +1027,7 @@ pprIfaceDecl ss (IfaceClass { ifName  = clas
       pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
         text "{-# MINIMAL" <+>
         pprBooleanFormula
-          (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
+          (\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>
         text "#-}"
 
       -- See Note [Suppressing binder signatures] in GHC.Iface.Type

compiler/GHC/Iface/Type.hs

@@ -10,7 +10,8 @@ This module defines interface types and binders
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE LambdaCase #-}
 module GHC.Iface.Type (
-        IfExtName, IfLclName,
+        IfExtName,
+        IfLclName(..), mkIfLclName, ifLclNameFS,
 
         IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
         IfaceMCoercion(..),
@@ -32,6 +33,8 @@ module GHC.Iface.Type (
         ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
         ifTyConBinderVar, ifTyConBinderName,
 
+        -- Binary utilities
+        putIfaceType, getIfaceType, ifaceTypeSharedByte,
         -- Equality testing
         isIfaceLiftedTypeKind,
 
@@ -89,10 +92,13 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
 
+import Data.Maybe (isJust)
+import Data.Proxy
+import qualified Data.Semigroup as Semi
+import Data.Word (Word8)
+import Control.Arrow (first)
 import Control.DeepSeq
 import Control.Monad ((<$!>))
-import qualified Data.Semigroup as Semi
-import Data.Maybe( isJust )
 
 {-
 ************************************************************************
@@ -102,7 +108,20 @@ import Data.Maybe( isJust )
 ************************************************************************
 -}
 
-type IfLclName = FastString     -- A local name in iface syntax
+-- | A local name in iface syntax
+newtype IfLclName = IfLclName
+  { getIfLclName :: LexicalFastString
+  } deriving (Eq, Ord, Show)
+
+instance Uniquable IfLclName where
+  getUnique = getUnique . ifLclNameFS
+
+
+ifLclNameFS :: IfLclName -> FastString
+ifLclNameFS = getLexicalFastString . getIfLclName
+
+mkIfLclName :: FastString -> IfLclName
+mkIfLclName = IfLclName . LexicalFastString
 
 type IfExtName = Name   -- An External or WiredIn Name can appear in Iface syntax
                         -- (However Internal or System Names never should)
@@ -110,6 +129,8 @@ type IfExtName = Name   -- An External or WiredIn Name can appear in Iface synta
 data IfaceBndr          -- Local (non-top-level) binders
   = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
   | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
+  deriving (Eq, Ord)
+
 
 type IfaceIdBndr  = (IfaceType, IfLclName, IfaceType)
 type IfaceTvBndr  = (IfLclName, IfaceKind)
@@ -178,6 +199,7 @@ data IfaceType
           -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression
           -- in interface file size (in GHC's boot libraries).
           -- See !3987.
+  deriving (Eq, Ord)
 
 type IfaceMult = IfaceType
 
@@ -186,9 +208,9 @@ type IfaceContext = [IfacePredType]
 
 data IfaceTyLit
   = IfaceNumTyLit Integer
-  | IfaceStrTyLit FastString
+  | IfaceStrTyLit LexicalFastString
   | IfaceCharTyLit Char
-  deriving (Eq)
+  deriving (Eq, Ord)
 
 type IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis
 type IfaceForAllBndr     = VarBndr IfaceBndr ForAllTyFlag
@@ -230,6 +252,7 @@ data IfaceAppArgs
                         --    arguments in @{...}.
 
            IfaceAppArgs -- The rest of the arguments
+  deriving (Eq, Ord)
 
 instance Semi.Semigroup IfaceAppArgs where
   IA_Nil <> xs              = xs
@@ -256,7 +279,7 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
                              -- See Note [Sharing IfaceTyConInfo] for why
                              -- sharing is so important for 'IfaceTyConInfo'.
                              }
-    deriving (Eq)
+    deriving (Eq, Ord)
 
 -- | The various types of TyCons which have special, built-in syntax.
 data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
@@ -276,7 +299,7 @@ data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
                       -- that is actually being applied to two types
                       -- of the same kind.  This affects pretty-printing
                       -- only: see Note [Equality predicates in IfaceType]
-                    deriving (Eq)
+                    deriving (Eq, Ord)
 
 instance Outputable IfaceTyConSort where
   ppr IfaceNormalTyCon         = text "normal"
@@ -370,7 +393,7 @@ data IfaceTyConInfo   -- Used only to guide pretty-printing
                       -- should be printed as 'D to distinguish it from
                       -- an existing type constructor D.
                    , ifaceTyConSort       :: IfaceTyConSort }
-    deriving (Eq)
+    deriving (Eq, Ord)
 
 -- | This smart constructor allows sharing of the two most common
 -- cases. See Note [Sharing IfaceTyConInfo]
@@ -420,7 +443,7 @@ This one change leads to an 15% reduction in residency for GHC when embedding
 
 data IfaceMCoercion
   = IfaceMRefl
-  | IfaceMCo IfaceCoercion
+  | IfaceMCo IfaceCoercion deriving (Eq, Ord)
 
 data IfaceCoercion
   = IfaceReflCo       IfaceType
@@ -445,11 +468,13 @@ data IfaceCoercion
   | IfaceSubCo        IfaceCoercion
   | IfaceFreeCoVar    CoVar    -- See Note [Free tyvars in IfaceType]
   | IfaceHoleCo       CoVar    -- ^ See Note [Holes in IfaceCoercion]
+  deriving (Eq, Ord)
 
 data IfaceUnivCoProv
   = IfacePhantomProv IfaceCoercion
   | IfaceProofIrrelProv IfaceCoercion
   | IfacePluginProv String
+  deriving (Eq, Ord)
 
 {- Note [Holes in IfaceCoercion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -621,11 +646,11 @@ type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType]
 
 mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
 -- See Note [Substitution on IfaceType]
-mkIfaceTySubst eq_spec = mkFsEnv eq_spec
+mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec)
 
 inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
 -- See Note [Substitution on IfaceType]
-inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
+inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs))
 
 substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
 -- See Note [Substitution on IfaceType]
@@ -681,7 +706,7 @@ substIfaceAppArgs env args
 
 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
 substIfaceTyVar env tv
-  | Just ty <- lookupFsEnv env tv = ty
+  | Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty
   | otherwise                     = IfaceTyVar tv
 
 
@@ -1190,7 +1215,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
      | isInvisibleForAllTyFlag argf  -- Don't default *visible* quantification
                                      -- or we get the mess in #13963
      , Just substituted_ty <- check_substitution var_kind
-      = let subs' = extendFsEnv subs var substituted_ty
+      = let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty
             -- Record that we should replace it with LiftedRep/Lifted/Many,
             -- and recurse, discarding the forall
         in go subs' True ty
@@ -1198,7 +1223,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
     go subs rank1 (IfaceForAllTy bndr ty)
       = IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty)
 
-    go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of
+    go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of
       Just s -> s
       Nothing -> ty
 
@@ -1626,7 +1651,7 @@ pprTyTcApp ctxt_prec tc tys =
        , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
                 Required (IA_Arg ty Required IA_Nil) <- tys
        -> maybeParen ctxt_prec funPrec
-         $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
+         $ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty
 
        | IfaceTupleTyCon arity sort <- ifaceTyConSort info
        , not debug
@@ -2014,6 +2039,9 @@ pprIfaceUnivCoProv (IfacePluginProv s)
   = text "plugin" <+> doubleQuotes (text s)
 
 -------------------
+instance Outputable IfLclName where
+  ppr = ppr . ifLclNameFS
+
 instance Outputable IfaceTyCon where
   ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
 
@@ -2171,38 +2199,69 @@ ppr_parend_preds :: [IfacePredType] -> SDoc
 ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
 
 instance Binary IfaceType where
-    put_ _ (IfaceFreeTyVar tv)
-       = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
+   put_ bh ty =
+    case findUserDataWriter Proxy bh of
+      tbl -> putEntry tbl bh ty
 
-    put_ bh (IfaceForAllTy aa ab) = do
-            putByte bh 0
-            put_ bh aa
-            put_ bh ab
-    put_ bh (IfaceTyVar ad) = do
-            putByte bh 1
-            put_ bh ad
-    put_ bh (IfaceAppTy ae af) = do
-            putByte bh 2
-            put_ bh ae
-            put_ bh af
-    put_ bh (IfaceFunTy af aw ag ah) = do
-            putByte bh 3
-            put_ bh af
-            put_ bh aw
-            put_ bh ag
-            put_ bh ah
-    put_ bh (IfaceTyConApp tc tys)
-      = do { putByte bh 5; put_ bh tc; put_ bh tys }
-    put_ bh (IfaceCastTy a b)
-      = do { putByte bh 6; put_ bh a; put_ bh b }
-    put_ bh (IfaceCoercionTy a)
-      = do { putByte bh 7; put_ bh a }
-    put_ bh (IfaceTupleTy s i tys)
-      = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
-    put_ bh (IfaceLitTy n)
-      = do { putByte bh 9; put_ bh n }
+   get bh = getIfaceTypeShared bh
 
-    get bh = do
+-- | This is the byte tag we expect to read when the next
+-- value is not an 'IfaceType' value, but an offset into a
+-- lookup value.
+--
+-- Must not overlap with any byte tag in 'getIfaceType'.
+ifaceTypeSharedByte :: Word8
+ifaceTypeSharedByte = 99
+
+-- | Like 'getIfaceType' but checks for a specific byte tag
+-- that indicates that we won't be able to read a 'IfaceType' value
+-- but rather an offset into a lookup table. Consequentially,
+-- we look up the value for the 'IfaceType' in the look up table.
+--
+-- See Note [Iface Binary Serialisation] for details.
+getIfaceTypeShared :: ReadBinHandle -> IO IfaceType
+getIfaceTypeShared bh = do
+  start <- tellBinReader bh
+  tag <- getByte bh
+  if ifaceTypeSharedByte == tag
+    then case findUserDataReader Proxy bh of
+            tbl -> getEntry tbl bh
+    else seekBinReader bh start >> getIfaceType bh
+
+putIfaceType :: WriteBinHandle -> IfaceType -> IO ()
+putIfaceType _ (IfaceFreeTyVar tv)
+   = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
+
+putIfaceType bh (IfaceForAllTy aa ab) = do
+        putByte bh 0
+        put_ bh aa
+        put_ bh ab
+putIfaceType bh (IfaceTyVar ad) = do
+        putByte bh 1
+        put_ bh ad
+putIfaceType bh (IfaceAppTy ae af) = do
+        putByte bh 2
+        put_ bh ae
+        put_ bh af
+putIfaceType bh (IfaceFunTy af aw ag ah) = do
+        putByte bh 3
+        put_ bh af
+        put_ bh aw
+        put_ bh ag
+        put_ bh ah
+putIfaceType bh (IfaceTyConApp tc tys)
+  = do { putByte bh 5; put_ bh tc; put_ bh tys }
+putIfaceType bh (IfaceCastTy a b)
+  = do { putByte bh 6; put_ bh a; put_ bh b }
+putIfaceType bh (IfaceCoercionTy a)
+  = do { putByte bh 7; put_ bh a }
+putIfaceType bh (IfaceTupleTy s i tys)
+  = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
+putIfaceType bh (IfaceLitTy n)
+  = do { putByte bh 9; put_ bh n }
+
+getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType
+getIfaceType bh = do
             h <- getByte bh
             case h of
               0 -> do aa <- get bh
@@ -2230,6 +2289,13 @@ instance Binary IfaceType where
               _  -> do n <- get bh
                        return (IfaceLitTy n)
 
+instance Binary IfLclName where
+  put_ bh = put_ bh . ifLclNameFS
+
+  get bh = do
+    fs <- get bh
+    pure $ IfLclName $ LexicalFastString fs
+
 instance Binary IfaceMCoercion where
   put_ bh IfaceMRefl =
           putByte bh 1
@@ -2475,6 +2541,9 @@ instance NFData IfaceTyConSort where
     IfaceSumTyCon arity -> rnf arity
     IfaceEqualityTyCon -> ()
 
+instance NFData IfLclName where
+  rnf (IfLclName lfs) = rnf lfs
+
 instance NFData IfaceTyConInfo where
   rnf (IfaceTyConInfo f s) = f `seq` rnf s
 

compiler/GHC/Iface/Type/Map.hs

+{-# LANGUAGE TypeFamilies #-}
+module GHC.Iface.Type.Map where
+
+import GHC.Prelude
+import GHC.Data.TrieMap
+import GHC.Iface.Type
+import qualified Data.Map as Map
+import Data.Functor.Compose
+import GHC.Types.Basic
+import Control.Monad ((>=>))
+import GHC.Types.Unique.DFM
+import Data.Functor.Product
+import GHC.Types.Var (VarBndr(..))
+
+
+newtype IfaceTypeMap a = IfaceTypeMap (IfaceTypeMapG a)
+
+instance Functor IfaceTypeMap where
+  fmap f (IfaceTypeMap m) = IfaceTypeMap (fmap f m)
+
+instance TrieMap IfaceTypeMap where
+  type Key IfaceTypeMap = IfaceType
+
+  emptyTM = IfaceTypeMap emptyTM
+
+  lookupTM k (IfaceTypeMap m) = lookupTM k m
+
+  alterTM k f (IfaceTypeMap m) = IfaceTypeMap (alterTM k f m)
+
+  filterTM f (IfaceTypeMap m) = IfaceTypeMap (filterTM f m)
+
+  foldTM f (IfaceTypeMap m) = foldTM f m
+
+type IfaceTypeMapG = GenMap IfaceTypeMapX
+
+data IfaceTypeMapX a
+  = IFM { ifm_lit :: IfaceLiteralMap a
+        , ifm_var :: UniqDFM IfLclName a
+        , ifm_app :: IfaceTypeMapG (IfaceAppArgsMap a)
+        , ifm_fun_ty :: FunTyFlagMap (IfaceTypeMapG (IfaceTypeMapG (IfaceTypeMapG a)))
+        , ifm_ty_con_app :: IfaceTyConMap (IfaceAppArgsMap a)
+        , ifm_forall_ty :: IfaceForAllBndrMap (IfaceTypeMapG a)
+        , ifm_cast_ty :: IfaceTypeMapG (IfaceCoercionMap a)
+        , ifm_coercion_ty :: IfaceCoercionMap a
+        , ifm_tuple_ty :: TupleSortMap (PromotionFlagMap (IfaceAppArgsMap a))  }
+
+type IfaceLiteralMap = Map.Map IfaceTyLit
+type FunTyFlagMap = Map.Map FunTyFlag
+type IfaceTyConMap = Map.Map IfaceTyCon
+type ForAllTyFlagMap = Map.Map ForAllTyFlag
+type IfaceCoercionMap = Map.Map IfaceCoercion
+type TupleSortMap = Map.Map TupleSort
+type PromotionFlagMap = Map.Map PromotionFlag
+type IfaceForAllBndrMap = Compose IfaceBndrMap ForAllTyFlagMap
+
+type IfaceIdBndrMap = Compose IfaceTypeMapG (Compose (UniqDFM IfLclName) IfaceTypeMapG)
+type IfaceTvBndrMap = Compose (UniqDFM IfLclName) IfaceTypeMapG
+
+type IfaceBndrMap = Product IfaceIdBndrMap IfaceTvBndrMap
+
+
+
+
+type IfaceAppArgsMap a = ListMap (Compose IfaceTypeMapG ForAllTyFlagMap) a
+
+emptyE :: IfaceTypeMapX a
+emptyE = IFM { ifm_lit = emptyTM
+             , ifm_var = emptyTM
+             , ifm_app = emptyTM
+             , ifm_fun_ty = emptyTM
+             , ifm_ty_con_app = emptyTM
+             , ifm_forall_ty = emptyTM
+             , ifm_cast_ty = emptyTM
+             , ifm_coercion_ty = emptyTM
+             , ifm_tuple_ty = emptyTM }
+
+instance Functor IfaceTypeMapX where
+  fmap f  IFM { ifm_lit = ilit
+          , ifm_var = ivar
+          , ifm_app = iapp
+          , ifm_fun_ty = ift
+          , ifm_ty_con_app = itc
+          , ifm_forall_ty = ifal
+          , ifm_cast_ty = icast
+          , ifm_coercion_ty = ico
+          , ifm_tuple_ty = itup }
+
+    = IFM { ifm_lit = fmap f ilit
+          , ifm_var = fmap f ivar
+          , ifm_app = fmap (fmap f) iapp
+          , ifm_fun_ty = fmap (fmap (fmap (fmap f))) ift
+          , ifm_ty_con_app = fmap (fmap f) itc
+          , ifm_forall_ty = fmap (fmap f) ifal
+          , ifm_cast_ty = fmap (fmap f) icast
+          , ifm_coercion_ty = fmap f ico
+          , ifm_tuple_ty = fmap (fmap (fmap f)) itup }
+
+instance TrieMap IfaceTypeMapX where
+  type Key IfaceTypeMapX = IfaceType
+
+  emptyTM = emptyE
+  lookupTM = lkE
+  alterTM = xtE
+  foldTM = fdE
+  filterTM = ftE
+  {-# INLINE lookupTM #-}
+  {-# INLINE alterTM #-}
+
+{-# INLINE ftE #-}
+ftE :: (a -> Bool) -> IfaceTypeMapX a -> IfaceTypeMapX a
+ftE f  IFM { ifm_lit = ilit
+          , ifm_var = ivar
+          , ifm_app = iapp
+          , ifm_fun_ty = ift
+          , ifm_ty_con_app = itc
+          , ifm_forall_ty = ifal
+          , ifm_cast_ty = icast
+          , ifm_coercion_ty = ico
+          , ifm_tuple_ty = itup }
+
+    = IFM { ifm_lit = filterTM f ilit
+          , ifm_var = filterTM f ivar
+          , ifm_app = fmap (filterTM f) iapp
+          , ifm_fun_ty = fmap (fmap (fmap (filterTM f))) ift
+          , ifm_ty_con_app = fmap (filterTM f) itc
+          , ifm_forall_ty = fmap (filterTM f) ifal
+          , ifm_cast_ty = fmap (filterTM f) icast
+          , ifm_coercion_ty = filterTM f ico
+          , ifm_tuple_ty = fmap (fmap (filterTM f)) itup }
+
+{-# INLINE fdE #-}
+fdE :: (a -> b -> b) -> IfaceTypeMapX a -> b -> b
+fdE f  IFM { ifm_lit = ilit
+          , ifm_var = ivar
+          , ifm_app = iapp
+          , ifm_fun_ty = ift
+          , ifm_ty_con_app = itc
+          , ifm_forall_ty = ifal
+          , ifm_cast_ty = icast
+          , ifm_coercion_ty = ico
+          , ifm_tuple_ty = itup }
+  = foldTM f ilit . foldTM f ivar . foldTM (foldTM f) iapp
+  . foldTM (foldTM (foldTM (foldTM f))) ift
+  . foldTM (foldTM f) itc
+  . foldTM (foldTM f) ifal
+  . foldTM (foldTM f) icast
+  . foldTM f ico
+  . foldTM (foldTM (foldTM f)) itup
+
+bndrToKey :: IfaceBndr -> Either (IfaceType, (IfLclName, IfaceType)) IfaceTvBndr
+bndrToKey (IfaceIdBndr (a,b,c)) = Left (a, (b,c))
+bndrToKey (IfaceTvBndr k) = Right k
+
+{-# INLINE lkE #-}
+lkE :: IfaceType -> IfaceTypeMapX a -> Maybe a
+lkE it ifm = go it ifm
+  where
+    go (IfaceFreeTyVar {}) = error "ftv"
+    go (IfaceTyVar var) = ifm_var >.> lookupTM var
+    go (IfaceLitTy l) = ifm_lit >.> lookupTM l
+    go (IfaceAppTy ift args) = ifm_app >.> lkG ift >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+    go (IfaceFunTy ft t1 t2 t3) = ifm_fun_ty >.> lookupTM ft >=> lkG t1 >=> lkG t2 >=> lkG t3
+    go (IfaceForAllTy (Bndr a b) t) = ifm_forall_ty >.> lookupTM (bndrToKey a,b) >=> lkG t
+    go (IfaceTyConApp tc args) = ifm_ty_con_app >.> lookupTM tc >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+    go (IfaceCastTy ty co) = ifm_cast_ty >.> lkG ty >=> lookupTM co
+    go (IfaceCoercionTy co) = ifm_coercion_ty >.> lookupTM co
+    go (IfaceTupleTy sort prom args) = ifm_tuple_ty >.> lookupTM sort >=> lookupTM prom >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+
+{-# INLINE xtE #-}
+xtE :: IfaceType -> XT a -> IfaceTypeMapX a -> IfaceTypeMapX a
+xtE (IfaceFreeTyVar {}) _ _ = error "ftv"
+xtE (IfaceTyVar var) f m = m { ifm_var = ifm_var m |> alterTM var f }
+xtE (IfaceLitTy l) f m = m { ifm_lit = ifm_lit m |> alterTM l f }
+xtE (IfaceAppTy ift args) f m = m { ifm_app = ifm_app m |> xtG ift |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
+xtE (IfaceFunTy ft t1 t2 t3) f m = m { ifm_fun_ty = ifm_fun_ty m |> alterTM ft |>> xtG t1 |>> xtG t2 |>> xtG t3 f }
+xtE (IfaceForAllTy (Bndr a b) t) f m = m { ifm_forall_ty = ifm_forall_ty m |> alterTM (bndrToKey a,b) |>> xtG t f }
+xtE (IfaceTyConApp tc args) f m = m { ifm_ty_con_app = ifm_ty_con_app m |> alterTM tc |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
+xtE (IfaceCastTy ty co) f m = m { ifm_cast_ty = ifm_cast_ty m |> xtG ty |>> alterTM co f }
+xtE (IfaceCoercionTy co) f m = m { ifm_coercion_ty = ifm_coercion_ty m |> alterTM co f }
+xtE (IfaceTupleTy sort prom args) f m = m { ifm_tuple_ty = ifm_tuple_ty m |> alterTM sort |>> alterTM prom |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }

compiler/GHC/IfaceToCore.hs

@@ -733,7 +733,7 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
      { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $
                    tc_fam_flav tc_name fam_flav
-     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res
      ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
      ; return (ATyCon tycon) }
    where
@@ -782,7 +782,7 @@ tc_iface_decl _parent ignore_prags
     ; fds  <- mapM tc_fd rdr_fds
     ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
     ; let mindef_occ = fromIfaceBooleanFormula if_mindef
-    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ
     ; cls  <- fixM $ \ cls -> do
               { ats  <- mapM (tc_at cls) rdr_ats
               ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
@@ -936,8 +936,8 @@ mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
        ; let occ = case details' of
                  RecSelId { sel_tycon = parent }
                    -> let con_fs = getOccFS $ recSelFirstConName parent
-                      in mkRecFieldOccFS con_fs raw_name
-                 _ -> mkVarOccFS raw_name
+                      in mkRecFieldOccFS con_fs (ifLclNameFS raw_name)
+                 _ -> mkVarOccFS (ifLclNameFS raw_name)
        ; name <- newIfaceName occ }
    info' <- tcIdInfo False TopLevel name ty info
    let new_id = mkGlobalId details' name ty info'
@@ -1441,7 +1441,7 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
 -----------------------------------------
 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
-tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit (getLexicalFastString n))
 tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
 
 {-
@@ -1485,7 +1485,7 @@ tcIfaceCo = go
     go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
     go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
 
-    go_var :: FastString -> IfL CoVar
+    go_var :: IfLclName -> IfL CoVar
     go_var = tcIfaceLclId
 
 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
@@ -1561,7 +1561,7 @@ tcIfaceExpr (IfaceECase scrut ty)
 
 tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
-    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
+    case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr))
     let
         scrut_ty   = exprType scrut'
         case_mult  = ManyTy
@@ -1580,7 +1580,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
      return (Case scrut' case_bndr' (coreAltsType alts') alts')
 
 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
-  = do  { name    <- newIfaceName (mkVarOccFS fs)
+  = do  { name    <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
         ; ty'     <- tcIfaceType ty
         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                               NotTopLevel name ty' info
@@ -1598,7 +1598,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
        ; return (Let (Rec pairs') body') } }
  where
    tc_rec_bndr (IfLetBndr fs ty _ ji)
-     = do { name <- newIfaceName (mkVarOccFS fs)
+     = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
           ; ty'  <- tcIfaceType ty
           ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
    tc_pair (IfLetBndr _ _ info _, rhs) id
@@ -1655,12 +1655,12 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st
                (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
         ; tcIfaceDataAlt mult con inst_tys arg_strs rhs }
 
-tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr
+tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr
                -> IfL CoreAlt
 tcIfaceDataAlt mult con inst_tys arg_strs rhs
   = do  { uniqs <- getUniquesM
         ; let (ex_tvs, arg_ids)
-                      = dataConRepFSInstPat arg_strs uniqs mult con inst_tys
+                      = dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
 
         ; rhs' <- extendIfaceEnvs  ex_tvs       $
                   extendIfaceIdEnv arg_ids      $
@@ -2031,7 +2031,7 @@ tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
 --   - axioms for type-level literals (Nat and Symbol),
 --     enumerated in typeNatCoAxiomRules
 tcIfaceCoAxiomRule n
-  | Just ax <- lookupUFM typeNatCoAxiomRules n
+  | Just ax <- lookupUFM typeNatCoAxiomRules (ifLclNameFS n)
   = return ax
   | otherwise
   = pprPanic "tcIfaceCoAxiomRule" (ppr n)
@@ -2075,7 +2075,7 @@ tcIfaceImplicit n = do
 
 bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
 bindIfaceId (w, fs, ty) thing_inside
-  = do  { name <- newIfaceName (mkVarOccFS fs)
+  = do  { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
         ; ty' <- tcIfaceType ty
         ; w' <- tcIfaceType w
         ; let id = mkLocalIdOrCoVar name w' ty'
@@ -2118,7 +2118,7 @@ bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
 
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside
-  = do  { name <- newIfaceName (mkTyVarOccFS occ)
+  = do  { name <- newIfaceName (mkTyVarOccFS (ifLclNameFS occ))
         ; tyvar <- mk_iface_tyvar name kind
         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }