DynamicLoading.hs 11.2 KB
Newer Older
1 2
{-# LANGUAGE CPP, MagicHash #-}

3 4 5
-- | Dynamically lookup up values from modules and loading them.
module DynamicLoading (
#ifdef GHCI
Adam Gundry's avatar
Adam Gundry committed
6 7
        -- * Loading plugins
        loadPlugins,
Edward Z. Yang's avatar
Edward Z. Yang committed
8
        loadFrontendPlugin,
Adam Gundry's avatar
Adam Gundry committed
9

10 11 12 13
        -- * Force loading information
        forceLoadModuleInterfaces,
        forceLoadNameModuleInterface,
        forceLoadTyCon,
14

15
        -- * Finding names
16
        lookupRdrNameInModuleForPlugins,
17

18 19
        -- * Loading values
        getValueSafely,
20
        getHValueSafely,
21
        lessUnsafeCoerce
22 23
#else
        pluginError,
24 25 26 27
#endif
    ) where

#ifdef 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(..)
Adam Gundry's avatar
Adam Gundry committed
35 36
                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
                        , gre_name, mkRdrQual )
Edward Z. Yang's avatar
Edward Z. Yang committed
37
import OccName          ( OccName, mkVarOcc )
38
import RnNames          ( gresFromAvails )
39
import DynFlags
Edward Z. Yang's avatar
Edward Z. Yang committed
40 41
import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )
import PrelNames        ( pluginTyConName, frontendPluginTyConName )
42

43
import HscTypes
44
import GHCi.RemoteTypes ( HValue )
45
import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )
46 47 48 49
import TyCon            ( TyCon )
import Name             ( Name, nameModule_maybe )
import Id               ( idType )
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 61 62 63 64 65 66 67 68 69
#else

import Module           ( ModuleName, moduleNameString )
import Panic

import Data.List        ( intercalate )

#endif

#ifdef GHCI
70

Adam Gundry's avatar
Adam Gundry committed
71 72 73
loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
loadPlugins hsc_env
  = do { plugins <- mapM (loadPlugin hsc_env) to_load
74
       ; return $ zipWith attachOptions to_load plugins }
Adam Gundry's avatar
Adam Gundry committed
75 76 77 78
  where
    dflags  = hsc_dflags hsc_env
    to_load = pluginModNames dflags

79
    attachOptions mod_nm plug = (mod_nm, plug, options)
Adam Gundry's avatar
Adam Gundry committed
80 81 82 83 84
      where
        options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
                            , opt_mod_nm == mod_nm ]

loadPlugin :: HscEnv -> ModuleName -> IO Plugin
Edward Z. Yang's avatar
Edward Z. Yang committed
85 86 87 88 89 90 91 92
loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName

loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName

loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a
loadPlugin' occ_name plugin_name hsc_env mod_name
  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
Adam Gundry's avatar
Adam Gundry committed
93 94 95 96 97 98
             dflags = hsc_dflags hsc_env
       ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
                        plugin_rdr_name
       ; case mb_name of {
            Nothing ->
                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
99 100
                          [ text "The module", ppr mod_name
                          , text "did not export the plugin name"
Adam Gundry's avatar
Adam Gundry committed
101 102 103
                          , ppr plugin_rdr_name ]) ;
            Just name ->

Edward Z. Yang's avatar
Edward Z. Yang committed
104
     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
Adam Gundry's avatar
Adam Gundry committed
105 106 107 108
        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
        ; case mb_plugin of
            Nothing ->
                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
109 110 111
                          [ text "The value", ppr name
                          , text "did not have the type"
                          , ppr pluginTyConName, text "as required"])
Adam Gundry's avatar
Adam Gundry committed
112 113 114
            Just plugin -> return plugin } } }


115 116 117 118
-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces hsc_env doc modules
119 120
    = (initTcInteractive hsc_env $
       initIfaceTcRn $
121
       mapM_ (loadPluginInterface doc) modules)
122
      >> return ()
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137

-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface hsc_env reason name = do
    let name_modules = mapMaybe nameModule_maybe [name]
    forceLoadModuleInterfaces hsc_env reason name_modules

