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/Iface/Binary.hs

@@ -25,11 +25,12 @@ module GHC.Iface.Binary (
         putName,
         putSymbolTable,
         BinSymbolTable(..),
+        initWriteIfaceType, initReadIfaceTypeTable,
+        putAllTables,
     ) where
 
 import GHC.Prelude
 
-import GHC.Tc.Utils.Monad
 import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )
 import GHC.Unit
 import GHC.Unit.Module.ModIface
@@ -39,6 +40,7 @@ import GHC.Types.Unique.FM
 import GHC.Utils.Panic
 import GHC.Utils.Binary as Binary
 import GHC.Data.FastMutInt
+import GHC.Data.FastString (FastString)
 import GHC.Types.Unique
 import GHC.Utils.Outputable
 import GHC.Types.Name.Cache
@@ -54,6 +56,10 @@ import Data.Char
 import Data.Word
 import Data.IORef
 import Control.Monad
+import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import System.IO.Unsafe
+import Data.Map.Strict (Map)
+
 
 -- ---------------------------------------------------------------------------
 -- Reading and writing binary interface files
@@ -75,7 +81,7 @@ readBinIfaceHeader
   -> CheckHiWay
   -> TraceBinIFace
   -> FilePath
-  -> IO (Fingerprint, BinHandle)
+  -> IO (Fingerprint, ReadBinHandle)
 readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
     let platform = profilePlatform profile
 
@@ -121,6 +127,8 @@ readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
     pure (src_hash, bh)
 
 -- | Read an interface file.
+--
+-- See Note [Iface Binary Serialisation] for details.
 readBinIface
   :: Profile
   -> NameCache
@@ -135,7 +143,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
 
     mod_iface <- getWithUserData name_cache bh
 
-    seekBin bh extFields_p
+    seekBinReader bh extFields_p
     extFields <- get bh
 
     return mod_iface
@@ -146,7 +154,7 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
 -- | This performs a get action after reading the dictionary and symbol
 -- table. It is necessary to run this before trying to deserialise any
 -- Names or FastStrings.
-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
+getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a
 getWithUserData name_cache bh = do
   bh <- getTables name_cache bh
   get bh
@@ -154,24 +162,41 @@ getWithUserData name_cache bh = do
 -- | Setup a BinHandle to read something written using putWithTables
 --
 -- Reading names has the side effect of adding them into the given NameCache.
-getTables :: NameCache -> BinHandle -> IO BinHandle
+getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
 getTables name_cache bh = do
-    -- Read the dictionary
-    -- The next word in the file is a pointer to where the dictionary is
-    -- (probably at the end of the file)
-    dict <- Binary.forwardGet bh (getDictionary bh)
+    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!
+    --
+    -- See Note [Iface Binary Serialiser Order] for details.
+    fsTable <- Binary.forwardGet bh (getTable fsReaderTable bh)
+    let
+      fsReader = mkReaderFromTable fsReaderTable fsTable
+      bhFs = addReaderToUserData fsReader bh
+
 
-    -- Initialise the user-data field of bh
-    let bh_fs = setUserData bh $ newReadState (error "getSymtabName")
-                                              (getDictFastString dict)
+    nameTable <- Binary.forwardGet bh (getTable nameReaderTable bhFs)
+    let
+      nameReader = mkReaderFromTable nameReaderTable nameTable
+      bhName = addReaderToUserData nameReader bhFs
 
-    symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)
+    ifaceTypeTable <- Binary.forwardGet bh (getTable ifaceTypeReaderTable bhName)
+    let
+      ifaceTypeReader = mkReaderFromTable ifaceTypeReaderTable ifaceTypeTable
+      bhIfaceType = addReaderToUserData ifaceTypeReader bhName
 
-    -- It is only now that we know how to get a Name
-    return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
-                                           (getDictFastString dict)
+    writeIORef bhRef (getReaderUserData bhIfaceType)
+    pure bhIfaceType
 
--- | Write an interface file
+-- | 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
     bh <- openBinMem initBinMemSize
@@ -184,14 +209,14 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
     put_  bh tag
     put_  bh (mi_src_hash mod_iface)
 
