never executed always true always false
    1 
    2 
    3 -- | Dynamically lookup up values from modules and loading them.
    4 module GHC.Runtime.Loader (
    5         initializePlugins,
    6         -- * Loading plugins
    7         loadFrontendPlugin,
    8 
    9         -- * Force loading information
   10         forceLoadModuleInterfaces,
   11         forceLoadNameModuleInterface,
   12         forceLoadTyCon,
   13 
   14         -- * Finding names
   15         lookupRdrNameInModuleForPlugins,
   16 
   17         -- * Loading values
   18         getValueSafely,
   19         getHValueSafely,
   20         lessUnsafeCoerce
   21     ) where
   22 
   23 import GHC.Prelude
   24 
   25 import GHC.Driver.Session
   26 import GHC.Driver.Ppr
   27 import GHC.Driver.Hooks
   28 import GHC.Driver.Plugins
   29 
   30 import GHC.Linker.Loader       ( loadModule, loadName )
   31 import GHC.Runtime.Interpreter ( wormhole )
   32 import GHC.Runtime.Interpreter.Types
   33 
   34 import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )
   35 import GHC.Iface.Load          ( loadPluginInterface, cannotFindModule )
   36 import GHC.Rename.Names ( gresFromAvails )
   37 import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName )
   38 
   39 import GHC.Driver.Env
   40 import GHCi.RemoteTypes  ( HValue )
   41 import GHC.Core.Type     ( Type, eqType, mkTyConTy )
   42 import GHC.Core.TyCon    ( TyCon )
   43 
   44 import GHC.Types.SrcLoc        ( noSrcSpan )
   45 import GHC.Types.Name    ( Name, nameModule_maybe )
   46 import GHC.Types.Id      ( idType )
   47 import GHC.Types.TyThing
   48 import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )
   49 import GHC.Types.Name.Reader   ( RdrName, ImportSpec(..), ImpDeclSpec(..)
   50                                , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
   51                                , greMangledName, mkRdrQual )
   52 
   53 import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )
   54 import GHC.Driver.Config.Finder ( initFinderOpts )
   55 import GHC.Unit.Module   ( Module, ModuleName )
   56 import GHC.Unit.Module.ModIface
   57 
   58 import GHC.Utils.Panic
   59 import GHC.Utils.Logger
   60 import GHC.Utils.Error
   61 import GHC.Utils.Outputable
   62 import GHC.Utils.Exception
   63 
   64 import Control.Monad     ( unless )
   65 import Data.Maybe        ( mapMaybe )
   66 import Unsafe.Coerce     ( unsafeCoerce )
   67 import GHC.Unit.Types (ModuleNameWithIsBoot)
   68 
   69 -- | Loads the plugins specified in the pluginModNames field of the dynamic
   70 -- flags. Should be called after command line arguments are parsed, but before
   71 -- actual compilation starts. Idempotent operation. Should be re-called if
   72 -- pluginModNames or pluginModNameOpts changes.
   73 initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv
   74 initializePlugins hsc_env mnwib
   75     -- plugins not changed
   76   | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags
   77    -- arguments not changed
   78   , all same_args (hsc_plugins hsc_env)
   79   = return hsc_env -- no need to reload plugins
   80   | otherwise
   81   = do loaded_plugins <- loadPlugins hsc_env mnwib
   82        let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }
   83        withPlugins hsc_env' driverPlugin hsc_env'
   84   where
   85     plugin_args = pluginModNameOpts dflags
   86     same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args
   87     argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
   88     dflags = hsc_dflags hsc_env
   89 
   90 loadPlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO [LoadedPlugin]
   91 loadPlugins hsc_env mnwib
   92   = do { unless (null to_load) $
   93            checkExternalInterpreter hsc_env
   94        ; plugins <- mapM loadPlugin to_load
   95        ; return $ zipWith attachOptions to_load plugins }
   96   where
   97     dflags  = hsc_dflags hsc_env
   98     to_load = pluginModNames dflags
   99 
  100     attachOptions mod_nm (plug, mod) =
  101         LoadedPlugin (PluginWithArgs plug (reverse options)) mod
  102       where
  103         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
  104                             , opt_mod_nm == mod_nm ]
  105     loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env mnwib
  106 
  107 
  108 loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
  109 loadFrontendPlugin hsc_env mod_name = do
  110     checkExternalInterpreter hsc_env
  111     fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
  112                 hsc_env Nothing mod_name
  113 
  114 -- #14335
  115 checkExternalInterpreter :: HscEnv -> IO ()
  116 checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
  117   Just (ExternalInterp {})
  118     -> throwIO (InstallationError "Plugins require -fno-external-interpreter")
  119   _ -> pure ()
  120 
  121 loadPlugin' :: OccName -> Name -> HscEnv -> Maybe ModuleNameWithIsBoot -> ModuleName -> IO (a, ModIface)
  122 loadPlugin' occ_name plugin_name hsc_env mnwib mod_name
  123   = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
  124              dflags = hsc_dflags hsc_env
  125        ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
  126                         plugin_rdr_name
  127        ; case mb_name of {
  128             Nothing ->
  129                 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
  130                           [ text "The module", ppr mod_name
  131                           , text "did not export the plugin name"
  132                           , ppr plugin_rdr_name ]) ;
  133             Just (name, mod_iface) ->
  134 
  135      do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
  136         ; mb_plugin <- getValueSafely hsc_env mnwib name (mkTyConTy plugin_tycon)
  137         ; case mb_plugin of
  138             Nothing ->
  139                 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
  140                           [ text "The value", ppr name
  141                           , text "did not have the type"
  142                           , ppr pluginTyConName, text "as required"])
  143             Just plugin -> return (plugin, mod_iface) } } }
  144 
  145 
  146 -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
  147 -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
  148 forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
  149 forceLoadModuleInterfaces hsc_env doc modules
  150     = (initTcInteractive hsc_env $
  151        initIfaceTcRn $
  152        mapM_ (loadPluginInterface doc) modules)
  153       >> return ()
  154 
  155 -- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
  156 -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
  157 forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
  158 forceLoadNameModuleInterface hsc_env reason name = do
  159     let name_modules = mapMaybe nameModule_maybe [name]
  160     forceLoadModuleInterfaces hsc_env reason name_modules
  161 
  162 -- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
  163 --
  164 -- * The interface could not be loaded
  165 -- * The name is not that of a 'TyCon'
  166 -- * The name did not exist in the loaded module
  167 forceLoadTyCon :: HscEnv -> Name -> IO TyCon
  168 forceLoadTyCon hsc_env con_name = do
  169     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
  170 
  171     mb_con_thing <- lookupType hsc_env con_name
  172     case mb_con_thing of
  173         Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
  174         Just (ATyCon tycon) -> return tycon
  175         Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
  176   where dflags = hsc_dflags hsc_env
  177 
  178 -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
  179 -- 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!
  180 --
  181 -- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
  182 --
  183 -- * If we could not load the names module
  184 -- * If the thing being loaded is not a value
  185 -- * If the Name does not exist in the module
  186 -- * If the link failed
  187 
  188 getValueSafely :: HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe a)
  189 getValueSafely hsc_env mnwib val_name expected_type = do
  190   mb_hval <- case getValueSafelyHook hooks of
  191     Nothing -> getHValueSafely interp hsc_env mnwib val_name expected_type
  192     Just h  -> h                      hsc_env mnwib val_name expected_type
  193   case mb_hval of
  194     Nothing   -> return Nothing
  195     Just hval -> do
  196       value <- lessUnsafeCoerce logger "getValueSafely" hval
  197       return (Just value)
  198   where
  199     interp = hscInterp hsc_env
  200     logger = hsc_logger hsc_env
  201     hooks  = hsc_hooks hsc_env
  202 
  203 getHValueSafely :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> Type -> IO (Maybe HValue)
  204 getHValueSafely interp hsc_env mnwib val_name expected_type = do
  205     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
  206     -- Now look up the names for the value and type constructor in the type environment
  207     mb_val_thing <- lookupType hsc_env val_name
  208     case mb_val_thing of
  209         Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
  210         Just (AnId id) -> do
  211             -- Check the value type in the interface against the type recovered from the type constructor
  212             -- before finally casting the value to the type we assume corresponds to that constructor
  213             if expected_type `eqType` idType id
  214              then do
  215                 -- Link in the module that contains the value, if it has such a module
  216                 case nameModule_maybe val_name of
  217                     Just mod -> do loadModule interp hsc_env mnwib mod
  218                                    return ()
  219                     Nothing ->  return ()
  220                 -- Find the value that we just linked in and cast it given that we have proved it's type
  221                 hval <- do
  222                   v <- loadName interp hsc_env mnwib val_name
  223                   wormhole interp v
  224                 return (Just hval)
  225              else return Nothing
  226         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
  227    where dflags = hsc_dflags hsc_env
  228 
  229 -- | Coerce a value as usual, but:
  230 --
  231 -- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
  232 --
  233 -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
  234 --    if it /does/ segfault
  235 lessUnsafeCoerce :: Logger -> String -> a -> IO b
  236 lessUnsafeCoerce logger context what = do
  237     debugTraceMsg logger 3 $
  238         (text "Coercing a value in") <+> (text context) <> (text "...")
  239     output <- evaluate (unsafeCoerce what)
  240     debugTraceMsg logger 3 (text "Successfully evaluated coercion")
  241     return output
  242 
  243 
  244 -- | Finds the 'Name' corresponding to the given 'RdrName' in the
  245 -- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
  246 -- could be found. Any other condition results in an exception:
  247 --
  248 -- * If the module could not be found
  249 -- * If we could not determine the imports of the module
  250 --
  251 -- Can only be used for looking up names while loading plugins (and is
  252 -- *not* suitable for use within plugins).  The interface file is
  253 -- loaded very partially: just enough that it can be used, without its
  254 -- rules and instances affecting (and being linked from!) the module
  255 -- being compiled.  This was introduced by 57d6798.
  256 --
  257 -- Need the module as well to record information in the interface file
  258 lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
  259                                 -> IO (Maybe (Name, ModIface))
  260 lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
  261     let dflags    = hsc_dflags hsc_env
  262     let fopts     = initFinderOpts dflags
  263     let fc        = hsc_FC hsc_env
  264     let units     = hsc_units hsc_env
  265     let home_unit = hsc_home_unit hsc_env
  266     -- First find the unit the module resides in by searching exposed units and home modules
  267     found_module <- findPluginModule fc fopts units home_unit mod_name
  268     case found_module of
  269         Found _ mod -> do
  270             -- Find the exports of the module
  271             (_, mb_iface) <- initTcInteractive hsc_env $
  272                              initIfaceTcRn $
  273                              loadPluginInterface doc mod
  274             case mb_iface of
  275                 Just iface -> do
  276                     -- Try and find the required name in the exports
  277                     let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
  278                                                 , is_qual = False, is_dloc = noSrcSpan }
  279                         imp_spec = ImpSpec decl_spec ImpAll
  280                         env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
  281                     case lookupGRE_RdrName rdr_name env of
  282                         [gre] -> return (Just (greMangledName gre, iface))
  283                         []    -> return Nothing
  284                         _     -> panic "lookupRdrNameInModule"
  285 
  286                 Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
  287         err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err
  288   where
  289     doc = text "contains a name used in an invocation of lookupRdrNameInModule"
  290 
  291 wrongTyThingError :: Name -> TyThing -> SDoc
  292 wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing]
  293 
  294 missingTyThingError :: Name -> SDoc
  295 missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"]
  296 
  297 throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
  298 throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
  299 
  300 throwCmdLineError :: String -> IO a
  301 throwCmdLineError = throwGhcExceptionIO . CmdLineError