[Git][ghc/ghc][wip/coreField] Add mechanism to write extensible interface data during plugins

[Josh Meredith]

Josh Meredith pushed to branch wip/coreField at Glasgow Haskell Compiler / GHC


Commits:
876e3fe4 by Josh Meredith at 2020-06-15T11:56:46+10:00
Add mechanism to write extensible interface data during plugins

- - - - -


5 changed files:

- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/CoreToByteCode.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Tc/Types.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -612,6 +612,9 @@ instance MonadUnique CoreM where
         mask <- read cr_uniq_mask
         liftIO $! uniqFromMask mask
 
+instance HasHscEnv CoreM where
+  getHscEnv = read cr_hsc_env
+
 runCoreM :: HscEnv
          -> RuleBase
          -> Char -- ^ Mask
@@ -677,9 +680,6 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re
 ************************************************************************
 -}
 
-getHscEnv :: CoreM HscEnv
-getHscEnv = read cr_hsc_env
-
 getRuleBase :: CoreM RuleBase
 getRuleBase = read cr_rule_base
 


=====================================
compiler/GHC/CoreToByteCode.hs
=====================================
@@ -2012,8 +2012,8 @@ instance Monad BcM where
 instance HasDynFlags BcM where
     getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
 
-getHscEnv :: BcM HscEnv
-getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
+instance HasHscEnv BcM where
+    getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
 
 emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -196,6 +196,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      = []
@@ -205,6 +206,7 @@ newHscEnv dflags = do
                   ,  hsc_EPS          = eps_var
                   ,  hsc_NC           = nc_var
                   ,  hsc_FC           = fc_var
+                  ,  hsc_extensible_fields = ext_fs
                   ,  hsc_type_env_var = Nothing
                   ,  hsc_interp       = Nothing
                   ,  hsc_dynLinker    = emptyDynLinker
@@ -221,9 +223,6 @@ clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
 logWarnings :: WarningMessages -> Hsc ()
 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
 
-getHscEnv :: Hsc HscEnv
-getHscEnv = Hsc $ \e w -> return (e, w)
-
 handleWarnings :: Hsc ()
 handleWarnings = do
     dflags <- getDynFlags


=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -22,6 +22,7 @@ module GHC.Driver.Types (
         FinderCache, FindResult(..), InstalledFindResult(..),
         Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,
         HscStatus(..),
+        HasHscEnv(..),
 
         -- * ModuleGraph
         ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG,
@@ -474,6 +475,10 @@ data HscEnv
         hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),
                 -- ^ The cached result of performing finding in the file system
 
+        hsc_extensible_fields :: {-# UNPACK #-} !(IORef ExtensibleFields),
+                -- ^ Extensible interface field data stored by plugins to be 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
@@ -486,8 +491,16 @@ data HscEnv
         , hsc_dynLinker :: DynLinker
                 -- ^ dynamic linker.
 
+
  }
 
+
+class HasHscEnv m where
+  getHscEnv :: m HscEnv
+
+instance HasHscEnv Hsc where
+  getHscEnv = Hsc $ \e w -> return (e, w)
+
 {-
 
 Note [Target code interpreter]
@@ -3432,3 +3445,14 @@ 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, HasHscEnv m, MonadIO m) => FieldName -> a -> m ()
+registerInterfaceData name x = registerInterfaceDataWith name (`put_` x)
+
+registerInterfaceDataWith :: (HasHscEnv m, MonadIO m) => FieldName -> (BinHandle -> IO ()) -> m ()
+registerInterfaceDataWith name write = do
+  env <- getHscEnv
+  let ext_fs_ref = hsc_extensible_fields env
+  liftIO $ do
+    ext_fs  <- readIORef ext_fs_ref
+    ext_fs' <- writeFieldWith name write ext_fs
+    writeIORef ext_fs_ref ext_fs'


=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -5,7 +5,7 @@
 -}
 
 {-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving,
-             ViewPatterns #-}
+             ViewPatterns, FlexibleInstances #-}
 
 -- | Various types used during typechecking.
 --
@@ -194,6 +194,9 @@ type DsM        = TcRnIf DsGblEnv DsLclEnv    -- Desugaring
 -- local environment is 'TcLclEnv', which tracks local information as
 -- we move inside expressions.
 
+instance HasHscEnv (IOEnv (Env a b)) where
+    getHscEnv = env_top <$> getEnv
+
 -- | Historical "renaming monad" (now it's just 'TcRn').
 type RnM  = TcRn
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876e3fe49f7465193e041919f83ec9e8a8872c47

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876e3fe49f7465193e041919f83ec9e8a8872c47
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/20200614/38ad17bc/attachment-0001.html>