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