[Git][ghc/ghc][wip/fendor/ifacetype-deduplication] 6 commits: Refactor the Binary serialisation interface
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Wed Apr 10 09:58:58 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ifacetype-deduplication at Glasgow Haskell Compiler / GHC
Commits:
68d406f8 by Fendor at 2024-04-10T10:11:27+02:00
Refactor the Binary serialisation interface
The end goal is to dynamically add deduplication tables for `ModIface`
interface serialisation.
We identify two main points of interest that make this difficult:
1. UserData hardcodes what `Binary` instances can have deduplication
tables. Moreover, it heavily uses partial functions.
2. GHC.Iface.Binary hardcodes the deduplication tables for 'Name' and
'FastString', making it difficult to add more deduplication.
Instead of having a single `UserData` record with fields for all the
types that can have deduplication tables, we allow to provide custom
serialisers for any `Typeable`.
These are wrapped in existentials and stored in a `Map` indexed by their
respective `TypeRep`.
The `Binary` instance of the type to deduplicate still needs to
explicitly look up the decoder via `findUserDataReader` and
`findUserDataWriter`, which is no worse than the status-quo.
`Map` was chosen as microbenchmarks indicate it is the fastest for a
small number of keys (< 10).
To generalise the deduplication table serialisation mechanism, we
introduce the types `ReaderTable` and `WriterTable` which provide a
simple interface that is sufficient to implement a general purpose
deduplication mechanism for `writeBinIface` and `readBinIface`.
This allows us to provide a list of deduplication tables for
serialisation that can be extended more easily, for example for
`IfaceTyCon`, see the issue https://gitlab.haskell.org/ghc/ghc/-/issues/24540
for more motivation.
In addition to ths refactoring, we split `UserData` into `ReaderUserData`
and `WriterUserData`, to avoid partial functions.
Bump haddock submodule to accomodate for `UserData` split.
-------------------------
Metric Increase:
T21839c
-------------------------
- - - - -
026372f7 by Fendor at 2024-04-10T10:11:27+02:00
Split `BinHandle` into `ReadBinHandle` and `WriteBinHandle`
A `BinHandle` contains too much information for reading data.
For example, it needs to keep a `FastMutInt` and a `IORef BinData`,
when the non-mutable variants would suffice.
Additionally, this change has the benefit that anyone can immediately
tell whether the `BinHandle` is used for reading or writing.
Bump haddock submodule BinHandle split.
- - - - -
12a3a5d5 by Matthew Pickering at 2024-04-10T10:44:28+02:00
Add deduplication table for `IfaceType`
The type `IfaceType` is a highly redundant, tree-like data structure.
While benchmarking, we realised that the high redundancy of `IfaceType`
causes high memory consumption in GHCi sessions.
We fix this by adding a deduplication table to the serialisation of
`ModIface`, similar to how we deduplicate `Name`s and `FastString`s.
When reading the interface file back, the table allows us to automatically
share identical values of `IfaceType`.
This deduplication has the beneficial side effect to additionally reduce
the size of the on-disk interface files tremendously. On the agda code
base, we reduce the size from 28 MB to 16 MB. When `-fwrite-simplified-core`
is enabled, we reduce the size from 112 MB to 22 MB.
We have to add an `Ord` instance to `IfaceType` in order to store it
efficiently for look up operations. This is mostly straightforward, we
change occurrences of `FastString` with `LexicalFastString` and add a
newtype definition for `IfLclName = LexicalFastString`.
Bump haddock submodule for `IfLclName` newtype changes.
- - - - -
4ed1ed63 by Fendor at 2024-04-10T10:44:30+02:00
Add IfaceType deduplication table to .hie serialisation
Refactor .hie file serialisation to use the same infrastrucutre as
`putWithTables`.
- - - - -
c4a518b4 by Matthew Pickering at 2024-04-10T10:44:30+02:00
WIP: TrieMap for IfaceType
Bump haddock submodule
- - - - -
829f88c9 by Fendor at 2024-04-10T11:58:08+02:00
WIP: CI results for Data.Map deduplication
- - - - -
30 changed files:
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Fields.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Binary.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- + compiler/GHC/Iface/Type/Map.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/CSE.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/FieldLabel.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/Language/Haskell/Syntax/Type.hs-boot
- compiler/ghc.cabal.in
- utils/haddock
Changes:
=====================================
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 at 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
=====================================
@@ -0,0 +1,180 @@
+{-# 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
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -148,7 +148,7 @@ import qualified Data.Semigroup as Semi
********************************************************************* -}
data LeftOrRight = CLeft | CRight
- deriving( Eq, Data )
+ deriving( Eq, Data, Ord )
pickLR :: LeftOrRight -> (a,a) -> a
pickLR CLeft (l,_) = l
@@ -1010,7 +1010,7 @@ data TupleSort
= BoxedTuple
| UnboxedTuple
| ConstraintTuple
- deriving( Eq, Data )
+ deriving( Eq, Data, Ord )
instance Outputable TupleSort where
ppr ts = text $
=====================================
compiler/GHC/Types/FieldLabel.hs
=====================================
@@ -140,9 +140,7 @@ instance Binary Name => Binary FieldLabel where
put_ bh (FieldLabel aa ab ac) = do
put_ bh aa
put_ bh ab
- case getUserData bh of
- UserData{ ud_put_binding_name = put_binding_name } ->
- put_binding_name bh ac
+ put_ bh ac
get bh = do
aa <- get bh
ab <- get bh
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -663,12 +663,12 @@ instance Data Name where
-- distinction.
instance Binary Name where
put_ bh name =
- case getUserData bh of
- UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name
+ case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh name
get bh =
- case getUserData bh of
- UserData { ud_get_name = get_name } -> get_name bh
+ case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
{-
************************************************************************
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -720,7 +720,7 @@ Currently there are nine different uses of 'VarBndr':
data VarBndr var argf = Bndr var argf
-- See Note [The VarBndr type and its uses]
- deriving( Data )
+ deriving( Data, Eq, Ord)
-- | Variable Binder
--
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -2,8 +2,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# LANGUAGE TypeFamilies #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -21,7 +23,7 @@
module GHC.Utils.Binary
( {-type-} Bin,
{-class-} Binary(..),
- {-type-} BinHandle,
+ {-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
@@ -30,8 +32,10 @@ module GHC.Utils.Binary
openBinMem,
-- closeBin,
- seekBin,
- tellBin,
+ seekBinWriter,
+ seekBinReader,
+ tellBinReader,
+ tellBinWriter,
castBin,
withBinBuffer,
@@ -62,19 +66,41 @@ module GHC.Utils.Binary
-- * Lazy Binary I/O
lazyGet,
lazyPut,
+ lazyGet',
+ lazyPut',
lazyGetMaybe,
lazyPutMaybe,
-- * User data
- UserData(..), getUserData, setUserData,
- newReadState, newWriteState, noUserData,
-
+ ReaderUserData(..), getReaderUserData, setReaderUserData, noReaderUserData,
+ WriterUserData(..), getWriterUserData, setWriterUserData, noWriterUserData,
+ mkWriterUserData, mkReaderUserData,
+ newReadState, newWriteState,
+ addReaderToUserData, addWriterToUserData,
+ findUserDataReader, findUserDataWriter,
+ -- * Binary Readers & Writers
+ BinaryReader(..), BinaryWriter(..),
+ mkWriter, mkReader,
+ SomeBinaryReader, SomeBinaryWriter,
+ mkSomeBinaryReader, mkSomeBinaryWriter,
+ -- * Tables
+ ReaderTable(..),
+ WriterTable(..),
-- * String table ("dictionary")
+ initFastStringReaderTable, initFastStringWriterTable,
putDictionary, getDictionary, putFS,
- FSTable, initFSTable, getDictFastString, putDictFastString,
-
+ FSTable(..), getDictFastString, putDictFastString,
+ -- * Generic deduplication table
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ getGenericSymtab, putGenericSymTab,
+ getGenericSymbolTable, putGenericSymbolTable,
-- * Newtype wrappers
- BinSpan(..), BinSrcSpan(..), BinLocated(..)
+ BinSpan(..), BinSrcSpan(..), BinLocated(..),
+ -- * Newtypes for types that have canonically more than one valid encoding
+ BindingName(..),
+ simpleBindingNameWriter,
+ simpleBindingNameReader,
) where
import GHC.Prelude
@@ -91,8 +117,10 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHC.Utils.Misc ( HasCallStack )
import Control.DeepSeq
+import Control.Monad ( when, (<$!>), unless, forM_, void )
import Foreign hiding (shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
@@ -104,11 +132,13 @@ import Data.IORef
import Data.Char ( ord, chr )
import Data.List.NonEmpty ( NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time
import Data.List (unfoldr)
-import Control.Monad ( when, (<$!>), unless, forM_, void )
+import Data.Typeable
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
@@ -119,6 +149,12 @@ import qualified Data.IntMap as IntMap
import GHC.ForeignPtr ( unsafeWithForeignPtr )
#endif
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Coerce
+import GHC.Data.TrieMap
+
+
+
type BinArray = ForeignPtr Word8
#if !MIN_VERSION_base(4,15,0)
@@ -150,49 +186,95 @@ instance Binary BinData where
copyBytes dest orig sz
return (BinData sz dat)
-dataHandle :: BinData -> IO BinHandle
+dataHandle :: BinData -> IO ReadBinHandle
dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
- szr <- newFastMutInt size
- binr <- newIORef bin
- return (BinMem noUserData ixr szr binr)
+ return (ReadBinMem noReaderUserData ixr size bin)
-handleData :: BinHandle -> IO BinData
-handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+handleData :: WriteBinHandle -> IO BinData
+handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
-data BinHandle
- = BinMem { -- binary data stored in an unboxed array
- bh_usr :: UserData, -- sigh, need parameterized modules :-)
- _off_r :: !FastMutInt, -- the current offset
- _sz_r :: !FastMutInt, -- size of the array (cached)
- _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
+-- | A write-only handle that can be used to serialise binary data into a buffer.
+--
+-- The buffer is an unboxed binary array.
+data WriteBinHandle
+ = WriteBinMem {
+ wbm_userData :: WriterUserData,
+ -- ^ User data for writing binary outputs.
+ -- Allows users to overwrite certain 'Binary' instances.
+ -- This is helpful when a non-canonical 'Binary' instance is required,
+ -- such as in the case of 'Name'.
+ wbm_off_r :: !FastMutInt, -- ^ the current offset
+ wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached)
+ wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))
+ }
+
+-- | A read-only handle that can be used to deserialise binary data from a buffer.
+--
+-- The buffer is an unboxed binary array.
+data ReadBinHandle
+ = ReadBinMem {
+ rbm_userData :: ReaderUserData,
+ -- ^ User data for reading binary inputs.
+ -- Allows users to overwrite certain 'Binary' instances.
+ -- This is helpful when a non-canonical 'Binary' instance is required,
+ -- such as in the case of 'Name'.
+ rbm_off_r :: !FastMutInt, -- ^ the current offset
+ rbm_sz_r :: !Int, -- ^ size of the array (cached)
+ rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1))
}
- -- XXX: should really store a "high water mark" for dumping out
- -- the binary data to a file.
-getUserData :: BinHandle -> UserData
-getUserData bh = bh_usr bh
+getReaderUserData :: ReadBinHandle -> ReaderUserData
+getReaderUserData bh = rbm_userData bh
+
+getWriterUserData :: WriteBinHandle -> WriterUserData
+getWriterUserData bh = wbm_userData bh
-setUserData :: BinHandle -> UserData -> BinHandle
-setUserData bh us = bh { bh_usr = us }
+setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
+setWriterUserData bh us = bh { wbm_userData = us }
+
+setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
+setReaderUserData bh us = bh { rbm_userData = us }
+
+-- | Add 'SomeBinaryReader' as a known binary decoder.
+-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',
+-- it is overwritten.
+addReaderToUserData :: Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle
+addReaderToUserData reader bh = bh
+ { rbm_userData = (rbm_userData bh)
+ { ud_reader_data = Map.insert typRep cache (ud_reader_data (rbm_userData bh))
+ }
+ }
+ where
+ cache@(SomeBinaryReader typRep _) = mkSomeBinaryReader reader
+
+-- | Add 'SomeBinaryWriter' as a known binary encoder.
+-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',
+-- it is overwritten.
+addWriterToUserData :: Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle
+addWriterToUserData writer bh = bh
+ { wbm_userData = (wbm_userData bh)
+ { ud_writer_data = Map.insert typRep cache (ud_writer_data (wbm_userData bh))
+ }
+ }
+ where
+ cache@(SomeBinaryWriter typRep _) = mkSomeBinaryWriter writer
-- | Get access to the underlying buffer.
-withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
-withBinBuffer (BinMem _ ix_r _ arr_r) action = do
- arr <- readIORef arr_r
+withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a
+withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do
ix <- readFastMutInt ix_r
+ arr <- readIORef arr_r
action $ BS.fromForeignPtr arr 0 ix
-unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
+unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt len
- return (BinMem noUserData ix_r sz_r arr_r)
+ return (ReadBinMem noReaderUserData ix_r len arr)
---------------------------------------------------------------
-- Bin
@@ -211,23 +293,23 @@ castBin (BinPtr i) = BinPtr i
-- | Do not rely on instance sizes for general types,
-- we use variable length encoding for many of them.
class Binary a where
- put_ :: BinHandle -> a -> IO ()
- put :: BinHandle -> a -> IO (Bin a)
- get :: BinHandle -> IO a
+ put_ :: WriteBinHandle -> a -> IO ()
+ put :: WriteBinHandle -> a -> IO (Bin a)
+ get :: ReadBinHandle -> IO a
-- define one of put_, put. Use of put_ is recommended because it
-- is more likely that tail-calls can kick in, and we rarely need the
-- position return value.
put_ bh a = do _ <- put bh a; return ()
- put bh a = do p <- tellBin bh; put_ bh a; return p
+ put bh a = do p <- tellBinWriter bh; put_ bh a; return p
-putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
-putAt bh p x = do seekBin bh p; put_ bh x; return ()
+putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBinWriter bh p; put_ bh x; return ()
-getAt :: Binary a => BinHandle -> Bin a -> IO a
-getAt bh p = do seekBin bh p; get bh
+getAt :: Binary a => ReadBinHandle -> Bin a -> IO a
+getAt bh p = do seekBinReader bh p; get bh
-openBinMem :: Int -> IO BinHandle
+openBinMem :: Int -> IO WriteBinHandle
openBinMem size
| size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0"
| otherwise = do
@@ -235,45 +317,60 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem noUserData ix_r sz_r arr_r)
+ return WriteBinMem
+ { wbm_userData = noWriterUserData
+ , wbm_off_r = ix_r
+ , wbm_sz_r = sz_r
+ , wbm_arr_r = arr_r
+ }
-tellBin :: BinHandle -> IO (Bin a)
-tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBinWriter :: WriteBinHandle -> IO (Bin a)
+tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
-seekBin :: BinHandle -> Bin a -> IO ()
-seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
+tellBinReader :: ReadBinHandle -> IO (Bin a)
+tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+
+seekBinWriter :: WriteBinHandle -> Bin a -> IO ()
+seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p > sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
--- | 'seekBinNoExpand' moves the index pointer to the location pointed to
+-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to
-- by 'Bin a'.
-- This operation may 'panic', if the pointer location is out of bounds of the
-- buffer of 'BinHandle'.
-seekBinNoExpand :: BinHandle -> Bin a -> IO ()
-seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
+seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO ()
+seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do
sz <- readFastMutInt sz_r
if (p > sz)
- then panic "seekBinNoExpand: seek out of range"
+ then panic "seekBinNoExpandWriter: seek out of range"
else writeFastMutInt ix_r p
-writeBinMem :: BinHandle -> FilePath -> IO ()
-writeBinMem (BinMem _ ix_r _ arr_r) fn = do
+-- | SeekBin but without calling expandBin
+seekBinReader :: ReadBinHandle -> Bin a -> IO ()
+seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do
+ if (p > sz_r)
+ then panic "seekBinReader: seek out of range"
+ else writeFastMutInt ix_r p
+
+writeBinMem :: WriteBinHandle -> FilePath -> IO ()
+writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix
hClose h
-readBinMem :: FilePath -> IO BinHandle
+readBinMem :: FilePath -> IO ReadBinHandle
readBinMem filename = do
withBinaryFile filename ReadMode $ \h -> do
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
readBinMem_ filesize h
-readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle)
+readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle)
readBinMemN size filename = do
withBinaryFile filename ReadMode $ \h -> do
filesize' <- hFileSize h
@@ -282,20 +379,23 @@ readBinMemN size filename = do
then pure Nothing
else Just <$> readBinMem_ size h
-readBinMem_ :: Int -> Handle -> IO BinHandle
+readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ filesize h = do
arr <- mallocForeignPtrBytes filesize
count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
when (count /= filesize) $
error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
- arr_r <- newIORef arr
ix_r <- newFastMutInt 0
- sz_r <- newFastMutInt filesize
- return (BinMem noUserData ix_r sz_r arr_r)
+ return ReadBinMem
+ { rbm_userData = noReaderUserData
+ , rbm_off_r = ix_r
+ , rbm_sz_r = filesize
+ , rbm_arr_r = arr
+ }
-- expand the size of the array to include a specified offset
-expandBin :: BinHandle -> Int -> IO ()
-expandBin (BinMem _ _ sz_r arr_r) !off = do
+expandBin :: WriteBinHandle -> Int -> IO ()
+expandBin (WriteBinMem _ _ sz_r arr_r) !off = do
!sz <- readFastMutInt sz_r
let !sz' = getSize sz
arr <- readIORef arr_r
@@ -316,7 +416,7 @@ expandBin (BinMem _ _ sz_r arr_r) !off = do
foldGet
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -332,7 +432,7 @@ foldGet n bh init_b f = go 0 init_b
foldGet'
:: Binary a
=> Word -- n elements
- -> BinHandle
+ -> ReadBinHandle
-> b -- initial accumulator
-> (Word -> a -> b -> IO b)
-> IO b
@@ -353,8 +453,8 @@ foldGet' n bh init_b f = go 0 init_b
-- | Takes a size and action writing up to @size@ bytes.
-- After the action has run advance the index to the buffer
-- by size bytes.
-putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
-putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
+putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
+putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix + size > sz) $
@@ -375,39 +475,37 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
-- writeFastMutInt ix_r (ix + written)
-getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
-getPrim (BinMem _ ix_r sz_r arr_r) size f = do
+getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
+getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do
ix <- readFastMutInt ix_r
- sz <- readFastMutInt sz_r
- when (ix + size > sz) $
+ when (ix + size > sz_r) $
ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
- arr <- readIORef arr_r
- w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)
+ w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)
-- This is safe WRT #17760 as we we guarantee that the above line doesn't
-- diverge
writeFastMutInt ix_r (ix + size)
return w
-putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 :: WriteBinHandle -> Word8 -> IO ()
putWord8 h !w = putPrim h 1 (\op -> poke op w)
-getWord8 :: BinHandle -> IO Word8
+getWord8 :: ReadBinHandle -> IO Word8
getWord8 h = getPrim h 1 peek
-putWord16 :: BinHandle -> Word16 -> IO ()
+putWord16 :: WriteBinHandle -> Word16 -> IO ()
putWord16 h w = putPrim h 2 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
)
-getWord16 :: BinHandle -> IO Word16
+getWord16 :: ReadBinHandle -> IO Word16
getWord16 h = getPrim h 2 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
return $! w0 `shiftL` 8 .|. w1
)
-putWord32 :: BinHandle -> Word32 -> IO ()
+putWord32 :: WriteBinHandle -> Word32 -> IO ()
putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
@@ -415,7 +513,7 @@ putWord32 h w = putPrim h 4 (\op -> do
pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
)
-getWord32 :: BinHandle -> IO Word32
+getWord32 :: ReadBinHandle -> IO Word32
getWord32 h = getPrim h 4 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -428,7 +526,7 @@ getWord32 h = getPrim h 4 (\op -> do
w3
)
-putWord64 :: BinHandle -> Word64 -> IO ()
+putWord64 :: WriteBinHandle -> Word64 -> IO ()
putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
@@ -440,7 +538,7 @@ putWord64 h w = putPrim h 8 (\op -> do
pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
)
-getWord64 :: BinHandle -> IO Word64
+getWord64 :: ReadBinHandle -> IO Word64
getWord64 h = getPrim h 8 (\op -> do
w0 <- fromIntegral <$> peekElemOff op 0
w1 <- fromIntegral <$> peekElemOff op 1
@@ -461,10 +559,10 @@ getWord64 h = getPrim h 8 (\op -> do
w7
)
-putByte :: BinHandle -> Word8 -> IO ()
+putByte :: WriteBinHandle -> Word8 -> IO ()
putByte bh !w = putWord8 bh w
-getByte :: BinHandle -> IO Word8
+getByte :: ReadBinHandle -> IO Word8
getByte h = getWord8 h
-- -----------------------------------------------------------------------------
@@ -487,15 +585,15 @@ getByte h = getWord8 h
-- for now.
-- Unsigned numbers
-{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}
-putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()
putULEB128 bh w =
#if defined(DEBUG)
(if w < 0 then panic "putULEB128: Signed number" else id) $
@@ -512,15 +610,15 @@ putULEB128 bh w =
putByte bh byte
go (w `unsafeShiftR` 7)
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}
-getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-}
+getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a
getULEB128 bh =
go 0 0
where
@@ -536,15 +634,15 @@ getULEB128 bh =
return $! val
-- Signed numbers
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}
-{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}
-putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
+{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
+putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 bh initial = go initial
where
go :: a -> IO ()
@@ -564,15 +662,15 @@ putSLEB128 bh initial = go initial
unless done $ go val'
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}
-{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}
-getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}
+{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}
+getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a
getSLEB128 bh = do
(val,shift,signed) <- go 0 0
if signed && (shift < finiteBitSize val )
@@ -983,63 +1081,74 @@ instance Binary (Bin a) where
-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B
-- by using a forward reference
-forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)
+forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut bh put_A put_B = do
-- write placeholder pointer to A
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a
-- write B
r_b <- put_B
-- update A's pointer
- a <- tellBin bh
+ a <- tellBinWriter bh
putAt bh pre_a a
- seekBinNoExpand bh a
+ seekBinNoExpandWriter bh a
-- write A
r_a <- put_A r_b
pure (r_a,r_b)
-forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()
+forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B
-- | Read a value stored using a forward reference
-forwardGet :: BinHandle -> IO a -> IO a
+forwardGet :: ReadBinHandle -> IO a -> IO a
forwardGet bh get_A = do
-- read forward reference
p <- get bh -- a BinPtr
-- store current position
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
-- go read the forward value, then seek back
- seekBinNoExpand bh p
+ seekBinReader bh p
r <- get_A
- seekBinNoExpand bh p_a
+ seekBinReader bh p_a
pure r
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
-lazyPut :: Binary a => BinHandle -> a -> IO ()
-lazyPut bh a = do
+lazyPut :: Binary a => WriteBinHandle -> a -> IO ()
+lazyPut = lazyPut' put_
+
+lazyGet :: Binary a => ReadBinHandle -> IO a
+lazyGet = lazyGet' Nothing (\_ -> get)
+
+lazyPut' :: HasCallStack => (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
+lazyPut' f bh a = do
-- output the obj with a ptr to skip over it:
- pre_a <- tellBin bh
+ pre_a <- tellBinWriter bh
put_ bh pre_a -- save a slot for the ptr
- put_ bh a -- dump the object
- q <- tellBin bh -- q = ptr to after object
+ f bh a -- dump the object
+ q <- tellBinWriter bh -- q = ptr to after object
putAt bh pre_a q -- fill in slot before a with ptr to q
- seekBin bh q -- finally carry on writing at q
+ seekBinWriter bh q -- finally carry on writing at q
-lazyGet :: Binary a => BinHandle -> IO a
-lazyGet bh = do
+lazyGet' :: HasCallStack => Maybe (IORef ReadBinHandle) -> (Bin () -> ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
+lazyGet' mbh f bh = do
p <- get bh -- a BinPtr
- p_a <- tellBin bh
+ p_a <- tellBinReader bh
+ -- Do this before to avoid retaining reference to old BH inside the unsafeInterleaveIO.
+ let !get_inner_bh = maybe (pure bh) readIORef mbh
a <- unsafeInterleaveIO $ do
- -- NB: Use a fresh off_r variable in the child thread, for thread
+ -- NB: Use a fresh rbm_off_r variable in the child thread, for thread
-- safety.
+ inner_bh <- get_inner_bh
off_r <- newFastMutInt 0
- getAt bh { _off_r = off_r } p_a
- seekBin bh p -- skip over the object for now
+ let bh' = inner_bh { rbm_off_r = off_r }
+ seekBinReader bh' p_a
+ f p bh'
+ seekBinReader bh p -- skip over the object for now
return a
-- | Serialize the constructor strictly but lazily serialize a value inside a
@@ -1047,14 +1156,14 @@ lazyGet bh = do
--
-- This way we can check for the presence of a value without deserializing the
-- value itself.
-lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO ()
+lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()
lazyPutMaybe bh Nothing = putWord8 bh 0
lazyPutMaybe bh (Just x) = do
putWord8 bh 1
lazyPut bh x
-- | Deserialize a value serialized by 'lazyPutMaybe'.
-lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)
+lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)
lazyGetMaybe bh = do
h <- getWord8 bh
case h of
@@ -1065,7 +1174,9 @@ lazyGetMaybe bh = do
-- UserData
-- -----------------------------------------------------------------------------
--- | Information we keep around during interface file
+-- Note [Binary UserData]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- Information we keep around during interface file
-- serialization/deserialization. Namely we keep the functions for serializing
-- and deserializing 'Name's and 'FastString's. We do this because we actually
-- use serialization in two distinct settings,
@@ -1084,73 +1195,283 @@ lazyGetMaybe bh = do
-- non-binding Name is serialized as the fingerprint of the thing they
-- represent. See Note [Fingerprinting IfaceDecls] for further discussion.
--
-data UserData =
- UserData {
- -- for *deserialising* only:
- ud_get_name :: BinHandle -> IO Name,
- ud_get_fs :: BinHandle -> IO FastString,
-
- -- for *serialising* only:
- ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
- -- ^ serialize a non-binding 'Name' (e.g. a reference to another
- -- binding).
- ud_put_binding_name :: BinHandle -> Name -> IO (),
- -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
- ud_put_fs :: BinHandle -> FastString -> IO ()
+
+-- | Newtype to serialise binding names differently to non-binding 'Name'.
+-- See Note [Binary UserData]
+newtype BindingName = BindingName { getBindingName :: Name }
+ deriving ( Eq )
+
+simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName
+simpleBindingNameWriter = coerce
+
+simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName
+simpleBindingNameReader = coerce
+
+-- | Existential for 'BinaryWriter' with a type witness.
+data SomeBinaryWriter = forall a . SomeBinaryWriter TypeRep (BinaryWriter a)
+
+-- | Existential for 'BinaryReader' with a type witness.
+data SomeBinaryReader = forall a . SomeBinaryReader TypeRep (BinaryReader a)
+
+-- | UserData required to serialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data WriterUserData =
+ WriterUserData {
+ ud_writer_data :: Map TypeRep SomeBinaryWriter
+ -- ^ A mapping from a type witness to the 'Writer' for the associated type.
+ -- This is a 'Map' because microbenchmarks indicated this is more efficient
+ -- than other representations for less than ten elements.
+ --
+ -- Considered representations:
+ --
+ -- * [(TypeRep, SomeBinaryWriter)]
+ -- * bytehash (on hackage)
+ -- * Map TypeRep SomeBinaryWriter
+ }
+
+-- | UserData required to deserialise symbols for interface files.
+--
+-- See Note [Binary UserData]
+data ReaderUserData =
+ ReaderUserData {
+ ud_reader_data :: Map TypeRep SomeBinaryReader
+ -- ^ A mapping from a type witness to the 'Reader' for the associated type.
+ -- This is a 'Map' because microbenchmarks indicated this is more efficient
+ -- than other representations for less than ten elements.
+ --
+ -- Considered representations:
+ --
+ -- * [(TypeRep, SomeBinaryReader)]
+ -- * bytehash (on hackage)
+ -- * Map TypeRep SomeBinaryReader
}
-newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
- -> (BinHandle -> IO FastString)
- -> UserData
-newReadState get_name get_fs
- = UserData { ud_get_name = get_name,
- ud_get_fs = get_fs,
- ud_put_nonbinding_name = undef "put_nonbinding_name",
- ud_put_binding_name = undef "put_binding_name",
- ud_put_fs = undef "put_fs"
- }
-
-newWriteState :: (BinHandle -> Name -> IO ())
+mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData
+mkWriterUserData caches = noWriterUserData
+ { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (typRep, cache)) caches
+ }
+
+mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData
+mkReaderUserData caches = noReaderUserData
+ { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (typRep, cache)) caches
+ }
+
+mkSomeBinaryWriter :: forall a . Typeable a => BinaryWriter a -> SomeBinaryWriter
+mkSomeBinaryWriter cb = SomeBinaryWriter (typeRep (Proxy :: Proxy a)) cb
+
+mkSomeBinaryReader :: forall a . Typeable a => BinaryReader a -> SomeBinaryReader
+mkSomeBinaryReader cb = SomeBinaryReader (typeRep (Proxy :: Proxy a)) cb
+
+data BinaryReader s = BinaryReader
+ { getEntry :: ReadBinHandle -> IO s
+ } deriving (Functor)
+
+data BinaryWriter s = BinaryWriter
+ { putEntry :: WriteBinHandle -> s -> IO ()
+ }
+
+mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
+mkWriter f = BinaryWriter
+ { putEntry = f
+ }
+
+mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s
+mkReader f = BinaryReader
+ { getEntry = f
+ }
+
+-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.
+--
+-- If no 'BinaryReader' has been configured before, this function will panic.
+findUserDataReader :: forall a . (HasCallStack, Typeable a) => Proxy a -> ReadBinHandle -> BinaryReader a
+findUserDataReader query bh =
+ case Map.lookup (typeRep query) (ud_reader_data $ getReaderUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (typeRep query)
+ Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
+ unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader
+
+-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'.
+--
+-- If no 'BinaryWriter' has been configured before, this function will panic.
+findUserDataWriter :: forall a . (HasCallStack, Typeable a) => Proxy a -> WriteBinHandle -> BinaryWriter a
+findUserDataWriter query bh =
+ case Map.lookup (typeRep query) (ud_writer_data $ getWriterUserData bh) of
+ Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (typeRep query)
+ Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) ->
+ unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer
+
+noReaderUserData :: ReaderUserData
+noReaderUserData = ReaderUserData
+ { ud_reader_data = Map.empty
+ }
+
+noWriterUserData :: WriterUserData
+noWriterUserData = WriterUserData
+ { ud_writer_data = Map.empty
+ }
+
+newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's
+ -> (ReadBinHandle -> IO FastString)
+ -> ReaderUserData
+newReadState get_name get_fs =
+ mkReaderUserData
+ [ mkSomeBinaryReader $ mkReader get_name
+ , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name)
+ , mkSomeBinaryReader $ mkReader get_fs
+ ]
+
+newWriteState :: (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize non-binding 'Name's
- -> (BinHandle -> Name -> IO ())
+ -> (WriteBinHandle -> Name -> IO ())
-- ^ how to serialize binding 'Name's
- -> (BinHandle -> FastString -> IO ())
- -> UserData
-newWriteState put_nonbinding_name put_binding_name put_fs
- = UserData { ud_get_name = undef "get_name",
- ud_get_fs = undef "get_fs",
- ud_put_nonbinding_name = put_nonbinding_name,
- ud_put_binding_name = put_binding_name,
- ud_put_fs = put_fs
- }
-
-noUserData :: UserData
-noUserData = UserData
- { ud_get_name = undef "get_name"
- , ud_get_fs = undef "get_fs"
- , ud_put_nonbinding_name = undef "put_nonbinding_name"
- , ud_put_binding_name = undef "put_binding_name"
- , ud_put_fs = undef "put_fs"
+ -> (WriteBinHandle -> FastString -> IO ())
+ -> WriterUserData
+newWriteState put_non_binding_name put_binding_name put_fs =
+ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name))
+ , mkSomeBinaryWriter $ mkWriter put_non_binding_name
+ , mkSomeBinaryWriter $ mkWriter put_fs
+ ]
+
+-- ----------------------------------------------------------------------------
+-- Types for lookup and deduplication tables.
+-- ----------------------------------------------------------------------------
+
+data ReaderTable a = ReaderTable
+ { getTable :: ReadBinHandle -> IO (SymbolTable a)
+ , mkReaderFromTable :: SymbolTable a -> BinaryReader a
}
-undef :: String -> a
-undef s = panic ("Binary.UserData: no " ++ s)
+data WriterTable = WriterTable
+ { putTable :: WriteBinHandle -> IO Int
+ }
+
+-- ----------------------------------------------------------------------------
+-- Common data structures for constructing and maintaining lookup tables for
+-- binary serialisation and deserialisation.
+-- ----------------------------------------------------------------------------
+
+data GenericSymbolTable m = GenericSymbolTable
+ { gen_symtab_next :: !FastMutInt
+ -- ^ The next index to use
+ , gen_symtab_map :: !(IORef (m Int))
+ -- ^ Given a symbol, find the symbol
+ , gen_symtab_to_write :: !(IORef [Key m])
+ -- ^ Reversed list of values to write into the buffer
+ }
+
+initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m)
+initGenericSymbolTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef emptyTM
+ symtab_todo <- newIORef []
+ pure $ GenericSymbolTable
+ { gen_symtab_next = symtab_next
+ , gen_symtab_map = symtab_map
+ , gen_symtab_to_write = symtab_todo
+ }
+
+{-# INLINE putGenericSymbolTable #-}
+putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int
+putGenericSymbolTable gen_sym_tab serialiser bh = do
+ putGenericSymbolTable bh
+ where
+ symtab_next = gen_symtab_next gen_sym_tab
+ symtab_to_write = gen_symtab_to_write gen_sym_tab
+ putGenericSymbolTable :: HasCallStack => WriteBinHandle -> IO Int
+ putGenericSymbolTable bh = do
+ let loop = do
+ vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a))
+ case vs of
+ [] -> readFastMutInt symtab_next
+ todo -> do
+ mapM_ (\n -> serialiser bh n) (reverse todo)
+ loop
+ snd <$>
+ (forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
+ loop)
+
+getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bh = do
+ sz <- forwardGet bh (get bh) :: IO Int
+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
+ -- Using lazyPut/lazyGet is quite space inefficient as each usage will allocate a large closure
+ -- (6 arguments-ish).
+ forM_ [0..(sz-1)] $ \i -> do
+ f <- lazyGet' Nothing (\_ -> deserialiser) bh
+ -- f <- deserialiser bh
+ writeArray mut_arr i f
+ unsafeFreeze mut_arr
+
+{-# INLINE putGenericSymTab #-}
+putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
+putGenericSymTab GenericSymbolTable{
+ gen_symtab_map = symtab_map_ref,
+ gen_symtab_next = symtab_next,
+ gen_symtab_to_write = symtab_todo }
+ bh val = do
+ symtab_map <- readIORef symtab_map_ref
+ case lookupTM val symtab_map of
+ Just off -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! insertTM val off symtab_map
+ atomicModifyIORef symtab_todo (\todo -> (val : todo, ()))
+ put_ bh (fromIntegral off :: Word32)
+
+getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a
+getGenericSymtab symtab bh = do
+ i :: Word32 <- get bh
+ return $! symtab ! fromIntegral i
---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------
-type Dictionary = Array Int FastString -- The dictionary
- -- Should be 0-indexed
+-- | A 'SymbolTable' of 'FastString's.
+type Dictionary = SymbolTable FastString
+
+initFastStringReaderTable :: IO (ReaderTable FastString)
+initFastStringReaderTable = do
+ return $
+ ReaderTable
+ { getTable = getDictionary
+ , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl)
+ }
+
+initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)
+initFastStringWriterTable = do
+ dict_next_ref <- newFastMutInt 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict =
+ FSTable
+ { fs_tab_next = dict_next_ref
+ , fs_tab_map = dict_map_ref
+ }
+ let put_dict bh = do
+ fs_count <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
+ putDictionary bh fs_count dict_map
+ pure fs_count
+
+ return
+ ( WriterTable
+ { putTable = put_dict
+ }
+ , mkWriter $ putDictFastString bin_dict
+ )
-putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
+putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary bh sz dict = do
put_ bh sz
mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
-- It's OK to use nonDetEltsUFM here because the elements have indices
-- that array uses to create order
-getDictionary :: BinHandle -> IO Dictionary
+getDictionary :: ReadBinHandle -> IO Dictionary
getDictionary bh = do
sz <- get bh :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
@@ -1159,34 +1480,12 @@ getDictionary bh = do
writeArray mut_arr i fs
unsafeFreeze mut_arr
-getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
-
-initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
-initFSTable bh = do
- dict_next_ref <- newFastMutInt 0
- dict_map_ref <- newIORef emptyUFM
- let bin_dict = FSTable
- { fs_tab_next = dict_next_ref
- , fs_tab_map = dict_map_ref
- }
- let put_dict = do
- fs_count <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh fs_count dict_map
- pure fs_count
-
- -- BinHandle with FastString writing support
- let ud = getUserData bh
- let ud_fs = ud { ud_put_fs = putDictFastString bin_dict }
- let bh_fs = setUserData bh ud_fs
-
- return (bh_fs,bin_dict,put_dict)
-
-putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
+putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: FSTable -> FastString -> IO Word32
@@ -1215,43 +1514,42 @@ data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use
-- The Symbol Table
---------------------------------------------------------
--- On disk, the symbol table is an array of IfExtName, when
--- reading it in we turn it into a SymbolTable.
-
-type SymbolTable = Array Int Name
+-- | Symbols that are read from disk.
+-- The 'SymbolTable' index starts on '0'.
+type SymbolTable a = Array Int a
---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------
-putFS :: BinHandle -> FastString -> IO ()
+putFS :: WriteBinHandle -> FastString -> IO ()
putFS bh fs = putBS bh $ bytesFS fs
-getFS :: BinHandle -> IO FastString
+getFS :: ReadBinHandle -> IO FastString
getFS bh = do
l <- get bh :: IO Int
getPrim bh l (\src -> pure $! mkFastStringBytes src l )
-- | Put a ByteString without its length (can't be read back without knowing the
-- length!)
-putByteString :: BinHandle -> ByteString -> IO ()
+putByteString :: WriteBinHandle -> ByteString -> IO ()
putByteString bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-- | Get a ByteString whose length is known
-getByteString :: BinHandle -> Int -> IO ByteString
+getByteString :: ReadBinHandle -> Int -> IO ByteString
getByteString bh l =
BS.create l $ \dest -> do
getPrim bh l (\src -> copyBytes dest src l)
-putBS :: BinHandle -> ByteString -> IO ()
+putBS :: WriteBinHandle -> ByteString -> IO ()
putBS bh bs =
BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
put_ bh l
putPrim bh l (\op -> copyBytes op (castPtr ptr) l)
-getBS :: BinHandle -> IO ByteString
+getBS :: ReadBinHandle -> IO ByteString
getBS bh = do
l <- get bh :: IO Int
BS.create l $ \dest -> do
@@ -1263,12 +1561,12 @@ instance Binary ByteString where
instance Binary FastString where
put_ bh f =
- case getUserData bh of
- UserData { ud_put_fs = put_fs } -> put_fs bh f
+ case findUserDataWriter (Proxy :: Proxy FastString) bh of
+ tbl -> putEntry tbl bh f
get bh =
- case getUserData bh of
- UserData { ud_get_fs = get_fs } -> get_fs bh
+ case findUserDataReader (Proxy :: Proxy FastString) bh of
+ tbl -> getEntry tbl bh
deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString
=====================================
compiler/GHC/Utils/Binary/Typeable.hs
=====================================
@@ -35,7 +35,7 @@ instance Binary TyCon where
get bh =
mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-getSomeTypeRep :: BinHandle -> IO SomeTypeRep
+getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep
getSomeTypeRep bh = do
tag <- get bh :: IO Word8
case tag of
@@ -167,7 +167,7 @@ instance Binary TypeLitSort where
2 -> pure TypeLitChar
_ -> fail "Binary.putTypeLitSort: invalid tag"
-putTypeRep :: BinHandle -> TypeRep a -> IO ()
+putTypeRep :: WriteBinHandle -> TypeRep a -> IO ()
putTypeRep bh rep -- Handle Type specially since it's so common
| Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
= put_ bh (0 :: Word8)
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -78,6 +78,7 @@ import Data.Eq
import Data.Bool
import Data.Char
import Prelude (Integer, length)
+import Data.Ord (Ord)
{-
************************************************************************
@@ -91,7 +92,7 @@ import Prelude (Integer, length)
data PromotionFlag
= NotPromoted
| IsPromoted
- deriving ( Eq, Data )
+ deriving ( Eq, Data, Ord )
isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True
=====================================
compiler/Language/Haskell/Syntax/Type.hs-boot
=====================================
@@ -2,6 +2,7 @@ module Language.Haskell.Syntax.Type where
import Data.Bool
import Data.Eq
+import Data.Ord
{-
************************************************************************
@@ -17,5 +18,6 @@ data PromotionFlag
| IsPromoted
instance Eq PromotionFlag
+instance Ord PromotionFlag
isPromoted :: PromotionFlag -> Bool
=====================================
compiler/ghc.cabal.in
=====================================
@@ -579,6 +579,7 @@ Library
GHC.Iface.Tidy.StaticPtrTable
GHC.IfaceToCore
GHC.Iface.Type
+ GHC.Iface.Type.Map
GHC.JS.Ident
GHC.JS.Make
GHC.JS.Optimizer
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 504d4c1842db93704b4c5e158ecc3af7050ba9fe
+Subproject commit 0b64da5b51dac5124b6516af1c402a83ca9d0a0d
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd21cc372e4a7d3783607896a66736019b9bcb21...829f88c9c22a96d48e121b4769924c7a6ef63e28
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd21cc372e4a7d3783607896a66736019b9bcb21...829f88c9c22a96d48e121b4769924c7a6ef63e28
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240410/a98de102/attachment-0001.html>
More information about the ghc-commits
mailing list