module GHC.Runtime.Loader (
initializePlugins,
loadFrontendPlugin,
forceLoadModuleInterfaces,
forceLoadNameModuleInterface,
forceLoadTyCon,
lookupRdrNameInModuleForPlugins,
getValueSafely,
getHValueSafely,
lessUnsafeCoerce
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Driver.Plugins
import GHC.Linker.Loader ( loadModule, loadName )
import GHC.Runtime.Interpreter ( wormhole )
import GHC.Runtime.Interpreter.Types
import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn )
import GHC.Iface.Load ( loadPluginInterface, cannotFindModule )
import GHC.Rename.Names ( gresFromAvails )
import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName )
import GHC.Driver.Env
import GHCi.RemoteTypes ( HValue )
import GHC.Core.Type ( Type, eqType, mkTyConTy )
import GHC.Core.TyCon ( TyCon )
import GHC.Types.SrcLoc ( noSrcSpan )
import GHC.Types.Name ( Name, nameModule_maybe )
import GHC.Types.Id ( idType )
import GHC.Types.TyThing
import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )
import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..)
, ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
, greMangledName, mkRdrQual )
import GHC.Unit.Finder ( findPluginModule, FindResult(..) )
import GHC.Driver.Config.Finder ( initFinderOpts )
import GHC.Unit.Module ( Module, ModuleName )
import GHC.Unit.Module.ModIface
import GHC.Unit.Env
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception
import Control.Monad ( unless )
import Data.Maybe ( mapMaybe )
import Unsafe.Coerce ( unsafeCoerce )
import GHC.Linker.Types
import GHC.Types.Unique.DFM
import Data.List (unzip4)
initializePlugins :: HscEnv -> IO HscEnv
initializePlugins hsc_env
| loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)
, map lpModuleName loaded_plugins == reverse (pluginModNames dflags)
, all same_args loaded_plugins
= return hsc_env
| otherwise
= do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env
let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins, loadedPluginDeps = (links, pkgs) }
let hsc_env' = hsc_env { hsc_plugins = plugins' }
withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'
where
plugin_args = pluginModNameOpts dflags
same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args
argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
dflags = hsc_dflags hsc_env
loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins hsc_env
= do { unless (null to_load) $
checkExternalInterpreter hsc_env
; plugins_with_deps <- mapM loadPlugin to_load
; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps
; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)
}
where
dflags = hsc_dflags hsc_env
to_load = reverse $ pluginModNames dflags
attachOptions mod_nm (plug, mod) =
LoadedPlugin (PluginWithArgs plug (reverse options)) mod
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env
loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
(plugin, _iface, links, pkgs)
<- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
hsc_env mod_name
return (plugin, links, pkgs)
checkExternalInterpreter :: HscEnv -> IO ()
checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
Just (ExternalInterp {})
-> throwIO (InstallationError "Plugins require -fno-external-interpreter")
_ -> pure ()
loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
plugin_rdr_name
; case mb_name of {
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ text "The module", ppr mod_name
, text "did not export the plugin name"
, ppr plugin_rdr_name ]) ;
Just (name, mod_iface) ->
do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
; case eith_plugin of
Left actual_type ->
throwGhcExceptionIO (CmdLineError $
showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))
alwaysQualify $ hsep
[ text "The value", ppr name
, text "with type", ppr actual_type
, text "did not have the type"
, text "GHC.Plugins.Plugin"
, text "as required"])
Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } }
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces hsc_env doc modules
= (initTcInteractive hsc_env $
initIfaceTcRn $
mapM_ (loadPluginInterface doc) modules)
>> return ()
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface hsc_env reason name = do
let name_modules = mapMaybe nameModule_maybe [name]
forceLoadModuleInterfaces hsc_env reason name_modules
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
mb_con_thing <- lookupType hsc_env con_name
case mb_con_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
Just (ATyCon tycon) -> return tycon
Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
where dflags = hsc_dflags hsc_env
getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely hsc_env val_name expected_type = do
eith_hval <- case getValueSafelyHook hooks of
Nothing -> getHValueSafely interp hsc_env val_name expected_type
Just h -> h hsc_env val_name expected_type
case eith_hval of
Left actual_type -> return (Left actual_type)
Right (hval, links, pkgs) -> do
value <- lessUnsafeCoerce logger "getValueSafely" hval
return (Right (value, links, pkgs))
where
interp = hscInterp hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
getHValueSafely interp hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
mb_val_thing <- lookupType hsc_env val_name
case mb_val_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
Just (AnId id) -> do
if expected_type `eqType` idType id
then do
case nameModule_maybe val_name of
Just mod -> do loadModule interp hsc_env mod
return ()
Nothing -> return ()
hval <- do
(v, links, pkgs) <- loadName interp hsc_env val_name
hv <- wormhole interp v
return (hv, links, pkgs)
return (Right hval)
else return (Left (idType id))
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
where dflags = hsc_dflags hsc_env
lessUnsafeCoerce :: Logger -> String -> a -> IO b
lessUnsafeCoerce logger context what = do
debugTraceMsg logger 3 $
(text "Coercing a value in") <+> (text context) <> (text "...")
output <- evaluate (unsafeCoerce what)
debugTraceMsg logger 3 (text "Successfully evaluated coercion")
return output
lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
-> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
let fc = hsc_FC hsc_env
let unit_env = hsc_unit_env hsc_env
let unit_state = ue_units unit_env
let mhome_unit = hsc_home_unit_maybe hsc_env
found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
case found_module of
Found _ mod -> do
(_, mb_iface) <- initTcInteractive hsc_env $
initIfaceTcRn $
loadPluginInterface doc mod
case mb_iface of
Just iface -> do
let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
, is_qual = False, is_dloc = noSrcSpan }
imp_spec = ImpSpec decl_spec ImpAll
env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
case lookupGRE_RdrName rdr_name env of
[gre] -> return (Just (greMangledName gre, iface))
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err
where
doc = text "contains a name used in an invocation of lookupRdrNameInModule"
wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing]
missingTyThingError :: Name -> SDoc
missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"]
throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcExceptionIO . CmdLineError