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