-    extFields_p_p <- tellBin bh
+    extFields_p_p <- tellBinWriter bh
     put_ bh extFields_p_p
 
     putWithUserData traceBinIface bh mod_iface
 
-    extFields_p <- tellBin bh
+    extFields_p <- tellBinWriter bh
     putAt bh extFields_p_p extFields_p
-    seekBin bh extFields_p
+    seekBinWriter bh extFields_p
     put_ bh (mi_ext_fields mod_iface)
 
     -- And send the result to the file
@@ -201,7 +226,7 @@ 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 -> BinHandle -> a -> IO ()
+putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
 putWithUserData traceBinIface bh payload = do
   (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
 
@@ -225,43 +250,43 @@ putWithUserData traceBinIface bh payload = do
 --
 -- It returns (number of names, number of FastStrings, payload write result)
 --
-putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
-putWithTables bh put_payload = do
-    -- initialize state for the name table and the FastString table.
-    symtab_next <- newFastMutInt 0
-    symtab_map <- newIORef emptyUFM
-    let bin_symtab = BinSymbolTable
-                      { bin_symtab_next = symtab_next
-                      , bin_symtab_map  = symtab_map
-                      }
-
-    (bh_fs, bin_dict, put_dict) <- initFSTable bh
-
-    (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
-
-      -- NB. write the dictionary after the symbol table, because
-      -- writing the symbol table may create more dictionary entries.
-      let put_symtab = do
-            name_count <- readFastMutInt symtab_next
-            symtab_map  <- readIORef symtab_map
-            putSymbolTable bh_fs name_count symtab_map
-            pure name_count
-
-      forwardPut bh_fs (const put_symtab) $ do
-
-        -- BinHandle with FastString and Name writing support
-        let ud_fs = getUserData bh_fs
-        let ud_name = ud_fs
-                        { ud_put_nonbinding_name = putName bin_dict bin_symtab
-                        , ud_put_binding_name    = putName bin_dict bin_symtab
-                        }
-        let bh_name = setUserData bh ud_name
-
-        put_payload bh_name
-
-    return (name_count, fs_count, r)
-
-
+-- See Note [Iface Binary Serialiser Order]
+putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
+putWithTables bh' put_payload = do
+  (fast_wt, fsWriter) <- initFastStringWriterTable
+  (name_wt, nameWriter) <- initNameWriterTable
+  (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType
+
+  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
+
+  (fs_count : name_count : _, r) <-
+    -- The order of these entries matters!
+    --
+    -- See Note [Iface Binary Serialiser Order] for details.
+    putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do
+      put_payload bh
+
+  return (name_count, fs_count, r)
+
+-- | 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
@@ -273,11 +298,168 @@ binaryInterfaceMagic platform
  | otherwise            = FixedLengthEncoding 0x1face64
 
 
+{-
+Note [Iface Binary Serialisation]
+~~~~~~~~~~~~~~~~~~~
+When we serialise a 'ModIface', many symbols are redundant.
+For example, there can be many duplicated 'FastString's and 'Name's.
+To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name',
+by maintaining a table of already seen symbols.
+When serialising a symbol, we lookup whether we have encountered the symbol before.
+If yes, we write the index of the symbol, otherwise we generate a new index and store it in the table.
+
+Besides saving a lot of disk space, this additionally enables us to automatically share
+these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'.
+
+To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following:
+
+* The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser instead of
+  directly serialising itself. It needs to look up the serialiser in the 'ReaderUserData' and
+  'WriterUserData' respectively.
+
+  For example:
+
+  @
+    instance Binary IfaceTyCon where
+      put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of
+        tbl -> putEntry tbl bh ty
+      get bh  = case findUserDataReader (Proxy @IfaceTyCon) bh of
+        tbl -> getEntry tbl bh
+  @
+
+* Whenever a value of 'IfaceTyCon' is serialised, the real serialisation function needs to
+  be configured in the User Data.
+
+  For example, for 'IfaceTyCon':
+
+  @
+    let bh0 :: WriteBinHandle = ...
+        putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk
+        bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0
+  @
+
+  Naturally, you have to do something similar for reading values of 'IfaceTyCon'.
+
+  Now, here we can introduce the deduplication table!
+  Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk,
+  we provide a function that looks up values in a 'Map' and remembers the offset
+  of each value we have already seen.
+  Instead of serialising the full 'IfaceTyCon', we only write the index of the value to disk.
+
+* Storing the deduplication table.
+
+  After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication
+  table full with all the values.
+  We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon').
+
+
+Note [Iface Binary Serialiser Order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often.
+
+After 'ModIface' has been written to disk, we write the deduplication tables.
+Writing a table may add additional entries to *other* deduplication tables, thus
+we need to make sure that the symbol table we serialise only depends on
+deduplication tables that haven't been written to disk yet.
+
+For example, assume we maintain deduplication tables for 'FastString' and 'Name'.
+The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString'
+to the 'FastString' deduplication table.
+Thus, 'Name' table needs to be serialised to disk before the 'FastString' table.
+
+When we read the 'ModIface' from disk, we consequentially need to read the 'FastString'
+deduplication table from disk, before we can deserialise the 'Name' deduplication table.
+Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead
+to the table we need to deserialise first.
+
+Here, a visualisation of the table structure we currently have:
+
+┌──────────────┐
+│   Headers    │
+├──────────────┤
+│   Ptr FS     ├────────┐
+├──────────────┤        │
+│   Ptr Name   ├─────┐  │
+├──────────────┤     │  │
+│              │     │  │
+│   ModIface   │     │  │
+│   Payload    │     │  │
+│              │     │  │
+├──────────────┤     │  │
+│              │     │  │
+│  Name Table  │◄────┘  │
+│              │        │
+├──────────────┤        │
+│              │        │
+│   FS Table   │◄───────┘
+│              │
+└──────────────┘
+
+-}
+
+
 -- -----------------------------------------------------------------------------
 -- The symbol table
 --
 
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
+initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
+initReadIfaceTypeTable ud = do
+  pure $
+    ReaderTable
+      { getTable = getGenericSymbolTable (\bh -> getIfaceType (setReaderUserData bh ud))
+      , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
+      }
+
+initWriteIfaceType :: IO (WriterTable, BinaryWriter IfaceType)
+initWriteIfaceType = do
+  sym_tab <- initGenericSymbolTable @(Map IfaceType)
+  pure
+    ( WriterTable
+        { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
+        }
+    , mkWriter $ putGenericSymTab sym_tab
+    )
+
+
+initNameReaderTable :: NameCache -> IO (ReaderTable Name)
+initNameReaderTable cache = do
+  return $
+    ReaderTable
+      { getTable = \bh -> getSymbolTable bh cache
+      , mkReaderFromTable = \tbl -> mkReader (getSymtabName tbl)
+      }
+
+data BinSymbolTable = BinSymbolTable {
+        bin_symtab_next :: !FastMutInt, -- The next index to use
+        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
+                                -- indexed by Name
+  }
+
+initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
+initNameWriterTable = do
+  symtab_next <- newFastMutInt 0
+  symtab_map <- newIORef emptyUFM
+  let bin_symtab =
+        BinSymbolTable
+          { bin_symtab_next = symtab_next
+          , bin_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
+    )
+
+
+putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
 putSymbolTable bh name_count symtab = do
     put_ bh name_count
     let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
@@ -286,7 +468,7 @@ putSymbolTable bh name_count symtab = do
     mapM_ (\n -> serialiseName bh n symtab) names
 
 
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
 getSymbolTable bh name_cache = do
     sz <- get bh :: IO Int
     -- create an array of Names for the symbols and add them to the NameCache
@@ -307,7 +489,7 @@ getSymbolTable bh name_cache = do
         arr <- unsafeFreeze mut_arr
         return (cache, arr)
 
-serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
+serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
 serialiseName bh name _ = do
     let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -331,8 +513,8 @@ serialiseName bh name _ = do
 
 
 -- See Note [Symbol table representation of names]
-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
-putName _dict BinSymbolTable{
+putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
+putName BinSymbolTable{
                bin_symtab_map = symtab_map_ref,
                bin_symtab_next = symtab_next }
         bh name
@@ -356,10 +538,9 @@ putName _dict BinSymbolTable{
             put_ bh (fromIntegral off :: Word32)
 
 -- See Note [Symbol table representation of names]
-getSymtabName :: NameCache
-              -> Dictionary -> SymbolTable
-              -> BinHandle -> IO Name
-getSymtabName _name_cache _dict symtab bh = do
+getSymtabName :: SymbolTable Name
+              -> ReadBinHandle -> IO Name
+getSymtabName symtab bh = do
     i :: Word32 <- get bh
     case i .&. 0xC0000000 of
       0x00000000 -> return $! symtab ! fromIntegral i
@@ -376,10 +557,3 @@ getSymtabName _name_cache _dict symtab bh = do
                       Just n  -> n
 
       _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
-
-data BinSymbolTable = BinSymbolTable {
-        bin_symtab_next :: !FastMutInt, -- The next index to use
-        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
-                                -- indexed by Name
-  }
-

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)
+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
 
@@ -67,7 +66,7 @@ hieMagicLen = length hieMagic
 ghcVersion :: ByteString
 ghcVersion = BSC.pack cProjectVersion
 
-putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine :: WriteBinHandle -> ByteString -> IO ()
 putBinLine bh xs = do
   mapM_ (putByte bh) $ BS.unpack xs
   putByte bh 10 -- newline char
@@ -84,57 +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 <- tellBin bh0
-  put_ bh0 dict_p_p
+  (fs_tbl, fs_w) <- initFastStringWriterTable
+  (name_tbl, name_w) <- initWriteNameTable
+  (iface_tbl, iface_w) <- initWriteIfaceType
 
-  -- remember where the symbol table pointer will go
-  symtab_p_p <- tellBin 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 = setUserData 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 <- tellBin bh
-  putAt bh symtab_p_p symtab_p
-  seekBin 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 <- tellBin bh
-  putAt bh dict_p_p dict_p
-  seekBin 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
@@ -181,7 +181,7 @@ readHieFile name_cache file = do
   hieFile <- readHieFileContents bh0 name_cache
   return $ HieFileResult hieVersion ghcVersion hieFile
 
-readBinLine :: BinHandle -> IO ByteString
+readBinLine :: ReadBinHandle -> IO ByteString
 readBinLine bh = BS.pack . reverse <$> loop []
   where
     loop acc = do
@@ -190,7 +190,7 @@ readBinLine bh = BS.pack . reverse <$> loop []
       then return acc
       else loop (char : acc)
 
-readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader :: FilePath -> ReadBinHandle -> IO HieHeader
 readHieFileHeader file bh0 = do
   -- Read the header
   magic <- replicateM hieMagicLen (get bh0)
@@ -213,59 +213,42 @@ readHieFileHeader file bh0 = do
                         ]
       return (readHieVersion, ghcVersion)
 
-readHieFileContents :: BinHandle -> NameCache -> IO HieFile
+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 = setUserData bh0 $ newReadState (error "getSymtabName")
-                                               (getDictFastString dict)
-      symtab <- get_symbol_table bh1
-      let bh1' = setUserData 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 <- tellBin bin_handle
-      seekBin bin_handle dict_p
-      dict <- getDictionary bin_handle
-      seekBin bin_handle data_p
-      return dict
-
-    get_symbol_table bh1 = do
-      symtab_p <- get bh1
-      data_p'  <- tellBin bh1
-      seekBin bh1 symtab_p
-      symtab <- getSymbolTable bh1 name_cache
-      seekBin bh1 data_p'
-      return symtab
-
-putFastString :: HieDictionary -> BinHandle -> 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)
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
+    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
   put_ bh next_off
   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
   mapM_ (putHieName bh) names
 
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
+getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
 getSymbolTable bh name_cache = do
   sz <- get bh
   mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
@@ -275,12 +258,12 @@ getSymbolTable bh name_cache = do
     A.writeArray mut_arr i name
   A.unsafeFreeze mut_arr
 
-getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName :: SymbolTable Name -> ReadBinHandle -> IO Name
 getSymTabName st bh = do
   i :: Word32 <- get bh
   return $ st A.! (fromIntegral i)
 
-putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName :: HieSymbolTable -> WriteBinHandle -> Name -> IO ()
 putName (HieSymbolTable next ref) bh name = do
   symmap <- readIORef ref
   case lookupUFM symmap name of
@@ -333,7 +316,7 @@ fromHieName nc hie_name = do
 
 -- ** Reading and writing `HieName`'s
 
-putHieName :: BinHandle -> HieName -> IO ()
+putHieName :: WriteBinHandle -> HieName -> IO ()
 putHieName bh (ExternalName mod occ span) = do
   putByte bh 0
   put_ bh (mod, occ, BinSrcSpan span)
@@ -344,7 +327,7 @@ putHieName bh (KnownKeyName uniq) = do
   putByte bh 2
   put_ bh $ unpkUnique uniq
 
-getHieName :: BinHandle -> IO HieName
+getHieName :: ReadBinHandle -> IO HieName
 getHieName bh = do
   t <- getByte bh
   case t of

compiler/GHC/Iface/Ext/Fields.hs

@@ -33,16 +33,16 @@ instance Binary ExtensibleFields where
     -- for a payload pointer after each name:
     header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
       put_ bh name
-      field_p_p <- tellBin bh
+      field_p_p <- tellBinWriter bh
       put_ bh field_p_p
       return (field_p_p, dat)
 
     -- Now put the payloads and use the reserved space
     -- to point to the start of each payload:
     forM_ header_entries $ \(field_p_p, dat) -> do
-      field_p <- tellBin bh
+      field_p <- tellBinWriter bh
       putAt bh field_p_p field_p
-      seekBin bh field_p
+      seekBinWriter bh field_p
       put_ bh dat
 
   get bh = do
@@ -54,7 +54,7 @@ instance Binary ExtensibleFields where
 
     -- Seek to and get each field's payload:
     fields <- forM header_entries $ \(name, field_p) -> do
-      seekBin bh field_p
+      seekBinReader bh field_p
       dat <- get bh
       return (name, dat)
 
@@ -72,7 +72,7 @@ emptyExtensibleFields = ExtensibleFields Map.empty
 readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
 readField name = readFieldWith name get
 
-readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
 readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
   Map.lookup name (getExtensibleFields fields)
 
@@ -82,7 +82,7 @@ readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
 writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
 writeField name x = writeFieldWith name (`put_` x)
 
-writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
 writeFieldWith name write fields = do
   bh <- openBinMem (1024 * 1024)
   write bh

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/Recomp.hs

@@ -1032,7 +1032,7 @@ addFingerprints hsc_env iface0
         -- change if the fingerprint for anything it refers to (transitively)
         -- changes.
        mk_put_name :: OccEnv (OccName,Fingerprint)
-                   -> BinHandle -> Name -> IO  ()
+                   -> WriteBinHandle -> Name -> IO  ()
        mk_put_name local_env bh name
           | isWiredInName name  =  putNameLiterally bh name
            -- wired-in names don't have fingerprints
@@ -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,8 +14,9 @@ import GHC.Utils.Fingerprint
 import GHC.Utils.Binary
 import GHC.Types.Name
 import GHC.Utils.Panic.Plain
+import GHC.Iface.Type (putIfaceType)
 
-fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
 fingerprintBinMem bh = withBinBuffer bh f
   where
     f bs =
@@ -26,7 +27,7 @@ fingerprintBinMem bh = withBinBuffer bh f
         in fp `seq` return fp
 
 computeFingerprint :: (Binary a)
-                   => (BinHandle -> Name -> IO ())
+                   => (WriteBinHandle -> Name -> IO ())
                    -> a
                    -> IO Fingerprint
 computeFingerprint put_nonbinding_name a = do
@@ -34,12 +35,16 @@ computeFingerprint put_nonbinding_name a = do
     put_ bh a
     fingerprintBinMem bh
   where
-    set_user_data bh =
-      setUserData 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.
-putNameLiterally :: BinHandle -> Name -> IO ()
+putNameLiterally :: WriteBinHandle -> Name -> IO ()
 putNameLiterally bh name = assert (isExternalName name) $ do
     put_ bh $! nameModule name
     put_ bh $! nameOccName name

compiler/GHC/Iface/Recomp/Flags.hs

@@ -31,7 +31,7 @@ import System.FilePath (normalise)
 -- NB: The 'Module' parameter is the 'Module' recorded by the *interface*
 -- file, not the actual 'Module' according to our 'DynFlags'.
 fingerprintDynFlags :: HscEnv -> Module
-                    -> (BinHandle -> Name -> IO ())
+                    -> (WriteBinHandle -> Name -> IO ())
                     -> IO Fingerprint
 
 fingerprintDynFlags hsc_env this_mod nameio =
@@ -81,7 +81,7 @@ fingerprintDynFlags hsc_env this_mod nameio =
 -- object files as they can.
 -- See Note [Ignoring some flag changes]
 fingerprintOptFlags :: DynFlags
-                      -> (BinHandle -> Name -> IO ())
+                      -> (WriteBinHandle -> Name -> IO ())
                       -> IO Fingerprint
 fingerprintOptFlags DynFlags{..} nameio =
       let
@@ -99,7 +99,7 @@ fingerprintOptFlags DynFlags{..} nameio =
 -- file compiled for HPC when not actually using HPC.
 -- See Note [Ignoring some flag changes]
 fingerprintHpcFlags :: DynFlags
-                      -> (BinHandle -> Name -> IO ())
+                      -> (WriteBinHandle -> Name -> IO ())
                       -> IO Fingerprint
 fingerprintHpcFlags dflags@DynFlags{..} nameio =
       let

compiler/GHC/Iface/Syntax.hs

@@ -94,6 +94,7 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
 import Control.Monad
 import System.IO.Unsafe
 import Control.DeepSeq
+import Data.Proxy
 
 infixl 3 &&&
 
@@ -118,15 +119,15 @@ type IfaceTopBndr = Name
   -- We don't serialise the namespace onto the disk though; rather we
   -- drop it when serialising and add it back in when deserialising.
 
-getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr
+getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr
 getIfaceTopBndr bh = get bh
 
-putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO ()
+putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO ()
 putIfaceTopBndr bh name =
-    case getUserData bh of
-      UserData{ ud_put_binding_name = put_binding_name } ->
+    case findUserDataWriter (Proxy @BindingName) bh of
+      tbl ->
           --pprTrace "putIfaceTopBndr" (ppr name) $
-          put_binding_name bh name
+          putEntry tbl bh (BindingName name)
 
 
 data IfaceDecl
@@ -631,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
@@ -1025,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
@@ -2444,13 +2446,13 @@ instance Binary IfGuidance where
                     c <- get bh
                     return (IfWhen a b c)
 
-putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()
+putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO ()
 putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
                                      , uf_is_work_free = wf, uf_expandable = exp }) = do
     let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp
     putByte bh b
 
-getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache
+getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache
 getUnfoldingCache bh = do
     b <- getByte bh
     let hnf     = testBit b 3

compiler/GHC/Iface/Type.hs

@@ -9,9 +9,9 @@ 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(..),
@@ -33,6 +33,8 @@ module GHC.Iface.Type (
         ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
         ifTyConBinderVar, ifTyConBinderName,
 
+        -- Binary utilities
+        putIfaceType, getIfaceType,
         -- Equality testing
         isIfaceLiftedTypeKind,
 
@@ -90,10 +92,12 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
 
-import Data.Maybe( isJust )
-import qualified Data.Semigroup as Semi
 import Control.DeepSeq
+import Data.Proxy
 import Control.Monad ((<$!>))
+import Control.Arrow (first)
+import qualified Data.Semigroup as Semi
+import Data.Maybe (isJust)
 
 {-
 ************************************************************************
@@ -103,7 +107,20 @@ import Control.Monad ((<$!>))
 ************************************************************************
 -}
 
-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)
@@ -111,6 +128,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)
@@ -179,6 +198,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
 
