{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ForeignFunctionInterface #-} -- -- Copyright (C) 2004-5 Don Stewart -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. -- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. -- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA -- -- | An interface to the GHC runtime's dynamic linker, providing runtime -- loading and linking of Haskell object files, commonly known as -- /plugins/. module System.Plugins.Load ( -- * The @LoadStatus@ type LoadStatus(..) -- * High-level interface , load , load_ , dynload , pdynload , pdynload_ , unload , unloadAll , reload , Module(..) -- * Low-level interface , initLinker -- start it up , loadModule -- load a vanilla .o , loadFunction -- retrieve a function from an object , loadFunction_ -- retrieve a function from an object , loadPackageFunction , loadPackage -- load a ghc library and its cbits , unloadPackage -- unload a ghc library and its cbits , loadPackageWith -- load a pkg using the package.conf provided , loadShared -- load a .so object file , resolveObjs -- and resolve symbols , loadRawObject -- load a bare .o. no dep chasing, no .hi file reading , Symbol , getImports ) where #include "../../../config.h" import System.Plugins.Make ( build ) import System.Plugins.Env import System.Plugins.Utils import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore ) import System.Plugins.LoadTypes -- import Language.Hi.Parser import Encoding (zEncodeString) import BinIface import HscTypes import Module (moduleName, moduleNameString) #if MIN_VERSION_ghc(8,0,0) #if MIN_VERSION_Cabal(2,0,0) import Module (installedUnitIdString) #else import Module (unitIdString) #endif #elif MIN_VERSION_ghc(7,10,0) import Module (packageKeyString) #else import Module (packageIdString) #endif import HscMain (newHscEnv) import TcRnMonad (initTcRnIf) import Data.Dynamic ( fromDynamic, Dynamic ) import Data.Typeable ( Typeable ) import Data.List ( isSuffixOf, nub, nubBy ) import Control.Monad ( when, filterM, liftM ) import System.Directory ( doesFileExist, removeFile ) import Foreign.C ( CInt(..) ) import Foreign.C.String ( CString, withCString, peekCString ) #if !MIN_VERSION_ghc(7,2,0) import GHC ( defaultCallbacks ) #else import DynFlags (defaultDynFlags, initDynFlags) import GHC.Paths (libdir) import SysTools (initSysTools) #endif import GHC.Ptr ( Ptr(..), nullPtr ) #if !MIN_VERSION_ghc(7,4,1) import GHC.Exts ( addrToHValue# ) #else import GHC.Exts ( addrToAny# ) #endif import GHC.Prim ( unsafeCoerce# ) #if DEBUG import System.IO ( hFlush, stdout ) #endif import System.IO ( hClose ) ifaceModuleName = moduleNameString . moduleName . mi_module readBinIface' :: FilePath -> IO ModIface readBinIface' hi_path = do -- kludgy as hell #if MIN_VERSION_ghc(7,2,0) mySettings <- initSysTools (Just libdir) -- how should we really set the top dir? dflags <- initDynFlags (defaultDynFlags mySettings) e <- newHscEnv dflags #else e <- newHscEnv defaultCallbacks undefined #endif initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path) -- TODO need a loadPackage p package.conf :: IO () primitive -- -- | The @LoadStatus@ type encodes the return status of functions that -- perform dynamic loading in a type isomorphic to 'Either'. Failure -- returns a list of error strings, success returns a reference to a -- loaded module, and the Haskell value corresponding to the symbol that -- was indexed. -- data LoadStatus a = LoadSuccess Module a | LoadFailure Errors -- -- | 'load' is the basic interface to the dynamic loader. A call to -- 'load' imports a single object file into the caller's address space, -- returning the value associated with the symbol requested. Libraries -- and modules that the requested module depends upon are loaded and -- linked in turn. -- -- The first argument is the path to the object file to load, the second -- argument is a list of directories to search for dependent modules. -- The third argument is a list of paths to user-defined, but -- unregistered, /package.conf/ files. The 'Symbol' argument is the -- symbol name of the value you with to retrieve. -- -- The value returned must be given an explicit type signature, or -- provided with appropriate type constraints such that Haskell compiler -- can determine the expected type returned by 'load', as the return -- type is notionally polymorphic. -- -- Example: -- -- > do mv <- load "Plugin.o" ["api"] [] "resource" -- > case mv of -- > LoadFailure msg -> print msg -- > LoadSuccess _ v -> return v -- load :: FilePath -- ^ object file -> [FilePath] -- ^ any include paths -> [PackageConf] -- ^ list of package.conf paths -> Symbol -- ^ symbol to find -> IO (LoadStatus a) load obj incpaths pkgconfs sym = do initLinker_ $ fromIntegral 0 -- load extra package information mapM_ addPkgConf pkgconfs (hif,moduleDeps) <- loadDepends obj incpaths -- why is this the package name? #if DEBUG putStr (' ':(decode $ ifaceModuleName hif)) >> hFlush stdout #endif m' <- loadObject obj . Object . ifaceModuleName $ hif let m = m' { iface = hif } resolveObjs (mapM_ unloadAll (m:moduleDeps)) #if DEBUG putStrLn " ... done" >> hFlush stdout #endif addModuleDeps m' moduleDeps v <- loadFunction m sym return $ case v of Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Just a -> LoadSuccess m a -- -- | Like load, but doesn't want a package.conf arg (they are rarely used) -- load_ :: FilePath -- ^ object file -> [FilePath] -- ^ any include paths -> Symbol -- ^ symbol to find -> IO (LoadStatus a) load_ o i s = load o i [] s -- | A work-around for Dynamics. The keys used to compare two TypeReps are -- somehow not equal for the same type in hs-plugin's loaded objects. -- Solution: implement our own dynamics... -- -- The problem with dynload is that it requires the plugin to export -- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this -- is not the case, we core dump. Use pdynload if you don't trust the -- user to supply you with a Dynamic -- dynload :: Typeable a => FilePath -> [FilePath] -> [PackageConf] -> Symbol -> IO (LoadStatus a) dynload obj incpaths pkgconfs sym = do s <- load obj incpaths pkgconfs sym case s of e@(LoadFailure _) -> return e LoadSuccess m dyn_v -> return $ case fromDynamic (unsafeCoerce# dyn_v :: Dynamic) of Just v' -> LoadSuccess m v' Nothing -> LoadFailure ["Mismatched types in interface"] ------------------------------------------------------------------------ -- | -- The super-replacement for dynload -- -- Use GHC at runtime so we get staged type inference, providing full -- power dynamics, *on module interfaces only*. This is quite suitable -- for plugins, of coures :) -- -- TODO where does the .hc file go in the call to build() ? -- pdynload :: FilePath -- ^ object to load -> [FilePath] -- ^ include paths -> [PackageConf] -- ^ package confs -> Type -- ^ API type -> Symbol -- ^ symbol -> IO (LoadStatus a) pdynload object incpaths pkgconfs ty sym = do #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif errors <- unify object incpaths [] ty sym #if DEBUG putStrLn "done" #endif if null errors then load object incpaths pkgconfs sym else return $ LoadFailure errors -- -- | Like pdynload, but you can specify extra arguments to the -- typechecker. -- pdynload_ :: FilePath -- ^ object to load -> [FilePath] -- ^ include paths for loading -> [PackageConf] -- ^ any extra package.conf files -> [Arg] -- ^ extra arguments to ghc, when typechecking -> Type -- ^ expected type -> Symbol -- ^ symbol to load -> IO (LoadStatus a) pdynload_ object incpaths pkgconfs args ty sym = do #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif errors <- unify object incpaths args ty sym #if DEBUG putStrLn "done" #endif if null errors then load object incpaths pkgconfs sym else return $ LoadFailure errors ------------------------------------------------------------------------ -- | run the typechecker over the constraint file -- -- Problem: if the user depends on a non-auto package to build the -- module, then that package will not be in scope when we try to build -- the module, when performing `unify'. Normally make() will handle this -- (as it takes extra ghc args). pdynload ignores these, atm -- but it -- shouldn't. Consider a pdynload() that accepts extra -package flags? -- -- Also, pdynload() should accept extra in-scope modules. -- Maybe other stuff we want to hack in here. -- unify obj incs args ty sym = do (tmpf,hdl) <- mkTemp (tmpf1,hdl1) <- mkTemp -- and send .hi file here. hClose hdl1 let nm = mkModid (basename tmpf) src = mkTest nm (hierize' . mkModid . hierize $ obj) (fst $ break (=='.') ty) ty sym is = map ("-i"++) incs -- api i = "-i" ++ dirname obj -- plugin hWrite hdl src e <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1]) mapM_ removeFile [tmpf,tmpf1] return e where -- fix up hierarchical names hierize [] = [] hierize ('/':cs) = '\\' : hierize cs hierize (c:cs) = c : hierize cs hierize'[] = [] hierize' ('\\':cs) = '.' : hierize' cs hierize' (c:cs) = c : hierize' cs mkTest modnm plugin api ty sym = "module "++ modnm ++" where" ++ "\nimport qualified " ++ plugin ++ "\nimport qualified " ++ api ++ "{-# LINE 1 \"<typecheck>\" #-}" ++ "\n_ = "++ plugin ++"."++ sym ++" :: "++ty ------------------------------------------------------------------------ {- -- -- old version that tried to rip stuff from .hi files -- pdynload obj incpaths pkgconfs sym ty = do (m, v) <- load obj incpaths pkgconfs sym ty' <- mungeIface sym obj if ty == ty' then return $ Just (m, v) else return Nothing -- mismatched types where -- grab the iface output from GHC. find the line relevant to our -- symbol. grab the string rep of the type. mungeIface sym o = do let hi = replaceSuffix o hiSuf (out,_) <- exec ghc ["--show-iface", hi] case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of Nothing -> return undefined Just v -> do let v' = drop 3 $ dropWhile (/= ':') v return v' -} {- -- -- a version of load the also unwraps and types a Dynamic object -- dynload2 :: Typeable a => FilePath -> FilePath -> Maybe [PackageConf] -> Symbol -> IO (Module, a) dynload2 obj incpath pkgconfs sym = do (m, v) <- load obj incpath pkgconfs sym case fromDynamic v of Nothing -> panic $ "load: couldn't type "++(show v) Just a -> return (m,a) -} ------------------------------------------------------------------------ -- -- | unload a module (not its dependencies) -- we have the dependencies, so cascaded unloading is possible -- -- once you unload it, you can't 'load' it again, you have to 'reload' -- it. Cause we don't unload all the dependencies -- unload :: Module -> IO () unload m = rmModuleDeps m >> unloadObj m ------------------------------------------------------------------------ -- -- | unload a module and its dependencies -- we have the dependencies, so cascaded unloading is possible -- unloadAll :: Module -> IO () unloadAll m = do moduleDeps <- getModuleDeps m rmModuleDeps m mapM_ unloadAll moduleDeps unload m -- -- | this will be nice for panTHeon, needs thinking about the interface -- reload a single object file. don't care about depends, assume they -- are loaded. (should use state to store all this) -- -- assumes you've already done a 'load' -- -- should factor the code -- reload :: Module -> Symbol -> IO (LoadStatus a) reload m@(Module{path = p, iface = hi}) sym = do unloadObj m -- unload module (and delete) #if DEBUG putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout #endif m_ <- loadObject p . Object . ifaceModuleName $ hi -- load object at path p let m' = m_ { iface = hi } resolveObjs (unloadAll m) #if DEBUG putStrLn "done" >> hFlush stdout #endif v <- loadFunction m' sym return $ case v of Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Just a -> LoadSuccess m' a -- -- This is a stripped-down version of Andre Pang's runtime_loader, -- which in turn is based on GHC's ghci\/ObjLinker.lhs binding -- -- Load and unload\/Haskell modules at runtime. This is not really -- \'dynamic loading\', as such -- that implies that you\'re working -- with proper shared libraries, whereas this is far more simple and -- only loads object files. But it achieves the same goal: you can -- load a Haskell module at runtime, load a function from it, and run -- the function. I have no idea if this works for types, but that -- doesn\'t mean that you can\'t try it :). -- -- read $fptools\/ghc\/compiler\/ghci\/ObjLinker.lhs for how to use this stuff -- -- | Call the initLinker function first, before calling any of the other -- functions in this module - otherwise you\'ll get unresolved symbols. initLinker :: IO () initLinker = initLinker_ $ fromIntegral 0 -- our initLinker transparently calls the one in GHC -- -- | Load a function from a module (which must be loaded and resolved first). -- loadFunction :: Module -- ^ The module the value is in -> String -- ^ Symbol name of value -> IO (Maybe a) -- ^ The value you want loadFunction (Module { iface = i }) valsym = loadFunction_ (ifaceModuleName i) valsym loadFunction_ :: String -> String -> IO (Maybe a) loadFunction_ = loadFunction__ Nothing loadFunction__ :: Maybe String -> String -> String -> IO (Maybe a) loadFunction__ pkg m valsym = do let symbol = prefixUnderscore++(maybe "" (\p -> zEncodeString p++"_") pkg) ++zEncodeString m++"_"++(zEncodeString valsym)++"_closure" #if DEBUG putStrLn $ "Looking for <<"++symbol++">>" #endif ptr@(Ptr addr) <- withCString symbol c_lookupSymbol if (ptr == nullPtr) then return Nothing #if !MIN_VERSION_ghc(7,4,1) else case addrToHValue# addr of #else else case addrToAny# addr of #endif (# hval #) -> return ( Just hval ) -- | Loads a function from a package module, given the package name, -- module name and symbol name. loadPackageFunction :: String -- ^ Package name, including version number. -> String -- ^ Module name -> String -- ^ Symbol to lookup in the module -> IO (Maybe a) loadPackageFunction pkgName modName functionName = do loadPackage pkgName resolveObjs (unloadPackage pkgName) loadFunction__ (Just pkgName) modName functionName -- -- | Load a GHC-compiled Haskell vanilla object file. -- The first arg is the path to the object file -- -- We make it idempotent to stop the nasty problem of loading the same -- .o twice. Also the rts is a very special package that is already -- loaded, even if we ask it to be loaded. N.B. we should insert it in -- the list of known packages. -- -- NB the environment stores the *full path* to an object. So if you -- want to know if a module is already loaded, you need to supply the -- *path* to that object, not the name. -- -- NB -- let's try just the module name. -- -- loadObject loads normal .o objs, and packages too. .o objs come with -- a nice canonical Z-encoded modid. packages just have a simple name. -- Do we want to ensure they won't clash? Probably. -- -- -- -- the second argument to loadObject is a string to use as the unique -- identifier for this object. For normal .o objects, it should be the -- Z-encoded modid from the .hi file. For archives\/packages, we can -- probably get away with the package name -- loadObject :: FilePath -> Key -> IO Module loadObject p ky@(Object k) = loadObject' p ky k loadObject p ky@(Package k) = loadObject' p ky k loadObject' :: FilePath -> Key -> String -> IO Module loadObject' p ky k = do alreadyLoaded <- isLoaded k when (not alreadyLoaded) $ do let ld = if sysPkgSuffix `isSuffixOf` p then c_loadArchive else c_loadObj r <- withCString p ld when (not r) (panic $ "Could not load module or package `"++p++"'") let hifile = replaceSuffix p hiSuf exists <- doesFileExist hifile hiface <- if exists then readBinIface' hifile else return undefined let m = emptyMod p hiface addModule k m return m where emptyMod q hiface = Module q (mkModid q) Vanilla hiface ky -- | -- load a single object. no dependencies. You should know what you're -- doing. -- loadModule :: FilePath -> IO Module loadModule obj = do let hifile = replaceSuffix obj hiSuf exists <- doesFileExist hifile if (not exists) then error $ "No .hi file found for "++show obj else do hiface <- readBinIface' hifile loadObject obj (Object (ifaceModuleName hiface)) -- -- | Load a generic .o file, good for loading C objects. -- You should know what you're doing.. -- Returns a fairly meaningless iface value. -- loadRawObject :: FilePath -> IO Module loadRawObject obj = loadObject obj (Object k) where k = encode (mkModid obj) -- Z-encoded module name -- -- | Resolve (link) the modules loaded by the 'loadObject' function. -- resolveObjs :: IO a -> IO () resolveObjs unloadLoaded = do r <- c_resolveObjs when (not r) $ unloadLoaded >> panic "resolvedObjs failed." -- | Unload a module unloadObj :: Module -> IO () unloadObj (Module { path = p, kind = k, key = ky }) = case k of Vanilla -> withCString p $ \c_p -> do removed <- rmModule name when (removed) $ do r <- c_unloadObj c_p when (not r) (panic "unloadObj: failed") Shared -> return () -- can't unload .so? where name = case ky of Object s -> s ; Package pk -> pk -- -- | from ghci\/ObjLinker.c -- -- Load a .so type object file. -- loadShared :: FilePath -> IO Module loadShared str = do #if DEBUG putStrLn $ " shared: " ++ str #endif maybe_errmsg <- withCString str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return (Module str (mkModid str) Shared undefined (Package (mkModid str))) else do e <- peekCString maybe_errmsg panic $ "loadShared: couldn't load `"++str++"\' because "++e -- -- | Load a -package that we might need, implicitly loading the cbits too -- The argument is the name of package (e.g. \"concurrent\") -- -- How to find a package is determined by the package.conf info we store -- in the environment. It is just a matter of looking it up. -- -- Not printing names of dependent pkgs -- loadPackage :: String -> IO () loadPackage p = do #if DEBUG putStr (' ':p) >> hFlush stdout #endif (libs,dlls) <- lookupPkg p mapM_ (\l -> loadObject l (Package (mkModid l))) libs #if DEBUG putStr (' ':show libs) >> hFlush stdout putStr (' ':show dlls) >> hFlush stdout #endif mapM_ loadShared dlls -- -- | Unload a -package, that has already been loaded. Unload the cbits -- too. The argument is the name of the package. -- -- May need to check if it exists. -- -- Note that we currently need to unload everything. grumble grumble. -- -- We need to add the version number to the package name with 6.4 and -- over. "yi-0.1" for example. This is a bug really. -- unloadPackage :: String -> IO () unloadPackage pkg = do let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg) flip mapM_ libs $ \p -> withCString p $ \c_p -> do r <- c_unloadObj c_p when (not r) (panic "unloadObj: failed") rmModule (mkModid p) -- unrecord this module -- -- | load a package using the given package.conf to help -- TODO should report if it doesn't actually load the package, instead -- of mapM_ doing nothing like above. -- loadPackageWith :: String -> [PackageConf] -> IO () loadPackageWith p pkgconfs = do #if DEBUG putStr "Loading package" >> hFlush stdout #endif mapM_ addPkgConf pkgconfs loadPackage p #if DEBUG putStrLn " done" #endif -- --------------------------------------------------------------------- -- | module dependency loading -- -- given an Foo.o vanilla object file, supposed to be a plugin compiled -- by our library, find the associated .hi file. If this is found, load -- the dependencies, packages first, then the modules. If it doesn't -- exist, assume the user knows what they are doing and continue. The -- linker will crash on them anyway. Second argument is any include -- paths to search in -- -- ToDo problem with absolute and relative paths, and different forms of -- relative paths. A user may cause a dependency to be loaded, which -- will search the incpaths, and perhaps find "./Foo.o". The user may -- then explicitly load "Foo.o". These are the same, and the loader -- should ignore the second load request. However, isLoaded will say -- that "Foo.o" is not loaded, as the full string is used as a key to -- the modenv fm. We need a canonical form for the keys -- is basename -- good enough? -- loadDepends :: FilePath -> [FilePath] -> IO (ModIface,[Module]) loadDepends obj incpaths = do let hifile = replaceSuffix obj hiSuf exists <- doesFileExist hifile if (not exists) then do #if DEBUG putStrLn "No .hi file found." >> hFlush stdout #endif return (undefined,[]) -- could be considered fatal else do hiface <- readBinIface' hifile let ds = mi_deps hiface -- remove ones that we've already loaded ds' <- filterM loaded . map (moduleNameString . fst) . dep_mods $ ds -- now, try to generate a path to the actual .o file -- fix up hierachical names let mods_ = map (\s -> (s, map (\c -> if c == '.' then '/' else c) $ s)) ds' -- construct a list of possible dependent modules to load let mods = concatMap (\p -> map (\(hi,m) -> (hi,p </> m++".o")) mods_) incpaths -- remove modules that don't exist mods' <- filterM (\(_,y) -> doesFileExist y) $ nubBy (\v u -> snd v == snd u) mods -- now remove duplicate valid paths to the same object let mods'' = nubBy (\v u -> fst v == fst u) mods' -- and find some packages to load, as well. let ps = dep_pkgs ds #if MIN_VERSION_ghc(8,0,0) #if MIN_VERSION_Cabal(2,0,0) ps' <- filterM loaded . map installedUnitIdString . nub $ map fst ps #else ps' <- filterM loaded . map unitIdString . nub $ map fst ps #endif #elif MIN_VERSION_ghc(7,10,0) ps' <- filterM loaded . map packageKeyString . nub $ map fst ps #elif MIN_VERSION_ghc(7,2,0) ps' <- filterM loaded . map packageIdString . nub $ map fst ps #else ps' <- filterM loaded . map packageIdString . nub $ ps #endif #if DEBUG when (not (null ps')) $ putStr "Loading package" >> hFlush stdout #endif mapM_ loadPackage ps' #if DEBUG when (not (null ps')) $ putStr " ... linking ... " >> hFlush stdout #endif resolveObjs (mapM_ unloadPackage ps') #if DEBUG when (not (null ps')) $ putStrLn "done" putStr "Loading object" mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods'' #endif moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods'' return (hiface,moduleDeps) -- --------------------------------------------------------------------- -- | Nice interface to .hi parser -- getImports :: String -> IO [String] getImports m = do hi <- readBinIface' (m ++ hiSuf) return . map (moduleNameString . fst) . dep_mods . mi_deps $ hi -- --------------------------------------------------------------------- -- C interface -- foreign import ccall safe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Bool foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Bool foreign import ccall unsafe "loadArchive" c_loadArchive :: CString -> IO Bool foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Bool foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString foreign import ccall unsafe "initLinker_" initLinker_ :: CInt -> IO ()