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