@@ -187,9 +207,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
@@ -231,6 +251,7 @@ data IfaceAppArgs
                         --    arguments in @{...}.
 
            IfaceAppArgs -- The rest of the arguments
+  deriving (Eq, Ord)
 
 instance Semi.Semigroup IfaceAppArgs where
   IA_Nil <> xs              = xs
@@ -257,7 +278,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
@@ -277,7 +298,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"
@@ -371,7 +392,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]
@@ -421,7 +442,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
@@ -446,11 +467,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -622,11 +645,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]
@@ -682,7 +705,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
 
 
@@ -1191,7 +1214,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
@@ -1199,7 +1222,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
 
@@ -1627,7 +1650,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
@@ -2015,6 +2038,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)
 
@@ -2045,11 +2071,12 @@ instance Outputable IfaceCoercion where
   ppr = pprIfaceCoercion
 
 instance Binary IfaceTyCon where
-   put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
+  put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
 
-   get bh = do n <- get bh
-               i <- get bh
-               return (IfaceTyCon n i)
+  get bh = do
+    n <- get bh
+    i <- get bh
+    return (IfaceTyCon n i)
 
 instance Binary IfaceTyConSort where
    put_ bh IfaceNormalTyCon             = putByte bh 0
@@ -2171,38 +2198,47 @@ 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 (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 = do
+   put_ bh tyCon = case findUserDataWriter Proxy bh of
+    tbl -> putEntry tbl bh tyCon
+
+   get bh = case findUserDataReader Proxy bh of
+    tbl -> getEntry tbl 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 +2266,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 +2518,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) }
 

