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