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