-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
--
-- * The interface could not be loaded
-- * The name is not that of a 'TyCon'
-- * The name did not exist in the loaded module
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
138
    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
139

140 141
    mb_con_thing <- lookupTypeHscEnv hsc_env con_name
    case mb_con_thing of
Ian Lynagh's avatar
Ian Lynagh committed
142
        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
143
        Just (ATyCon tycon) -> return tycon
Ian Lynagh's avatar
Ian Lynagh committed
144 145
        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
  where dflags = hsc_dflags hsc_env
146 147 148 149 150 151 152 153 154 155 156 157 158

-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
-- 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!
--
-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
--
-- * If we could not load the names module
-- * If the thing being loaded is not a value
-- * If the Name does not exist in the module
-- * If the link failed

getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
159 160 161 162 163 164 165 166 167 168 169
  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
  case mb_hval of
    Nothing   -> return Nothing
    Just hval -> do
      value <- lessUnsafeCoerce dflags "getValueSafely" hval
      return (Just value)
  where
    dflags = hsc_dflags hsc_env

getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
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 172 173
    -- Now look up the names for the value and type constructor in the type environment
    mb_val_thing <- lookupTypeHscEnv hsc_env val_name
    case mb_val_thing of
Ian Lynagh's avatar
Ian Lynagh committed
174
        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
175 176 177 178 179 180 181 182 183 184 185
        Just (AnId id) -> do
            -- Check the value type in the interface against the type recovered from the type constructor
            -- before finally casting the value to the type we assume corresponds to that constructor
            if expected_type `eqType` idType id
             then do
                -- Link in the module that contains the value, if it has such a module
                case nameModule_maybe val_name of
                    Just mod -> do linkModule hsc_env mod
                                   return ()
                    Nothing ->  return ()
                -- 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
Ian Lynagh's avatar
Ian Lynagh committed
189
        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
190
   where dflags = hsc_dflags hsc_env
191 192 193 194 195 196 197 198 199

-- | Coerce a value as usual, but:
--
-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
--
-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
--    if it /does/ segfault
lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do
200 201
    debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
                             (text "...")
202
    output <- evaluate (unsafeCoerce# what)
203
    debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
204 205 206
    return output


Adam Gundry's avatar
Adam Gundry committed
207 208 209
-- | Finds the 'Name' corresponding to the given 'RdrName' in the
-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
-- could be found. Any other condition results in an exception:
210 211 212
--
-- * If the module could not be found
-- * If we could not determine the imports of the module
213
--
Adam Gundry's avatar
Adam Gundry committed
214 215 216 217 218
-- Can only be used for looking up names while loading plugins (and is
-- *not* suitable for use within plugins).  The interface file is
-- loaded very partially: just enough that it can be used, without its
-- rules and instances affecting (and being linked from!) the module
-- being compiled.  This was introduced by 57d6798.
219 220
lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
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 227 228
            (_, mb_iface) <- initTcInteractive hsc_env $
                             initIfaceTcRn $
                             loadPluginInterface doc mod
229 230
            case mb_iface of
                Just iface -> do
231
                    -- Try and find the required name in the exports
232 233
                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
                                                , is_qual = False, is_dloc = noSrcSpan }
234 235
                        imp_spec = ImpSpec decl_spec ImpAll
                        env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
236 237 238 239 240
                    case lookupGRE_RdrName rdr_name env of
                        [gre] -> return (Just (gre_name gre))
                        []    -> return Nothing
                        _     -> panic "lookupRdrNameInModule"

241
                Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
242 243 244
        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
  where
    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

Ian Lynagh's avatar
Ian Lynagh committed
253 254
throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
255 256

throwCmdLineError :: String -> IO a
257
throwCmdLineError = throwGhcExceptionIO . CmdLineError
258 259 260 261 262 263 264 265 266 267 268

#else

pluginError :: [ModuleName] -> a
pluginError modnames = throwGhcException (CmdLineError msg)
  where
    msg = "not built for interactive use - can't load plugins ("
            -- module names are not z-encoded
          ++ intercalate ", " (map moduleNameString modnames)
          ++ ")"

269
#endif