-- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader ( initializePlugins, initializeSessionPlugins, -- * Loading plugins loadFrontendPlugin, -- * Force loading information forceLoadModuleInterfaces, forceLoadNameModuleInterface, forceLoadTyCon, -- * Finding names lookupRdrNameInModuleForPlugins, -- * Loading values getValueSafely, getHValueSafely, lessUnsafeCoerce ) where import GHC.Prelude import GHC.Data.FastString import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins import GHC.Driver.Plugins.External import GHC.Linker.Loader ( loadModule, loadName ) import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types import GHC.Rename.Names ( gresFromAvails ) import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, mkTyConTy ) import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon ( TyCon(tyConName) ) import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit) ) import GHC.Unit.Module.ModIface import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Utils.Misc ( HasDebugCallStack ) 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 Data.List (unzip4) import GHC.Iface.Errors.Ppr import GHC.Driver.Monad {- Note [Timing of plugin initialization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Plugins needs to be initialised as soon as possible in the pipeline. This is because driver plugins are executed immediately after being loaded, which can modify anything in the HscEnv, including the logger and DynFlags (for example #21279). For example, in ghc/Main.hs the logger is used almost immediately after the session has been initialised and so if a user overwrites the logger expecting all output to go there then unless the plugins are initialised before that point then unexpected things will happen. We initialise plugins in ghc/Main.hs for the main ghc executable. When people are using the GHC API, they also need to initialise plugins at the highest level possible for things to work as expected. We keep some defensive calls to plugin initialisation in functions like `load'` and `oneshot` to catch cases where API users have not initialised their own plugins. In addition to this, there needs to be an initialisation call for each module just in case the user has enabled a plugin just for that module using OPTIONS_GHC pragma. -} -- | Initialise plugins specified by the current DynFlags and update the session. initializeSessionPlugins :: GhcMonad m => m () initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. initializePlugins :: HscEnv -> IO HscEnv initializePlugins hsc_env -- check that plugin specifications didn't change -- dynamic plugins | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env) , map lpModuleName loaded_plugins == reverse (pluginModNames dflags) , all same_args loaded_plugins -- external plugins , external_plugins <- externalPlugins (hsc_plugins hsc_env) , check_external_plugins external_plugins (externalPluginSpecs dflags) -- FIXME: we should check static plugins too = return hsc_env -- no change, no need to reload plugins | otherwise = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env external_plugins <- loadExternalPlugins (externalPluginSpecs dflags) let plugins' = (hsc_plugins hsc_env) { staticPlugins = staticPlugins (hsc_plugins hsc_env) , externalPlugins = external_plugins , loadedPlugins = loaded_plugins , loadedPluginDeps = (links, pkgs) } let hsc_env' = hsc_env { hsc_plugins = plugins' } withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env' where dflags = hsc_dflags hsc_env -- dynamic plugins plugin_args = pluginModNameOpts dflags same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) -- external plugins check_external_plugin p spec = and [ epUnit p == esp_unit_id spec , epModule p == esp_module spec , paArguments (epPlugin p) == esp_args spec ] check_external_plugins eps specs = case (eps,specs) of ([] , []) -> True (_ , []) -> False -- some external plugin removed ([] , _ ) -> False -- some external plugin added (p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss 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' (mkVarOccFS (fsLit "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' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName hsc_env mod_name return (plugin, links, pkgs) -- #14335 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 ; case thisGhcUnit == (moduleUnit . nameModule . tyConName) plugin_tycon of { False -> throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep [ text "The plugin module", ppr mod_name , text "was built with a compiler that is incompatible with the one loading it" ]) ; True -> do { 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) } } } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () forceLoadModuleInterfaces hsc_env doc modules = (initTcInteractive hsc_env $ initIfaceTcRn $ mapM_ (loadPluginInterface doc) modules) >> return () -- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () forceLoadNameModuleInterface hsc_env reason name = do let name_modules = mapMaybe nameModule_maybe [name] forceLoadModuleInterfaces hsc_env reason name_modules -- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: -- -- * The interface could not be loaded -- * The name is not that of a 'TyCon' -- * The name did not exist in the loaded module 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 -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! -- -- If the value found was not of the correct type, returns @Left @. Any other condition results in an exception: -- -- * If we could not load the names module -- * If the thing being loaded is not a value -- * If the Name does not exist in the module -- * If the link failed 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 -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupType hsc_env val_name case mb_val_thing of Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do -- Check the value type in the interface against the type recovered from the type constructor -- before finally casting the value to the type we assume corresponds to that constructor if expected_type `eqType` idType id then do -- Link in the module that contains the value, if it has such a module case nameModule_maybe val_name of Just mod -> do loadModule interp hsc_env mod return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type 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 -- | Coerce a value as usual, but: -- -- 1) Evaluate it immediately to get a segfault early if the coercion was wrong -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened -- if it /does/ segfault 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 -- | Finds the 'Name' corresponding to the given 'RdrName' in the -- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' -- could be found. Any other condition results in an exception: -- -- * If the module could not be found -- * If we could not determine the imports of the module -- -- Can only be used for looking up names while loading plugins (and is -- *not* suitable for use within plugins). The interface file is -- loaded very partially: just enough that it can be used, without its -- rules and instances affecting (and being linked from!) the module -- being compiled. This was introduced by 57d6798. -- -- Need the module as well to record information in the interface file lookupRdrNameInModuleForPlugins :: HasDebugCallStack => 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 -- First find the unit the module resides in by searching exposed units and home modules found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module (_, mb_iface) <- initTcInteractive hsc_env $ initIfaceTcRn $ loadPluginInterface doc mod case mb_iface of Just iface -> do -- Try and find the required name in the exports let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name , is_qual = False, is_dloc = noSrcSpan } imp_spec = ImpSpec decl_spec ImpAll env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) case lookupGRE env (LookupRdrName rdr_name (RelevantGREsFOS WantNormal)) of [gre] -> return (Just (greName gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] err -> let opts = initIfaceMessageOpts dflags err_txt = missingInterfaceErrorDiagnostic opts $ cannotFindModule hsc_env mod_name err in throwCmdLineErrorS dflags err_txt 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