compiler/GHC/Stg/CSE.hs

@@ -109,6 +109,8 @@ import GHC.Core.Map.Expr
 import GHC.Data.TrieMap
 import GHC.Types.Name.Env
 import Control.Monad( (>=>) )
+import qualified Data.Map as Map
+import GHC.Types.Literal ( Literal )
 
 --------------
 -- The Trie --
@@ -122,6 +124,8 @@ data StgArgMap a = SAM
     , sam_lit :: LiteralMap a
     }
 
+type LiteralMap = Map.Map Literal
+
 -- TODO(22292): derive
 instance Functor StgArgMap where
     fmap f SAM { sam_var = varm, sam_lit = litm } = SAM

compiler/GHC/StgToJS/Object.hs

@@ -66,6 +66,9 @@ import GHC.Prelude
 import           Control.Monad
 
 import           Data.Array
+import qualified Data.ByteString          as B
+import qualified Data.ByteString.Unsafe   as B
+import           Data.Char (isSpace)
 import           Data.Int
 import           Data.IntSet (IntSet)
 import qualified Data.IntSet as IS
@@ -75,10 +78,7 @@ import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Word
 import           Data.Semigroup
-import qualified Data.ByteString          as B
-import qualified Data.ByteString.Unsafe   as B
-import Data.Char (isSpace)
-import System.IO
+import           System.IO
 
 import GHC.Settings.Constants (hiVersion)
 
