{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module System.Plugins.Load (
LoadStatus(..)
, load
, load_
, dynload
, pdynload
, pdynload_
, unload
, unloadAll
, reload
, Module(..)
, initLinker
, loadModule
, loadFunction
, loadFunction_
, loadPackageFunction
, loadPackage
, unloadPackage
, loadPackageWith
, loadShared
, resolveObjs
, loadRawObject
, 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 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, initLlvmConfig)
#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
#if MIN_VERSION_ghc(7,2,0)
#if MIN_VERSION_ghc(8,8,1)
mySettings <- initSysTools (libdir)
llvmConfig <- initLlvmConfig (libdir)
#else
mySettings <- initSysTools (Just libdir)
llvmConfig <- initLlvmConfig (Just libdir)
#endif
dflags <- initDynFlags (defaultDynFlags mySettings llvmConfig)
e <- newHscEnv dflags
#else
e <- newHscEnv defaultCallbacks undefined
#endif
initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path)
data LoadStatus a
= LoadSuccess Module a
| LoadFailure Errors
load :: FilePath
-> [FilePath]
-> [PackageConf]
-> Symbol
-> IO (LoadStatus a)
load obj incpaths pkgconfs sym = do
initLinker_ $ fromIntegral 0
mapM_ addPkgConf pkgconfs
(hif,moduleDeps) <- loadDepends obj incpaths
#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
load_ :: FilePath
-> [FilePath]
-> Symbol
-> IO (LoadStatus a)
load_ o i s = load o i [] s
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"]
pdynload :: FilePath
-> [FilePath]
-> [PackageConf]
-> Type
-> Symbol
-> IO (LoadStatus a)
pdynload object incpaths pkgconfs ty sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
(errors, success) <- unify object incpaths [] ty sym
#if DEBUG
putStrLn "done"
#endif
if success
then load object incpaths pkgconfs sym
else return $ LoadFailure errors
pdynload_ :: FilePath
-> [FilePath]
-> [PackageConf]
-> [Arg]
-> Type
-> Symbol
-> IO (LoadStatus a)
pdynload_ object incpaths pkgconfs args ty sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
(errors, success) <- unify object incpaths args ty sym
#if DEBUG
putStrLn "done"
#endif
if success
then load object incpaths pkgconfs sym
else return $ LoadFailure errors
unify obj incs args ty sym = do
(tmpf,hdl) <- mkTemp
(tmpf1,hdl1) <- mkTemp
hClose hdl1
let nm = mkModid (basename tmpf)
src = mkTest nm (hierize' . mkModid . hierize $ obj)
(fst $ break (=='.') ty) ty sym
is = map ("-i"++) incs
i = "-i" ++ dirname obj
hWrite hdl src
(e,success) <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1])
mapM_ removeFile [tmpf,tmpf1]
return (e, success)
where
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
unload :: Module -> IO ()
unload m = rmModuleDeps m >> unloadObj m
unloadAll :: Module -> IO ()
unloadAll m = do moduleDeps <- getModuleDeps m
rmModuleDeps m
mapM_ unloadAll moduleDeps
unload m
reload :: Module -> Symbol -> IO (LoadStatus a)
reload m@(Module{path = p, iface = hi}) sym = do
unloadObj m
#if DEBUG
putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
#endif
m_ <- loadObject p . Object . ifaceModuleName $ hi
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
initLinker :: IO ()
initLinker = initLinker_ $ fromIntegral 0
loadFunction :: Module
-> String
-> IO (Maybe a)
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 encode = zEncodeString
p <- case pkg of
Just p -> do
prefix <- pkgManglingPrefix p
return $ encode (maybe p id prefix)++"_"
Nothing -> return ""
let symbol = prefixUnderscore++p++encode m++"_"++(encode valsym)++"_closure"
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
initLinker
#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 )
loadPackageFunction :: String
-> String
-> String
-> IO (Maybe a)
loadPackageFunction pkgName modName functionName =
do loadPackage pkgName
resolveObjs (unloadPackage pkgName)
loadFunction__ (Just pkgName) modName functionName
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
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))
loadRawObject :: FilePath -> IO Module
loadRawObject obj = loadObject obj (Object k)
where
k = encode (mkModid obj)
resolveObjs :: IO a -> IO ()
resolveObjs unloadLoaded
= do r <- c_resolveObjs
when (not r) $ unloadLoaded >> panic "resolvedObjs failed."
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 ()
where name = case ky of Object s -> s ; Package pk -> pk
loadShared :: FilePath -> IO Module
loadShared str' = do
#if DEBUG
putStrLn $ " shared: " ++ str'
#endif
let str = case str' of
"libm.so" -> "/lib/x86_64-linux-gnu/libm.so.6"
"libpthread.so" -> "/lib/x86_64-linux-gnu/libpthread.so.0"
x -> x
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
loadPackage :: String -> IO ()
loadPackage p = do
initLinker
#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
unloadPackage :: String -> IO ()
unloadPackage pkg = do
let pkg' = takeWhile (/= '-') pkg
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)
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
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,[])
else do hiface <- readBinIface' hifile
let ds = mi_deps hiface
ds' <- filterM loaded . map (moduleNameString . fst) . dep_mods $ ds
let mods_ = map (\s -> (s, map (\c ->
if c == '.' then '/' else c) $ s)) ds'
let mods = concatMap (\p ->
map (\(hi,m) -> (hi,p </> m++".o")) mods_) incpaths
mods' <- filterM (\(_,y) -> doesFileExist y) $
nubBy (\v u -> snd v == snd u) mods
let mods'' = nubBy (\v u -> fst v == fst u) mods'
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)
getImports :: String -> IO [String]
getImports m = do
hi <- readBinIface' (m ++ hiSuf)
return . map (moduleNameString . fst) . dep_mods . mi_deps $ hi
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 ()