diff options
author | Josh Meredith <joshmeredith2008@gmail.com> | 2020-03-23 04:01:05 +1100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-12 11:21:34 -0400 |
commit | 0efaf301fec9ed9ea827392cbe03de3335e995c7 (patch) | |
tree | 9f97a9f99963d42297511a85cfd7c2a4d1e93bad /compiler | |
parent | cd4f92b5f4251f1a37d1e08ee97d99f2ccb41f26 (diff) | |
download | haskell-0efaf301fec9ed9ea827392cbe03de3335e995c7.tar.gz |
Implement extensible interface files
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Driver/Types.hs | 132 | ||||
-rw-r--r-- | compiler/GHC/Iface/Binary.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/Iface/Load.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Iface/Make.hs | 3 | ||||
-rw-r--r-- | compiler/utils/Binary.hs | 41 |
5 files changed, 195 insertions, 7 deletions
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs index 930350608c..d532ef09b0 100644 --- a/compiler/GHC/Driver/Types.hs +++ b/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) } diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 1aa1fdafef..07a9da4c96 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/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 diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index cf881e8f11..2108e84079 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/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@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" + {- ********************************************************* * * diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 677c8cef71..ef9e77b44d 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/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, diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 98d4e5ad56..529519df1d 100644 --- a/compiler/utils/Binary.hs +++ b/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 --------------------------------------------------------------- |