dynamic-loader-0.0.1: System/Plugins/DynamicLoader.hs
{-# LANGUAGE MagicHash, UnboxedTuples #-}
----------------------------------------------------------------------------
-- |
-- Module : DynamicLoader
-- Copyright : (c) Hampus Ram 2003-2004, Gabor Greif 2012
-- License : BSD-style (see LICENSE)
--
-- Maintainer : ggreif+dynamic@gmail.com
-- Stability : experimental
-- Portability : non-portable (ghc >= 7.6 only)
--
-- A module that implements dynamic loading. You can load
-- and use GHC object files and packages dynamically at runtime.
--
----------------------------------------------------------------------------
module System.Plugins.DynamicLoader (DynamicModule,
dm_path,
DynamicPackage,
dp_path,
DynamicArchive,
da_path,
addDLL,
loadModule,
loadModuleFromPath,
loadPackage,
loadPackageFromPath,
loadArchiveFromPath,
unloadModule,
unloadPackage,
unloadArchive,
loadFunction,
loadQualifiedFunction,
resolveFunctions) where
import Data.Char (ord)
import Data.List
import Control.Monad
import GHC.Exts
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.C.String (CString, withCString, peekCString)
import System.Directory (getCurrentDirectory, doesFileExist)
import GHC.Prim
import System.Info (os)
{-
Foreign imports, hooks into the GHC RTS.
-}
foreign import ccall unsafe "initLinker"
c_initLinker :: IO ()
foreign import ccall unsafe "loadObj"
c_loadObj :: CString -> IO Int
foreign import ccall unsafe "unloadObj"
c_unloadObj :: CString -> IO Int
foreign import ccall unsafe "loadArchive"
c_loadArchive :: CString -> IO Int
foreign import ccall unsafe "resolveObjs"
c_resolveObjs :: IO Int
foreign import ccall unsafe "lookupSymbol"
c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall unsafe "addDLL"
c_addDLL :: CString -> IO CString
-- split up qualified name so one could easily transform it
-- into A.B.C or A/B/C depending on context
data DynamicModule = RTM { dm_qname :: [String],
dm_path :: FilePath }
data DynamicPackage = RTP { dp_path :: FilePath,
dp_cbits :: Maybe DynamicPackage }
newtype DynamicArchive = RTA { da_path :: FilePath }
{-|
Dynamically load a shared library (DLL or .so). A shared library can't
be unloaded using this interface, if you need it use
System.Posix.DynamicLinker instead.
-}
addDLL :: String -> IO ()
addDLL str
= do c_initLinker
withCString str
(\s -> do err <- c_addDLL s
unless (err == nullPtr)
(do msg <- peekCString err
fail $ "Unable to load library: " ++ str ++ "\n " ++ msg))
{-|
Load a module given its name (for instance @Data.FiniteMap@), maybe a
path to the base directory and maybe a file extension. If no such path
is given the current working directory is used and if no file suffix
is given \"o\" is used.
If we have our module hierarchy in @\/usr\/lib\/modules@ and we want to
load the module @Foo.Bar@ located in @\/usr\/lib\/modules\/Foo\/Bar.o@ we
could issue the command:
@loadModule \"Foo.Bar\" (Just \"\/usr\/lib\/modules\") Nothing@
If our current directory was @\/tmp@ and we wanted to load the module
@Foo@ located in the file @\/tmp\/Foo.obj@ we would write:
@loadModule \"Foo\" Nothing (Just \"obj\")@
If it cannot load the object it will throw an exception.
-}
loadModule :: String -> Maybe FilePath -> Maybe String -> IO DynamicModule
loadModule name mpath msuff
= do c_initLinker
base <- maybe getCurrentDirectory return mpath
let qname = split '.' name
suff = maybe "o" id msuff
path = base ++ '/' : concat (intersperse "/" qname) ++
'.' : suff
ret <- withCString path c_loadObj
if ret /= 0
then return (RTM qname path)
else fail $ "Unable to load module: " ++ path
{-|
Load a module given its full path and maybe a base directory to use in
figuring out the module's hierarchical name. If no base directory is
given, it is set to the current directory.
For instance if one wants to load module @Foo.Bar@ located in
@\/usr\/modules\/Foo\/Bar.o@ one would issue the command:
@loadModuleFromPath \"\/usr\/modules\/Foo\/Bar.o\" (Just
\"\/usr\/modules\")@
If it cannot load the object it will throw an exception.
-}
loadModuleFromPath :: FilePath -> Maybe FilePath -> IO DynamicModule
loadModuleFromPath path mbase
= do c_initLinker
base <- maybe getCurrentDirectory return mbase
qual <- dropIsEq base path
-- not very smart but simple...
let name = reverse $ drop 1 $ dropWhile (/='.') $
reverse $ if head qual == '/' then drop 1 qual else qual
qname = split '/' name
ret <- withCString path c_loadObj
if ret /= 0
then return (RTM qname path)
else fail $ "Unable to load module: " ++ path
where dropIsEq [] ys = return ys
dropIsEq (x:xs) (y:ys)
| x == y = dropIsEq xs ys
| otherwise = fail $ "Unable to get qualified name from: "
++ path
dropIsEq _ _ = fail $ "Unable to get qualified name from: " ++ path
split :: Char -> String -> [String]
split _ "" = []
split c s = let (l,s') = break (c==) s
in l : case s' of [] -> []
(_:s'') -> split c s''
{-|
Load a GHC package such as \"base\" or \"text\". Takes the package name,
maybe a path to the packages, maybe a package prefix and maybe a
package suffix.
Path defaults to the current directory, package prefix to \"HS\" and
package suffix to \"o\".
This function also loads accompanying cbits-packages. I.e. if you load
the package @base@ located in @\/usr\/modules@ using @HS@ and @o@ as
prefix and suffix, @loadPackage@ will also look for the file
@\/usr\/modules\/HSbase_cbits.o@ and load it if present.
If it fails to load a package it will throw an exception. You will
need to resolve functions before you use any functions loaded.
-}
loadPackage :: String -> Maybe FilePath -> Maybe String -> Maybe String ->
IO DynamicPackage
loadPackage name mpath mpre msuff
= do c_initLinker
base <- case mpath of
Just a -> return a
_ -> getCurrentDirectory
let path = packageName name base mpre msuff
ret <- withCString path c_loadObj
unless (ret /= 0) (fail $ "Unable to load package: " ++ name)
let cbits_path = packageName (name ++ "_cbits") base mpre msuff
-- this will generate an extra unnecessary call checking for
-- FOO_cbits_cbits, but it looks nicer!
cbitsExist <- doesFileExist cbits_path
if cbitsExist
then do rtp <- loadPackage (name ++ "_cbits") mpath mpre msuff
return (RTP path (Just rtp))
else return (RTP path Nothing)
where packageName :: String -> FilePath -> Maybe String ->
Maybe String -> FilePath
packageName name path mpre msuff
= let prefix = maybe "HS" id mpre
suffix = maybe "o" id msuff
in path ++ '/' : prefix ++ name ++ '.' : suffix
{-|
Load a GHC package such as \"base\" or \"text\". Takes the full path to
the package.
This function also loads accompanying cbits-packages. I.e. if you load
the package @\/usr\/modules\/HSbase.o@ it will deduce that @o@ is the
suffix and @loadPackageFromPath@ will then also look for the file
@\/usr\/modules\/HSbase_cbits.o@ and load it if present.
If it fails to load a package it will throw an exception. You will
need to resolve functions before you use any functions loaded.
-}
loadPackageFromPath :: FilePath -> IO DynamicPackage
loadPackageFromPath path
= do c_initLinker
ret <- withCString path c_loadObj
unless (ret /= 0) (fail $ "Unable to load package: " ++ path)
let cbits_path = cbitsName path
-- this will generate an extra unnecessary call checking for
-- FOO_cbits_cbits, but it looks nicer!
cbitsExist <- doesFileExist cbits_path
if cbitsExist
then do rtp <- loadPackageFromPath cbits_path
return (RTP path (Just rtp))
else return (RTP path Nothing)
where cbitsName :: FilePath -> String
cbitsName name
= let suffix = reverse $! takeWhile (/='.') rname
rname = reverse name
in reverse (drop (length suffix + 1) rname) ++
"_cbits." ++ suffix -- wrong but simple...
{-|
Load an archive of GHC modules. Recent versions of GHC store packages
as archives.
If it fails to load the archive it will throw an exception. You will
need to resolve functions before you use any functions loaded.
-}
loadArchiveFromPath :: FilePath -> IO DynamicArchive
loadArchiveFromPath path
= do c_initLinker
ret <- withCString path c_loadArchive
unless (ret /= 0) (fail $ "Unable to load archive: " ++ path)
return (RTA path)
{-|
Unload an archive. Throws an exception if any unloading fails.
-}
unloadArchive :: DynamicArchive -> IO ()
unloadArchive (RTA { da_path = path })
= do c_initLinker
ret <- withCString path c_unloadObj
unless (ret /= 0) (fail $ "Unable to unload archive: " ++ path)
{-|
Unload a package (such as @base@) and its cbits-package (if
any). Throws an exception if any unloading fails.
-}
unloadPackage :: DynamicPackage -> IO ()
unloadPackage (RTP { dp_path = path, dp_cbits = cbits })
= do c_initLinker
ret <- withCString path c_unloadObj
unless (ret /= 0) (fail $ "Unable to unload package: " ++ path)
maybe (return ()) unloadPackage cbits
{-|
Unload a previously loaded module. If it cannot unload it an exception
will be thrown.
-}
unloadModule :: DynamicModule -> IO ()
unloadModule (RTM { dm_path = path })
= do c_initLinker
ret <- withCString path c_unloadObj
unless (ret /= 0) (fail $ "Unable to unload module: " ++ path)
{-|
Load a function from a given module. If the function can't be found an
exception will be thrown. You should have called @resolveFunctions@ before
you call this.
Beware that this function isn't type-safe in any way!
-}
loadFunction :: DynamicModule -> String -> IO a
loadFunction dm functionName
= do c_initLinker
Ptr addr <- lookupSymbol (dm_qname dm) functionName
case addrToAny# addr of
(# hval #) -> return hval
{-|
Load a function from package (or module) given the fully qualified
name (e.g. @Data.FiniteMap.emptyFM@). If the function can't be found an
exception will be thrown. You should have called @resolveFunctions@
before you call this.
You must take care that you load the function qualified with the name
of the module it's defined in! You can for instance not load
@Data.Bool.not@ because it is only reexported in that module (from
GHC.Base).
Beware that this function isn't type-safe in any way!
-}
loadQualifiedFunction :: String -> IO a
loadQualifiedFunction functionName
= do c_initLinker
let qfunc = split '.' functionName
Ptr addr <- lookupSymbol (init qfunc) (last qfunc)
case addrToAny# addr of
(# hval #) -> return hval
{-|
Resolve all loaded functions. Should be called before any functions
are loaded. If it is unable to resolve all functions it will throw an
exception.
-}
resolveFunctions :: IO ()
resolveFunctions
= do c_initLinker
ret <- c_resolveObjs
when (ret == 0) (fail "Unable to resolve functions!")
{-|
Find a symbol in a module's symbol-table. Throw an exception if it
isn't found.
-}
lookupSymbol :: [String] -> String -> IO (Ptr a)
lookupSymbol qname functionName
= do ptr <- withCString symbolName c_lookupSymbol
if ptr /= nullPtr
then return ptr
else fail $ "Could not load symbol: " ++ symbolName
where
moduleName = encode $ concat (intersperse "." qname)
realFunctionName = encode functionName
-- On OS X all functions have an extra _.
symbolName = (if os == "darwin" then "_" else "") ++ moduleName ++ "_" ++ realFunctionName ++ "_closure"
encode :: String -> String
encode str = concatMap encode_ch str
unencodedChar :: Char -> Bool -- True for chars that don't need encoding
unencodedChar 'Z' = False
unencodedChar 'z' = False
unencodedChar c = c >= 'a' && c <= 'z'
|| c >= 'A' && c <= 'Z'
|| c >= '0' && c <= '9'
encode_ch c | unencodedChar c = [c] -- Common case first
encode_ch 'Z' = "ZZ"
encode_ch 'z' = "zz"
encode_ch '&' = "za"
encode_ch '|' = "zb"
encode_ch '^' = "zc"
encode_ch '$' = "zd"
encode_ch '=' = "ze"
encode_ch '>' = "zg"
encode_ch '#' = "zh"
encode_ch '.' = "zi"
encode_ch '<' = "zl"
encode_ch '-' = "zm"
encode_ch '!' = "zn"
encode_ch '+' = "zp"
encode_ch '\'' = "zq"
encode_ch '\\' = "zr"
encode_ch '/' = "zs"
encode_ch '*' = "zt"
encode_ch '_' = "zu"
encode_ch '%' = "zv"
encode_ch c = 'z' : shows (ord c) "U"