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 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
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 }
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))
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
loadModuleFromPath :: FilePath -> Maybe FilePath -> IO DynamicModule
loadModuleFromPath path mbase
= do c_initLinker
base <- maybe getCurrentDirectory return mbase
qual <- dropIsEq base path
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''
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
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
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
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
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)
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)
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
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)
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
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
resolveFunctions :: IO ()
resolveFunctions
= do c_initLinker
ret <- c_resolveObjs
when (ret == 0) (fail "Unable to resolve functions!")
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
symbolName = (if os == "darwin" then "_" else "") ++ moduleName ++ "_" ++ realFunctionName ++ "_closure"
encode :: String -> String
encode str = concatMap encode_ch str
unencodedChar :: Char -> Bool
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]
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"