Add machinery for plugins to write data to extensible interface fields

4 files changed, 27 insertions, 7 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 42e9a35724..526123c3cb 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -198,6 +198,7 @@ newHscEnv dflags = do
     us      <- mkSplitUniqSupply 'r'
     nc_var  <- newIORef (initNameCache us knownKeyNames)
     fc_var  <- newIORef emptyInstalledModuleEnv
+    ext_fs  <- newIORef emptyExtensibleFields
     emptyDynLinker <- uninitializedLinker
     return HscEnv {  hsc_dflags       = dflags
                   ,  hsc_targets      = []
@@ -207,6 +208,7 @@ newHscEnv dflags = do
                   ,  hsc_EPS          = eps_var
                   ,  hsc_NC           = nc_var
                   ,  hsc_FC           = fc_var
+                  ,  hsc_ext_fields   = ext_fs
                   ,  hsc_type_env_var = Nothing
                   ,  hsc_interp       = Nothing
                   ,  hsc_dynLinker    = emptyDynLinker
@@ -810,11 +812,10 @@ finish summary tc_result mb_old_hash = do
           (cg_guts, details) <- {-# SCC "CoreTidy" #-}
               liftIO $ tidyProgram hsc_env simplified_guts
 
-          let !partial_iface =
-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
+          !partial_iface <- {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
                 -- This `force` saves 2M residency in test T10370
                 -- See Note [Avoiding space leaks in toIface*] for details.
-                force (mkPartialIface hsc_env details simplified_guts)
+                liftIO $ force <$> (mkPartialIface hsc_env details simplified_guts)
 
           return HscRecomp { hscs_guts = cg_guts,
                              hscs_mod_location = ms_location summary,
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 4029ab1c2c..93a7ac1b4d 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -155,6 +155,7 @@ module GHC.Driver.Types (
         readField, readIfaceField, readIfaceFieldWith,
         writeField, writeIfaceField, writeIfaceFieldWith,
         deleteField, deleteIfaceField,
+        registerInterfaceData, registerInterfaceDataWith,
     ) where
 
 #include "HsVersions.h"
@@ -475,6 +476,10 @@ data HscEnv
         hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),
                 -- ^ The cached result of performing finding in the file system
 
+        hsc_ext_fields :: {-# UNPACK #-} !(IORef ExtensibleFields),
+                -- ^ Extensible interface field data stored by plugins to be later
+                -- output in the `.hi` file.
+
         hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
                 -- ^ Used for one-shot compilation only, to initialise
                 -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for
@@ -3404,3 +3409,12 @@ 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) }
+
+registerInterfaceData :: Binary a => FieldName -> HscEnv -> a -> IO ()
+registerInterfaceData name env x = registerInterfaceDataWith name env (`put_` x)
+
+registerInterfaceDataWith :: FieldName -> HscEnv -> (BinHandle -> IO ()) -> IO ()
+registerInterfaceDataWith name env write = do
+  ext_fs  <- readIORef (hsc_ext_fields env)
+  ext_fs' <- writeFieldWith name write ext_fs
+  writeIORef (hsc_ext_fields env) ext_fs'
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 59c93ef95c..e082c0a7b6 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -82,7 +82,7 @@ import GHC.Driver.Plugins (LoadedPlugin(..))
 mkPartialIface :: HscEnv
                -> ModDetails
                -> ModGuts
-               -> PartialModIface
+               -> IO PartialModIface
 mkPartialIface hsc_env mod_details
   ModGuts{ mg_module       = this_mod
          , mg_hsc_src      = hsc_src
@@ -99,8 +99,11 @@ mkPartialIface hsc_env mod_details
          , mg_decl_docs    = decl_docs
          , mg_arg_docs     = arg_docs
          }
-  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
-             safe_mode usages doc_hdr decl_docs arg_docs mod_details
+  = do ext_fs <- readIORef $ hsc_ext_fields hsc_env
+       return iface{mi_ext_fields = ext_fs}
+    where
+      iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
+                       safe_mode usages doc_hdr decl_docs arg_docs mod_details
 
 -- | Fully instantiate an interface. Adds fingerprints and potentially code
 -- generator produced information.
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 9f8ba03bc1..b772f93593 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -20,7 +20,9 @@ module GHC.IfaceToCore (
         tcIfaceAnnotations, tcIfaceCompleteSigs,
         tcIfaceExpr,    -- Desired by HERMIT (#7683)
         tcIfaceGlobal,
-        tcIfaceOneShot
+        tcIfaceOneShot,
+        tcIfaceType,
+        tcJoinInfo,
  ) where
 
 #include "HsVersions.h"