wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
5c8d34fba9ffae17645332d492e16342b2b4d5fc
shaniqua-plugins/System/Plugins/Load.hs

662 lines
22 KiB
Haskell
Raw Blame History

{-# OPTIONS -fglasgow-exts #-}
--
-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- 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
--
module System.Plugins.Load (
-- high level interface
load , load_
, dynload
, pdynload , pdynload_
, unload
, unloadAll
, reload
, Module(..)
, LoadStatus(..)
-- low level interface
, initLinker -- start it up
, loadModule -- load a vanilla .o
, loadFunction -- retrieve a function from an object
, 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 AltData.Dynamic ( fromDynamic, Dynamic )
import AltData.Typeable ( Typeable )
import Data.List ( isSuffixOf, nub, nubBy )
import Control.Monad ( when, filterM, liftM )
import System.Directory ( doesFileExist, removeFile )
import Foreign.C.String ( CString, withCString, peekCString )
import GHC.Ptr ( Ptr(..), nullPtr )
import GHC.Exts ( addrToHValue# )
import GHC.Prim ( unsafeCoerce# )
#if DEBUG
import System.IO ( hFlush, stdout )
#endif
import System.IO ( hClose )
-- TODO need a loadPackage p package.conf :: IO () primitive
-- ---------------------------------------------------------------------
-- return status of all *load functions:
--
data LoadStatus a
= LoadSuccess Module a
| LoadFailure Errors
-- ---------------------------------------------------------------------
-- | load an object file into the address space, returning the closure
-- associated with the symbol requested, after removing its dynamism.
--
-- Recursively loads the specified modules, and all the modules they
-- depend on.
--
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
-- load extra package information
mapM_ addPkgConf pkgconfs
(hif,moduleDeps) <- loadDepends obj incpaths
-- why is this the package name?
#if DEBUG
putStr (' ':(decode $ mi_module hif)) >> hFlush stdout
#endif
m' <- loadObject obj (Object (mi_module 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 -> [FilePath] -> Symbol -> 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 (\s -> "-i"++s) incs -- api
i = "-i" ++ dirname obj -- plugin
hWrite hdl src
e <- build tmpf tmpf1 (i:is++args++["-fno-code","-ohi "++tmpf1])
-- removeFile tmpf
removeFile 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 $ mi_module 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 Andr<64> 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 ()
-- 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
= do let m = mi_module i
symbol = symbolise m
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
#endif
ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol
if (ptr == nullPtr)
then return Nothing
else case addrToHValue# addr of
(# hval #) -> return ( Just hval )
where
symbolise m = prefixUnderscore++m++"_"++(encode valsym)++"_closure"
--
-- | 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
| ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p)
| otherwise
= do alreadyLoaded <- isLoaded k
when (not alreadyLoaded) $ do
r <- withCString p c_loadObj
when (not r) (panic $ "Could not load module `"++p++"'")
addModule k (emptyMod p) -- needs to Z-encode module name
return (emptyMod p)
where emptyMod q = Module q (mkModid q) Vanilla emptyIface 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 <- readIface hifile
loadObject obj (Object (mi_module 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 emptyIface (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 dlls)
#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 (Iface,[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 (emptyIface,[]) -- could be considered fatal
else do hiface <- readIface hifile
let ds = mi_deps hiface
-- remove ones that we've already loaded
ds' <- filterM loaded (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) $ decode 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
ps' <- filterM loaded (nub ps)
#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 (" "++(decode 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 <- readIface (m ++ hiSuf)
return $ dep_mods (mi_deps hi)
-- ---------------------------------------------------------------------
-- C interface
--
foreign import ccall unsafe "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 "resolveObjs"
c_resolveObjs :: IO Bool
foreign import ccall unsafe "addDLL"
c_addDLL :: CString -> IO CString
foreign import ccall unsafe "initLinker"
initLinker :: IO ()
Reference in New Issue View Git Blame Copy Permalink