@@ -168,7 +168,7 @@ wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"#
 data Object = Object
   { objModuleName    :: !ModuleName
     -- ^ name of the module
-  , objHandle        :: !BinHandle
+  , objHandle        :: !ReadBinHandle
     -- ^ BinHandle that can be used to read the ObjBlocks
   , objPayloadOffset :: !(Bin ObjBlock)
     -- ^ Offset of the payload (units)
@@ -253,7 +253,7 @@ instance Outputable ExportedFun where
 
 -- | Write an ObjBlock, except for the top level symbols which are stored in the
 -- index
-putObjBlock :: BinHandle -> ObjBlock -> IO ()
+putObjBlock :: WriteBinHandle -> ObjBlock -> IO ()
 putObjBlock bh (ObjBlock _syms b c d e f g) = do
     put_ bh b
     put_ bh c
@@ -264,7 +264,7 @@ putObjBlock bh (ObjBlock _syms b c d e f g) = do
 
 -- | Read an ObjBlock and associate it to the given symbols (that must have been
 -- read from the index)
-getObjBlock :: [FastString] -> BinHandle -> IO ObjBlock
+getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock
 getObjBlock syms bh = do
     b <- get bh
     c <- get bh
@@ -299,7 +299,7 @@ data IndexEntry = IndexEntry
 -- | Given a handle to a Binary payload, add the module, 'mod_name', its
 -- dependencies, 'deps', and its linkable units to the payload.
 putObject
-  :: BinHandle
+  :: WriteBinHandle
   -> ModuleName -- ^ module
   -> BlockInfo  -- ^ block infos
   -> [ObjBlock] -- ^ linkable units and their symbols
@@ -313,15 +313,16 @@ putObject bh mod_name deps os = do
   -- object in an archive.
   put_ bh (moduleNameString mod_name)
 
-  (bh_fs, _bin_dict, put_dict) <- initFSTable bh
+  (fs_tbl, fs_writer) <- initFastStringWriterTable
+  let bh_fs = addWriterToUserData fs_writer bh
 
-  forwardPut_ bh (const put_dict) $ do
+  forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do
     put_ bh_fs deps
 
     -- forward put the index
     forwardPut_ bh_fs (put_ bh_fs) $ do
       idx <- forM os $ \o -> do
-        p <- tellBin bh_fs
+        p <- tellBinWriter bh_fs
         -- write units without their symbols
         putObjBlock bh_fs o
         -- return symbols and offset to store in the index
@@ -329,7 +330,7 @@ putObject bh mod_name deps os = do
       pure idx
 
 -- | Parse object header
-getObjectHeader :: BinHandle -> IO (Either String ModuleName)
+getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName)
 getObjectHeader bh = do
   magic <- getByteString bh (B.length hsHeader)
   case magic == hsHeader of
