2005-04-24 08:51:33 +00:00
|
|
|
|
{-# OPTIONS -#include "Linker.h" #-}
|
|
|
|
|
{-# OPTIONS -fglasgow-exts -cpp #-}
|
|
|
|
|
--
|
|
|
|
|
-- Copyright (C) 2004 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
|
|
|
|
|
--
|
|
|
|
|
|
2005-05-15 04:55:38 +00:00
|
|
|
|
module System.Plugins.Load (
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
|
|
|
|
-- high level interface
|
|
|
|
|
load , load_
|
|
|
|
|
, dynload
|
|
|
|
|
, pdynload , pdynload_
|
|
|
|
|
, unload
|
|
|
|
|
, 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
|
|
|
|
|
|
|
|
|
|
) where
|
|
|
|
|
|
2005-05-15 04:55:38 +00:00
|
|
|
|
import System.Plugins.Make ( build )
|
|
|
|
|
import System.Plugins.Env
|
|
|
|
|
import System.Plugins.Utils
|
|
|
|
|
import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
2005-05-15 04:55:38 +00:00
|
|
|
|
import Language.Hi.Parser
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
|
|
|
|
import AltData.Dynamic ( fromDyn, 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
|
2005-05-16 03:31:19 +00:00
|
|
|
|
import System.IO ( hClose )
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
|
|
|
|
-- TODO need a loadPackage p package.conf :: IO () primitive
|
|
|
|
|
|
|
|
|
|
-- ---------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
type Symbol = String
|
|
|
|
|
type Type = String
|
|
|
|
|
type Errors = [String]
|
|
|
|
|
type PackageConf = FilePath
|
|
|
|
|
|
|
|
|
|
data Module = Module { path :: !FilePath
|
|
|
|
|
, mname :: !String
|
|
|
|
|
, kind :: !ObjType
|
|
|
|
|
, iface :: Iface -- cache the iface
|
|
|
|
|
, key :: Key
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
data ObjType = Vanilla | Shared deriving Eq
|
|
|
|
|
|
|
|
|
|
-- ---------------------------------------------------------------------
|
|
|
|
|
-- 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 <- 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
|
|
|
|
|
|
|
|
|
|
#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
|
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
-- | 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 fromDyn (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
|
2005-05-16 03:31:19 +00:00
|
|
|
|
(tmpf,hdl) <- mkTemp
|
|
|
|
|
(tmpf1,hdl1) <- mkTemp -- and send .hi file here.
|
|
|
|
|
hClose hdl1
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
|
|
|
|
let nm = mkModid (basename tmpf)
|
|
|
|
|
src = mkTest nm (mkModid obj) (fst $ break (=='.') ty) ty sym
|
|
|
|
|
is = map (\s -> "-i"++s) incs -- api
|
|
|
|
|
i = "-i" ++ dirname obj -- plugin
|
|
|
|
|
|
|
|
|
|
hWrite hdl src
|
2005-05-16 03:31:19 +00:00
|
|
|
|
-- was need for cygwin, should be ok now:
|
|
|
|
|
-- e <- build tmpf "nul" (i:is++args++["-fno-code","-ohi nul"])
|
|
|
|
|
|
|
|
|
|
e <- build tmpf tmpf1 (i:is++args++["-fno-code","-ohi "++tmpf1])
|
2005-04-24 08:51:33 +00:00
|
|
|
|
removeFile tmpf
|
2005-05-16 03:31:19 +00:00
|
|
|
|
removeFile tmpf1
|
2005-04-24 08:51:33 +00:00
|
|
|
|
return e
|
|
|
|
|
|
|
|
|
|
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 it's 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 = unloadObj
|
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
-- | 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
|
|
|
|
|
#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
|
|
|
|
|
--
|
|
|
|
|
data Key = Object String | Package String
|
|
|
|
|
|
|
|
|
|
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 -- 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 ()
|
2005-05-07 03:58:08 +00:00
|
|
|
|
resolveObjs = do
|
2005-04-24 08:51:33 +00:00
|
|
|
|
r <- c_resolveObjs
|
|
|
|
|
when (not r) $
|
|
|
|
|
panic $ "resolveObjs failed with <<" ++ show r ++ ">>"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- | Unload a module
|
|
|
|
|
unloadObj :: Module -> IO ()
|
|
|
|
|
unloadObj (Module { path = p, kind = k, key = ky }) = case k of
|
|
|
|
|
Vanilla -> withCString p $ \c_p -> do
|
|
|
|
|
r <- c_unloadObj c_p
|
|
|
|
|
when (not r) (panic "unloadObj: failed")
|
|
|
|
|
rmModule $ case ky of Object s -> s ; Package pk -> pk
|
|
|
|
|
|
|
|
|
|
Shared -> return () -- can't unload .so?
|
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
-- | from ghci/ObjLinker.c
|
|
|
|
|
--
|
|
|
|
|
-- Load a .so type object file.
|
|
|
|
|
--
|
|
|
|
|
loadShared :: FilePath -> IO Module
|
|
|
|
|
loadShared str = do
|
2005-05-07 04:02:12 +00:00
|
|
|
|
str' <- return $ (reverse . drop 1 . dropWhile (/= '.') . reverse) str
|
|
|
|
|
maybe_errmsg <- withCString str' $ \dll -> c_addDLL dll
|
2005-04-24 08:51:33 +00:00
|
|
|
|
if maybe_errmsg == nullPtr
|
|
|
|
|
then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str)))
|
|
|
|
|
else do e <- peekCString maybe_errmsg
|
2005-05-07 03:58:08 +00:00
|
|
|
|
panic $ "loadShared: couldn't load `"++str'++"\' because "++e
|
2005-04-24 08:51:33 +00:00
|
|
|
|
|
|
|
|
|
--
|
|
|
|
|
-- 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
|
2005-05-07 04:02:12 +00:00
|
|
|
|
(libs,dlls) <- lookupPkg p
|
2005-04-24 08:51:33 +00:00
|
|
|
|
mapM_ (\l -> loadObject l (Package (mkModid l))) libs
|
2005-05-07 03:58:08 +00:00
|
|
|
|
mapM_ loadShared dlls
|
2005-04-24 08:51:33 +00:00
|
|
|
|
--
|
|
|
|
|
-- 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
|
2005-05-07 03:58:08 +00:00
|
|
|
|
libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg)
|
2005-04-24 08:51:33 +00:00
|
|
|
|
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
|
|
|
|
|
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
|
2005-05-07 03:58:08 +00:00
|
|
|
|
|
2005-04-24 08:51:33 +00:00
|
|
|
|
-- 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
|
|
|
|
|
#if DEBUG
|
|
|
|
|
when (not (null ps')) $ putStrLn "done"
|
|
|
|
|
putStr "Loading object"
|
|
|
|
|
mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods''
|
|
|
|
|
#endif
|
|
|
|
|
mapM_ (\(hi,m) -> loadObject m (Object hi)) mods''
|
|
|
|
|
return hiface
|
|
|
|
|
|
|
|
|
|
-- ---------------------------------------------------------------------
|
|
|
|
|
-- 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 ()
|