[Git][ghc/ghc][wip/extensible-interface-files] Implement extensible interface files
Josh Meredith
gitlab at gitlab.haskell.org
Fri Apr 10 11:15:08 UTC 2020
Josh Meredith pushed to branch wip/extensible-interface-files at Glasgow Haskell Compiler / GHC
Commits:
b03ae53c by Josh Meredith at 2020-04-10T21:13:39+10:00
Implement extensible interface files
- - - - -
8 changed files:
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/utils/Binary.hs
- docs/users_guide/extending_ghc.rst
- testsuite/tests/showIface/DocsInHiFile0.stdout
- testsuite/tests/showIface/DocsInHiFile1.stdout
Changes:
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -147,7 +147,14 @@ module GHC.Driver.Types (
-- * COMPLETE signature
CompleteMatch(..), CompleteMatchMap,
- mkCompleteMatchMap, extendCompleteMatchMap
+ mkCompleteMatchMap, extendCompleteMatchMap,
+
+ -- * Exstensible Iface fields
+ ExtensibleFields(..), FieldName,
+ emptyExtensibleFields,
+ readField, readIfaceField, readIfaceFieldWith,
+ writeField, writeIfaceField, writeIfaceFieldWith,
+ deleteField, deleteIfaceField,
) where
#include "HsVersions.h"
@@ -215,8 +222,10 @@ import GHC.Serialized ( Serialized )
import qualified GHC.LanguageExtensions as LangExt
import Foreign
-import Control.Monad ( guard, liftM, ap )
+import Control.Monad ( guard, liftM, ap, forM, forM_, replicateM )
import Data.IORef
+import Data.Map ( Map )
+import qualified Data.Map as Map
import Data.Time
import Exception
import System.FilePath
@@ -1090,9 +1099,17 @@ data ModIface_ (phase :: ModIfacePhase)
mi_arg_docs :: ArgDocMap,
-- ^ Docs on arguments.
- mi_final_exts :: !(IfaceBackendExts phase)
+ mi_final_exts :: !(IfaceBackendExts phase),
-- ^ Either `()` or `ModIfaceBackend` for
-- a fully instantiated interface.
+
+ mi_ext_fields :: ExtensibleFields
+ -- ^ Additional optional fields, where the Map key represents
+ -- the field name, resulting in a (size, serialized data) pair.
+ -- Because the data is intended to be serialized through the
+ -- internal `Binary` class (increasing compatibility with types
+ -- using `Name` and `FastString`, such as HIE), this format is
+ -- chosen over `ByteString`s.
}
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -1164,6 +1181,9 @@ instance Binary ModIface where
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
+ mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we
+ -- can deal with it's pointer in the header
+ -- when we write the actual file
mi_final_exts = ModIfaceBackend {
mi_iface_hash = iface_hash,
mi_mod_hash = mod_hash,
@@ -1264,6 +1284,8 @@ instance Binary ModIface where
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
+ mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt
+ -- with specially when the file is read
mi_final_exts = ModIfaceBackend {
mi_iface_hash = iface_hash,
mi_mod_hash = mod_hash,
@@ -1307,7 +1329,9 @@ emptyPartialModIface mod
mi_doc_hdr = Nothing,
mi_decl_docs = emptyDeclDocMap,
mi_arg_docs = emptyArgDocMap,
- mi_final_exts = () }
+ mi_final_exts = (),
+ mi_ext_fields = emptyExtensibleFields
+ }
emptyFullModIface :: Module -> ModIface
emptyFullModIface mod =
@@ -3279,7 +3303,105 @@ phaseForeignLanguage phase = case phase of
-- avoid major space leaks.
instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12
- f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) =
+ f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq`
rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23
+ `seq` rnf f24
+
+{-
+************************************************************************
+* *
+\subsection{Extensible Iface Fields}
+* *
+************************************************************************
+-}
+
+type FieldName = String
+
+newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }
+
+instance Binary ExtensibleFields where
+ put_ bh (ExtensibleFields fs) = do
+ put_ bh (Map.size fs :: Int)
+
+ -- Put the names of each field, and reserve a space
+ -- for a payload pointer after each name:
+ header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
+ put_ bh name
+ field_p_p <- tellBin 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
+ putAt bh field_p_p field_p
+ seekBin bh field_p
+ put_ bh dat
+
+ get bh = do
+ n <- get bh :: IO Int
+
+ -- Get the names and field pointers:
+ header_entries <- replicateM n $ do
+ (,) <$> get bh <*> get bh
+
+ -- Seek to and get each field's payload:
+ fields <- forM header_entries $ \(name, field_p) -> do
+ seekBin bh field_p
+ dat <- get bh
+ return (name, dat)
+
+ return . ExtensibleFields . Map.fromList $ fields
+
+instance NFData ExtensibleFields where
+ rnf (ExtensibleFields fs) = rnf fs
+
+emptyExtensibleFields :: ExtensibleFields
+emptyExtensibleFields = ExtensibleFields Map.empty
+
+--------------------------------------------------------------------------------
+-- | Reading
+
+readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)
+readIfaceField name = readIfaceFieldWith name get
+
+readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
+readField name = readFieldWith name get
+
+readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
+readIfaceFieldWith name read iface = readFieldWith name read (mi_ext_fields iface)
+
+readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
+ Map.lookup name (getExtensibleFields fields)
+
+--------------------------------------------------------------------------------
+-- | Writing
+
+writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface
+writeIfaceField name x = writeIfaceFieldWith name (`put_` x)
+
+writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
+writeField name x = writeFieldWith name (`put_` x)
+
+writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface
+writeIfaceFieldWith name write iface = do
+ fields <- writeFieldWith name write (mi_ext_fields iface)
+ return iface{ mi_ext_fields = fields }
+
+writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith name write fields = do
+ bh <- openBinMem (1024 * 1024)
+ write bh
+ --
+ bd <- handleData bh
+ return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
+
+deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
+deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
+
+deleteIfaceField :: FieldName -> ModIface -> ModIface
+deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) }
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -148,7 +148,15 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
- getWithUserData ncu bh
+
+ extFields_p <- get bh
+
+ mod_iface <- getWithUserData ncu bh
+
+ seekBin bh extFields_p
+ extFields <- get bh
+
+ return mod_iface{mi_ext_fields = extFields}
-- | This performs a get action after reading the dictionary and symbol
@@ -200,8 +208,16 @@ writeBinIface dflags hi_path mod_iface = do
let way_descr = getWayDescr dflags
put_ bh way_descr
+ extFields_p_p <- tellBin bh
+ put_ bh extFields_p_p
putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+
+ extFields_p <- tellBin bh
+ putAt bh extFields_p_p extFields_p
+ seekBin bh extFields_p
+ put_ bh (mi_ext_fields mod_iface)
+
-- And send the result to the file
writeBinMem bh hi_path
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Driver.Types
import GHC.Types.Basic hiding (SuccessFlag(..))
import GHC.Tc.Utils.Monad
+import Binary ( BinData(..) )
import Constants
import PrelNames
import PrelInfo
@@ -83,6 +84,7 @@ import GHC.Driver.Plugins
import Control.Monad
import Control.Exception
import Data.IORef
+import Data.Map ( toList )
import System.FilePath
import System.Directory
@@ -1159,6 +1161,7 @@ pprModIface iface at ModIface{ mi_final_exts = exts }
, text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
, text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
, text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
+ , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
]
where
pp_hsc_src HsBootFile = text "[boot]"
@@ -1248,6 +1251,11 @@ pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> text "annotated by" <+> ppr serialized
+pprExtensibleFields :: ExtensibleFields -> SDoc
+pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
+ where
+ pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
+
{-
*********************************************************
* *
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -268,7 +268,8 @@ mkIface_ hsc_env
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
- mi_final_exts = () }
+ mi_final_exts = (),
+ mi_ext_fields = emptyExtensibleFields }
where
cmp_rule = comparing ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
=====================================
compiler/utils/Binary.hs
=====================================
@@ -27,6 +27,8 @@ module Binary
{-type-} BinHandle,
SymbolTable, Dictionary,
+ BinData(..), dataHandle, handleData,
+
openBinMem,
-- closeBin,
@@ -73,6 +75,7 @@ import Fingerprint
import GHC.Types.Basic
import GHC.Types.SrcLoc
+import Control.DeepSeq
import Foreign
import Data.Array
import Data.ByteString (ByteString)
@@ -95,6 +98,44 @@ import GHC.Serialized
type BinArray = ForeignPtr Word8
+
+
+---------------------------------------------------------------
+-- BinData
+---------------------------------------------------------------
+
+data BinData = BinData Int BinArray
+
+instance NFData BinData where
+ rnf (BinData sz _) = rnf sz
+
+instance Binary BinData where
+ put_ bh (BinData sz dat) = do
+ put_ bh sz
+ putPrim bh sz $ \dest ->
+ withForeignPtr dat $ \orig ->
+ copyBytes dest orig sz
+ --
+ get bh = do
+ sz <- get bh
+ dat <- mallocForeignPtrBytes sz
+ getPrim bh sz $ \orig ->
+ withForeignPtr dat $ \dest ->
+ copyBytes dest orig sz
+ return (BinData sz dat)
+
+dataHandle :: BinData -> IO BinHandle
+dataHandle (BinData size bin) = do
+ ixr <- newFastMutInt
+ szr <- newFastMutInt
+ writeFastMutInt ixr 0
+ writeFastMutInt szr size
+ binr <- newIORef bin
+ return (BinMem noUserData ixr szr binr)
+
+handleData :: BinHandle -> IO BinData
+handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -749,6 +749,33 @@ NOT be invoked with your own modules.
In the ``ModIface`` datatype you can find lots of useful information, including
the exported definitions and type class instances.
+The ``ModIface`` datatype also contains facilities for extending it with extra
+data, stored in a ``Map`` of serialised fields, indexed by field names and using
+GHC's internal ``Binary`` class. The interface to work with these fields is:
+
+::
+
+ readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)
+ writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface
+ deleteIfaceField :: FieldName -> ModIface -> ModIface
+
+The ``FieldName`` is open-ended, but typically it should contain the producing
+package name, along with the actual field name. Then, the version number can either
+be attached to the serialised data for that field, or in cases where multiple versions
+of a field could exist in the same interface file, included in the field name.
+
+Depending on if the field version advances with the package version, or independently,
+the version can be attached to either the package name or the field name. Examples of
+each case:
+
+::
+
+ package/field
+ ghc-n.n.n/core
+ package/field-n
+
+To read an interface file from an external tool without linking to GHC, the format
+is described at `Extensible Interface Files<https://gitlab.haskell.org/ghc/ghc/wikis/Extensible-Interface-Files>`_.
Source plugin example
^^^^^^^^^^^^^^^^^^^^^
=====================================
testsuite/tests/showIface/DocsInHiFile0.stdout
=====================================
@@ -2,3 +2,4 @@ module header:
Nothing
declaration docs:
arg docs:
+extensible fields:
=====================================
testsuite/tests/showIface/DocsInHiFile1.stdout
=====================================
@@ -33,4 +33,4 @@ arg docs:
p:
0:
" An argument"
-
+extensible fields:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b03ae53c8c455bd665c701fef51bd8813f38e6c9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b03ae53c8c455bd665c701fef51bd8813f38e6c9
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/20200410/effc85ec/attachment-0001.html>
More information about the ghc-commits
mailing list