@@ -344,15 +345,15 @@ getObjectHeader bh = do
 
 
 -- | Parse object body. Must be called after a successful getObjectHeader
-getObjectBody :: BinHandle -> ModuleName -> IO Object
+getObjectBody :: ReadBinHandle -> ModuleName -> IO Object
 getObjectBody bh0 mod_name = do
   -- Read the string table
   dict <- forwardGet bh0 (getDictionary bh0)
-  let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }
+  let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict)
 
   block_info  <- get bh
   idx         <- forwardGet bh (get bh)
-  payload_pos <- tellBin bh
+  payload_pos <- tellBinReader bh
 
   pure $ Object
     { objModuleName    = mod_name
@@ -363,7 +364,7 @@ getObjectBody bh0 mod_name = do
     }
 
 -- | Parse object
-getObject :: BinHandle -> IO (Maybe Object)
+getObject :: ReadBinHandle -> IO (Maybe Object)
 getObject bh = do
   getObjectHeader bh >>= \case
     Left _err      -> pure Nothing
@@ -392,7 +393,7 @@ getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..])
     bh = objHandle obj
     read_entry (IndexEntry syms offset,i)
       | IS.member i bids = do
-          seekBin bh offset
+          seekBinReader bh offset
           Just <$> getObjBlock syms bh
       | otherwise = pure Nothing
 
@@ -408,12 +409,12 @@ readObjectBlocks file bids = do
 -- Helper functions
 --------------------------------------------------------------------------------
 
-putEnum :: Enum a => BinHandle -> a -> IO ()
+putEnum :: Enum a => WriteBinHandle -> a -> IO ()
 putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)
              | otherwise = put_ bh n
   where n = fromIntegral $ fromEnum x :: Word16
 
-getEnum :: Enum a => BinHandle -> IO a
+getEnum :: Enum a => ReadBinHandle -> IO a
 getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16)
 
 -- | Helper to convert Int to Int32
@@ -778,7 +779,7 @@ writeJSObject opts contents output_fn = do
 
 
 -- | Read a JS object from BinHandle
-parseJSObject :: BinHandle -> IO (JSOptions, B.ByteString)
+parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString)
 parseJSObject bh = do
   magic <- getByteString bh (B.length jsHeader)
   case magic == jsHeader of