{-# 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
#if MIN_VERSION_ghc(8,10,1)
, lazyInitLlvmConfig
#else
, initLlvmConfig
#endif
)
#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 )
#if !MIN_VERSION_ghc(8,10,1)
lazyInitLlvmConfig = initLlvmConfig
#endif
ifaceModuleName :: ModIface_ phase -> String
ifaceModuleName = ModuleName -> String
moduleNameString (ModuleName -> String)
-> (ModIface_ phase -> ModuleName) -> ModIface_ phase -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> ModuleName)
-> (ModIface_ phase -> Module) -> ModIface_ phase -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface_ phase -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module
readBinIface' :: FilePath -> IO ModIface
readBinIface' :: String -> IO ModIface
readBinIface' String
hi_path = do
#if MIN_VERSION_ghc(7,2,0)
#if MIN_VERSION_ghc(8,8,1)
Settings
mySettings <- String -> IO Settings
initSysTools (String
libdir)
LlvmConfig
llvmConfig <- String -> IO LlvmConfig
lazyInitLlvmConfig (String
libdir)
#else
mySettings <- initSysTools (Just libdir)
llvmConfig <- lazyInitLlvmConfig (Just libdir)
#endif
DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
mySettings LlvmConfig
llvmConfig)
HscEnv
e <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags
#else
e <- newHscEnv defaultCallbacks undefined
#endif
Char
-> HscEnv -> Any -> Any -> TcRnIf Any Any ModIface -> IO ModIface
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'r' HscEnv
e Any
forall a. HasCallStack => a
undefined Any
forall a. HasCallStack => a
undefined (CheckHiWay
-> TraceBinIFaceReading -> String -> TcRnIf Any Any ModIface
forall a b.
CheckHiWay -> TraceBinIFaceReading -> String -> TcRnIf a b ModIface
readBinIface CheckHiWay
IgnoreHiWay TraceBinIFaceReading
QuietBinIFaceReading String
hi_path)
data LoadStatus a
= LoadSuccess Module a
| LoadFailure Errors
load :: FilePath
-> [FilePath]
-> [PackageConf]
-> Symbol
-> IO (LoadStatus a)
load :: String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String]
incpaths [String]
pkgconfs String
sym = do
CInt -> IO ()
initLinker_ (CInt -> IO ()) -> CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
0
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
addPkgConf [String]
pkgconfs
(ModIface
hif,[Module]
moduleDeps) <- String -> [String] -> IO (ModIface, [Module])
loadDepends String
obj [String]
incpaths
#if DEBUG
putStr (' ':(decode $ ifaceModuleName hif)) >> hFlush stdout
#endif
Module
m' <- String -> Key -> IO Module
loadObject String
obj (Key -> IO Module) -> (ModIface -> Key) -> ModIface -> IO Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Key
Object (String -> Key) -> (ModIface -> String) -> ModIface -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName (ModIface -> IO Module) -> ModIface -> IO Module
forall a b. (a -> b) -> a -> b
$ ModIface
hif
let m :: Module
m = Module
m' { iface :: ModIface
iface = ModIface
hif }
IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs ((Module -> IO ()) -> [Module] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Module -> IO ()
unloadAll (Module
mModule -> [Module] -> [Module]
forall a. a -> [a] -> [a]
:[Module]
moduleDeps))
#if DEBUG
putStrLn " ... done" >> hFlush stdout
#endif
Module -> [Module] -> IO ()
addModuleDeps Module
m' [Module]
moduleDeps
Maybe a
v <- Module -> String -> IO (Maybe a)
forall a. Module -> String -> IO (Maybe a)
loadFunction Module
m String
sym
LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ case Maybe a
v of
Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"load: couldn't find symbol <<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
symString -> String -> String
forall a. [a] -> [a] -> [a]
++String
">>"]
Just a
a -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m a
a
load_ :: FilePath
-> [FilePath]
-> Symbol
-> IO (LoadStatus a)
load_ :: String -> [String] -> String -> IO (LoadStatus a)
load_ String
o [String]
i String
s = String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
o [String]
i [] String
s
dynload :: Typeable a
=> FilePath
-> [FilePath]
-> [PackageConf]
-> Symbol
-> IO (LoadStatus a)
dynload :: String -> [String] -> [String] -> String -> IO (LoadStatus a)
dynload String
obj [String]
incpaths [String]
pkgconfs String
sym = do
LoadStatus a
s <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String]
incpaths [String]
pkgconfs String
sym
case LoadStatus a
s of e :: LoadStatus a
e@(LoadFailure [String]
_) -> LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return LoadStatus a
e
LoadSuccess Module
m a
dyn_v -> LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$
case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (a -> Dynamic
unsafeCoerce# a
dyn_v :: Dynamic) of
Just a
v' -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m a
v'
Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"Mismatched types in interface"]
pdynload :: FilePath
-> [FilePath]
-> [PackageConf]
-> Type
-> Symbol
-> IO (LoadStatus a)
pdynload :: String
-> [String] -> [String] -> String -> String -> IO (LoadStatus a)
pdynload String
object [String]
incpaths [String]
pkgconfs String
ty String
sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
([String]
errors, Bool
success) <- String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
object [String]
incpaths [] String
ty String
sym
#if DEBUG
putStrLn "done"
#endif
if Bool
success
then String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
object [String]
incpaths [String]
pkgconfs String
sym
else LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String]
errors
pdynload_ :: FilePath
-> [FilePath]
-> [PackageConf]
-> [Arg]
-> Type
-> Symbol
-> IO (LoadStatus a)
pdynload_ :: String
-> [String]
-> [String]
-> [String]
-> String
-> String
-> IO (LoadStatus a)
pdynload_ String
object [String]
incpaths [String]
pkgconfs [String]
args String
ty String
sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
([String]
errors, Bool
success) <- String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
object [String]
incpaths [String]
args String
ty String
sym
#if DEBUG
putStrLn "done"
#endif
if Bool
success
then String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
object [String]
incpaths [String]
pkgconfs String
sym
else LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String]
errors
unify :: String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
obj [String]
incs [String]
args String
ty String
sym = do
(String
tmpf,Handle
hdl) <- IO (String, Handle)
mkTemp
(String
tmpf1,Handle
hdl1) <- IO (String, Handle)
mkTemp
Handle -> IO ()
hClose Handle
hdl1
let nm :: String
nm = String -> String
mkModid (String -> String
basename String
tmpf)
src :: String
src = String -> String -> String -> String -> String -> String
mkTest String
nm (String -> String
hierize' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
mkModid (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
hierize (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
obj)
((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') String
ty) String
ty String
sym
is :: [String]
is = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-i"String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
incs
i :: String
i = String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
dirname String
obj
Handle -> String -> IO ()
hWrite Handle
hdl String
src
([String]
e,Bool
success) <- String -> String -> [String] -> IO ([String], Bool)
build String
tmpf String
tmpf1 (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
is[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
args[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
"-fno-code",String
"-c",String
"-ohi "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
tmpf1])
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFile [String
tmpf,String
tmpf1]
([String], Bool) -> IO ([String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
e, Bool
success)
where
hierize :: String -> String
hierize [] = []
hierize (Char
'/':String
cs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize String
cs
hierize (Char
c:String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize String
cs
hierize' :: String -> String
hierize'[] = []
hierize' (Char
'\\':String
cs) = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize' String
cs
hierize' (Char
c:String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize' String
cs
mkTest :: String -> String -> String -> String -> String -> String
mkTest String
modnm String
plugin String
api String
ty String
sym =
String
"module "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modnm String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" where" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\nimport qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plugin String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\nimport qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
api String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"{-# LINE 1 \"<typecheck>\" #-}" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\n_ = "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plugin String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"."String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sym String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" :: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ty
unload :: Module -> IO ()
unload :: Module -> IO ()
unload Module
m = Module -> IO ()
rmModuleDeps Module
m IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Module -> IO ()
unloadObj Module
m
unloadAll :: Module -> IO ()
unloadAll :: Module -> IO ()
unloadAll Module
m = do [Module]
moduleDeps <- Module -> IO [Module]
getModuleDeps Module
m
Module -> IO ()
rmModuleDeps Module
m
(Module -> IO ()) -> [Module] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Module -> IO ()
unloadAll [Module]
moduleDeps
Module -> IO ()
unload Module
m
reload :: Module -> Symbol -> IO (LoadStatus a)
reload :: Module -> String -> IO (LoadStatus a)
reload m :: Module
m@(Module{path :: Module -> String
path = String
p, iface :: Module -> ModIface
iface = ModIface
hi}) String
sym = do
Module -> IO ()
unloadObj Module
m
#if DEBUG
putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
#endif
Module
m_ <- String -> Key -> IO Module
loadObject String
p (Key -> IO Module) -> (ModIface -> Key) -> ModIface -> IO Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Key
Object (String -> Key) -> (ModIface -> String) -> ModIface -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName (ModIface -> IO Module) -> ModIface -> IO Module
forall a b. (a -> b) -> a -> b
$ ModIface
hi
let m' :: Module
m' = Module
m_ { iface :: ModIface
iface = ModIface
hi }
IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs (Module -> IO ()
unloadAll Module
m)
#if DEBUG
putStrLn "done" >> hFlush stdout
#endif
Maybe a
v <- Module -> String -> IO (Maybe a)
forall a. Module -> String -> IO (Maybe a)
loadFunction Module
m' String
sym
LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ case Maybe a
v of
Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"load: couldn't find symbol <<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
symString -> String -> String
forall a. [a] -> [a] -> [a]
++String
">>"]
Just a
a -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m' a
a
initLinker :: IO ()
initLinker :: IO ()
initLinker = CInt -> IO ()
initLinker_ (CInt -> IO ()) -> CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
0
loadFunction :: Module
-> String
-> IO (Maybe a)
loadFunction :: Module -> String -> IO (Maybe a)
loadFunction (Module { iface :: Module -> ModIface
iface = ModIface
i }) String
valsym
= String -> String -> IO (Maybe a)
forall a. String -> String -> IO (Maybe a)
loadFunction_ (ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName ModIface
i) String
valsym
loadFunction_ :: String
-> String
-> IO (Maybe a)
loadFunction_ :: String -> String -> IO (Maybe a)
loadFunction_ = Maybe String -> String -> String -> IO (Maybe a)
forall a. Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ Maybe String
forall a. Maybe a
Nothing
loadFunction__ :: Maybe String
-> String
-> String
-> IO (Maybe a)
loadFunction__ :: Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ Maybe String
pkg String
m String
valsym
= do let encode :: String -> String
encode = String -> String
zEncodeString
String
p <- case Maybe String
pkg of
Just String
p -> do
Maybe String
prefix <- String -> IO (Maybe String)
pkgManglingPrefix String
p
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
encode (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
p String -> String
forall a. a -> a
id Maybe String
prefix)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"
Maybe String
Nothing -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
let symbol :: String
symbol = String
prefixUnderscoreString -> String -> String
forall a. [a] -> [a] -> [a]
++String
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
encode String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"String -> String -> String
forall a. [a] -> [a] -> [a]
++(String -> String
encode String
valsym)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_closure"
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
initLinker
#endif
ptr :: Ptr Any
ptr@(Ptr Addr#
addr) <- String -> (CString -> IO (Ptr Any)) -> IO (Ptr Any)
forall a. String -> (CString -> IO a) -> IO a
withCString String
symbol CString -> IO (Ptr Any)
forall a. CString -> IO (Ptr a)
c_lookupSymbol
if (Ptr Any
ptr Ptr Any -> Ptr Any -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Any
forall a. Ptr a
nullPtr)
then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
#if !MIN_VERSION_ghc(7,4,1)
else case addrToHValue# addr of
#else
else case Addr# -> (# a #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
#endif
(# a
hval #) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a -> Maybe a
forall a. a -> Maybe a
Just a
hval )
loadPackageFunction :: String
-> String
-> String
-> IO (Maybe a)
loadPackageFunction :: String -> String -> String -> IO (Maybe a)
loadPackageFunction String
pkgName String
modName String
functionName =
do String -> IO ()
loadPackage String
pkgName
IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs (String -> IO ()
unloadPackage String
pkgName)
Maybe String -> String -> String -> IO (Maybe a)
forall a. Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ (String -> Maybe String
forall a. a -> Maybe a
Just String
pkgName) String
modName String
functionName
loadObject :: FilePath -> Key -> IO Module
loadObject :: String -> Key -> IO Module
loadObject String
p ky :: Key
ky@(Object String
k) = String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k
loadObject String
p ky :: Key
ky@(Package String
k) = String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k
loadObject' :: FilePath -> Key -> String -> IO Module
loadObject' :: String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k
= do Bool
alreadyLoaded <- String -> IO Bool
isLoaded String
k
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
alreadyLoaded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let ld :: CString -> IO Bool
ld = if String
sysPkgSuffix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
p
then CString -> IO Bool
c_loadArchive
else CString -> IO Bool
c_loadObj
Bool
r <- String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
p CString -> IO Bool
ld
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not load module or package `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'")
let hifile :: String
hifile = String -> String -> String
replaceSuffix String
p String
hiSuf
Bool
exists <- String -> IO Bool
doesFileExist String
hifile
ModIface
hiface <- if Bool
exists then String -> IO ModIface
readBinIface' String
hifile else ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
forall a. HasCallStack => a
undefined
let m :: Module
m = String -> ModIface -> Module
emptyMod String
p ModIface
hiface
String -> Module -> IO ()
addModule String
k Module
m
Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
where emptyMod :: String -> ModIface -> Module
emptyMod String
q ModIface
hiface = String -> String -> ObjType -> ModIface -> Key -> Module
Module String
q (String -> String
mkModid String
q) ObjType
Vanilla ModIface
hiface Key
ky
loadModule :: FilePath -> IO Module
loadModule :: String -> IO Module
loadModule String
obj = do
let hifile :: String
hifile = String -> String -> String
replaceSuffix String
obj String
hiSuf
Bool
exists <- String -> IO Bool
doesFileExist String
hifile
if (Bool -> Bool
not Bool
exists)
then String -> IO Module
forall a. HasCallStack => String -> a
error (String -> IO Module) -> String -> IO Module
forall a b. (a -> b) -> a -> b
$ String
"No .hi file found for "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
obj
else do ModIface
hiface <- String -> IO ModIface
readBinIface' String
hifile
String -> Key -> IO Module
loadObject String
obj (String -> Key
Object (ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName ModIface
hiface))
loadRawObject :: FilePath -> IO Module
loadRawObject :: String -> IO Module
loadRawObject String
obj = String -> Key -> IO Module
loadObject String
obj (String -> Key
Object String
k)
where
k :: String
k = String -> String
encode (String -> String
mkModid String
obj)
resolveObjs :: IO a -> IO ()
resolveObjs :: IO a -> IO ()
resolveObjs IO a
unloadLoaded
= do Bool
r <- IO Bool
c_resolveObjs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO a
unloadLoaded IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
forall a. String -> IO a
panic String
"resolvedObjs failed."
unloadObj :: Module -> IO ()
unloadObj :: Module -> IO ()
unloadObj (Module { path :: Module -> String
path = String
p, kind :: Module -> ObjType
kind = ObjType
k, key :: Module -> Key
key = Key
ky }) = case ObjType
k of
ObjType
Vanilla -> String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
p ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
c_p -> do
Bool
removed <- String -> IO Bool
rmModule String
name
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
removed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Bool
r <- CString -> IO Bool
c_unloadObj CString
c_p
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic String
"unloadObj: failed")
ObjType
Shared -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where name :: String
name = case Key
ky of Object String
s -> String
s ; Package String
pk -> String
pk
loadShared :: FilePath -> IO Module
loadShared :: String -> IO Module
loadShared String
str' = do
#if DEBUG
putStrLn $ " shared: " ++ str'
#endif
let str :: String
str = case String
str' of
String
"libm.so" -> String
"/lib/x86_64-linux-gnu/libm.so.6"
String
"libpthread.so" -> String
"/lib/x86_64-linux-gnu/libpthread.so.0"
String
x -> String
x
CString
maybe_errmsg <- String -> (CString -> IO CString) -> IO CString
forall a. String -> (CString -> IO a) -> IO a
withCString String
str ((CString -> IO CString) -> IO CString)
-> (CString -> IO CString) -> IO CString
forall a b. (a -> b) -> a -> b
$ \CString
dll -> CString -> IO CString
c_addDLL CString
dll
if CString
maybe_errmsg CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
then Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> ObjType -> ModIface -> Key -> Module
Module String
str (String -> String
mkModid String
str) ObjType
Shared ModIface
forall a. HasCallStack => a
undefined (String -> Key
Package (String -> String
mkModid String
str)))
else do String
e <- CString -> IO String
peekCString CString
maybe_errmsg
String -> IO Module
forall a. String -> IO a
panic (String -> IO Module) -> String -> IO Module
forall a b. (a -> b) -> a -> b
$ String
"loadShared: couldn't load `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\' because "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
e
loadPackage :: String -> IO ()
loadPackage :: String -> IO ()
loadPackage String
p = do
IO ()
initLinker
#if DEBUG
putStr (' ':p) >> hFlush stdout
#endif
([String]
libs,[String]
dlls) <- String -> IO ([String], [String])
lookupPkg String
p
(String -> IO Module) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
l -> String -> Key -> IO Module
loadObject String
l (String -> Key
Package (String -> String
mkModid String
l))) [String]
libs
#if DEBUG
putStr (' ':show libs) >> hFlush stdout
putStr (' ':show dlls) >> hFlush stdout
#endif
(String -> IO Module) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO Module
loadShared [String]
dlls
unloadPackage :: String -> IO ()
unloadPackage :: String -> IO ()
unloadPackage String
pkg = do
let pkg' :: String
pkg' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') String
pkg
[String]
libs <- (([String], [String]) -> [String])
-> IO ([String], [String]) -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\([String]
a,[String]
_) -> ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSublistOf String
pkg') ) [String]
a) (String -> IO ([String], [String])
lookupPkg String
pkg)
((String -> IO Bool) -> [String] -> IO ())
-> [String] -> (String -> IO Bool) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> IO Bool) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [String]
libs ((String -> IO Bool) -> IO ()) -> (String -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
p -> String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
p ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
c_p -> do
Bool
r <- CString -> IO Bool
c_unloadObj CString
c_p
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic String
"unloadObj: failed")
String -> IO Bool
rmModule (String -> String
mkModid String
p)
loadPackageWith :: String -> [PackageConf] -> IO ()
loadPackageWith :: String -> [String] -> IO ()
loadPackageWith String
p [String]
pkgconfs = do
#if DEBUG
putStr "Loading package" >> hFlush stdout
#endif
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
addPkgConf [String]
pkgconfs
String -> IO ()
loadPackage String
p
#if DEBUG
putStrLn " done"
#endif
loadDepends :: FilePath -> [FilePath] -> IO (ModIface,[Module])
loadDepends :: String -> [String] -> IO (ModIface, [Module])
loadDepends String
obj [String]
incpaths = do
let hifile :: String
hifile = String -> String -> String
replaceSuffix String
obj String
hiSuf
Bool
exists <- String -> IO Bool
doesFileExist String
hifile
if (Bool -> Bool
not Bool
exists)
then do
#if DEBUG
putStrLn "No .hi file found." >> hFlush stdout
#endif
(ModIface, [Module]) -> IO (ModIface, [Module])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
forall a. HasCallStack => a
undefined,[])
else do ModIface
hiface <- String -> IO ModIface
readBinIface' String
hifile
let ds :: Dependencies
ds = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
hiface
[String]
ds' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
loaded ([String] -> IO [String])
-> (Dependencies -> [String]) -> Dependencies -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Bool) -> String) -> [(ModuleName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> String
moduleNameString (ModuleName -> String)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) ([(ModuleName, Bool)] -> [String])
-> (Dependencies -> [(ModuleName, Bool)])
-> Dependencies
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(ModuleName, Bool)]
dep_mods (Dependencies -> IO [String]) -> Dependencies -> IO [String]
forall a b. (a -> b) -> a -> b
$ Dependencies
ds
let mods_ :: [(String, String)]
mods_ = (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> (String
s, (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c ->
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'/' else Char
c) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
s)) [String]
ds'
let mods :: [(String, String)]
mods = (String -> [(String, String)]) -> [String] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
p ->
((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
hi,String
m) -> (String
hi,String
p String -> String -> String
</> String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".o")) [(String, String)]
mods_) [String]
incpaths
[(String, String)]
mods' <- ((String, String) -> IO Bool)
-> [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(String
_,String
y) -> String -> IO Bool
doesFileExist String
y) ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$
((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, String)
v (String, String)
u -> (String, String) -> String
forall a b. (a, b) -> b
snd (String, String)
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> b
snd (String, String)
u) [(String, String)]
mods
let mods'' :: [(String, String)]
mods'' = ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, String)
v (String, String)
u -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
u) [(String, String)]
mods'
let ps :: [(InstalledUnitId, Bool)]
ps = Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs Dependencies
ds
#if MIN_VERSION_ghc(8,0,0)
#if MIN_VERSION_Cabal(2,0,0)
[String]
ps' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
loaded ([String] -> IO [String])
-> ([InstalledUnitId] -> [String])
-> [InstalledUnitId]
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId -> String) -> [InstalledUnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> String
installedUnitIdString ([InstalledUnitId] -> [String])
-> ([InstalledUnitId] -> [InstalledUnitId])
-> [InstalledUnitId]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledUnitId] -> [InstalledUnitId]
forall a. Eq a => [a] -> [a]
nub ([InstalledUnitId] -> IO [String])
-> [InstalledUnitId] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst [(InstalledUnitId, Bool)]
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
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
loadPackage [String]
ps'
#if DEBUG
when (not (null ps')) $
putStr " ... linking ... " >> hFlush stdout
#endif
IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
unloadPackage [String]
ps')
#if DEBUG
when (not (null ps')) $ putStrLn "done"
putStr "Loading object"
mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods''
#endif
[Module]
moduleDeps <- ((String, String) -> IO Module)
-> [(String, String)] -> IO [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(String
hi,String
m) -> String -> Key -> IO Module
loadObject String
m (String -> Key
Object String
hi)) [(String, String)]
mods''
(ModIface, [Module]) -> IO (ModIface, [Module])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
hiface,[Module]
moduleDeps)
getImports :: String -> IO [String]
getImports :: String -> IO [String]
getImports String
m = do
ModIface
hi <- String -> IO ModIface
readBinIface' (String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hiSuf)
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> (ModIface -> [String]) -> ModIface -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Bool) -> String) -> [(ModuleName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> String
moduleNameString (ModuleName -> String)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) ([(ModuleName, Bool)] -> [String])
-> (ModIface -> [(ModuleName, Bool)]) -> ModIface -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(ModuleName, Bool)]
dep_mods (Dependencies -> [(ModuleName, Bool)])
-> (ModIface -> Dependencies) -> ModIface -> [(ModuleName, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps (ModIface -> IO [String]) -> ModIface -> IO [String]
forall a b. (a -> b) -> a -> b
$ ModIface
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 ()