Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc
[ghc.git] / compiler / ghci / ObjLink.lhs
1 %
2 % (c) The University of Glasgow, 2000-2006
3 %
4
5 -- ---------------------------------------------------------------------------
6 --      The dynamic linker for object code (.o .so .dll files)
7 -- ---------------------------------------------------------------------------
8
9 Primarily, this module consists of an interface to the C-land dynamic linker.
10
11 \begin{code}
12 module ObjLink (
13    initObjLinker,        -- :: IO ()
14    loadDLL,              -- :: String -> IO (Maybe String)
15    loadArchive,          -- :: String -> IO ()
16    loadObj,              -- :: String -> IO ()
17    unloadObj,            -- :: String -> IO ()
18    insertSymbol,         -- :: String -> String -> Ptr a -> IO ()
19    lookupSymbol,         -- :: String -> IO (Maybe (Ptr a))
20    resolveObjs           -- :: IO SuccessFlag
21   )  where
22
23 import Panic
24 import BasicTypes       ( SuccessFlag, successIf )
25 import Config           ( cLeadingUnderscore )
26 import Util
27
28 import Control.Monad    ( when )
29 import Foreign.C
30 import Foreign          ( nullPtr )
31 import GHC.Exts         ( Ptr(..) )
32 import System.Posix.Internals ( CFilePath, withFilePath )
33 import System.FilePath  ( dropExtension )
34
35
36 -- ---------------------------------------------------------------------------
37 -- RTS Linker Interface
38 -- ---------------------------------------------------------------------------
39
40 insertSymbol :: String -> String -> Ptr a -> IO ()
41 insertSymbol obj_name key symbol
42     = let str = prefixUnderscore key
43       in withFilePath obj_name $ \c_obj_name ->
44          withCAString str $ \c_str ->
45           c_insertSymbol c_obj_name c_str symbol
46
47 lookupSymbol :: String -> IO (Maybe (Ptr a))
48 lookupSymbol str_in = do
49    let str = prefixUnderscore str_in
50    withCAString str $ \c_str -> do
51      addr <- c_lookupSymbol c_str
52      if addr == nullPtr
53         then return Nothing
54         else return (Just addr)
55
56 prefixUnderscore :: String -> String
57 prefixUnderscore
58  | cLeadingUnderscore == "YES" = ('_':)
59  | otherwise                   = id
60
61 -- | loadDLL loads a dynamic library using the OS's native linker
62 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
63 -- an absolute pathname to the file, or a relative filename
64 -- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
65 -- searches the standard locations for the appropriate library.
66 --
67 loadDLL :: String -> IO (Maybe String)
68 -- Nothing      => success
69 -- Just err_msg => failure
70 loadDLL str0 = do
71   let
72      -- On Windows, addDLL takes a filename without an extension, because
73      -- it tries adding both .dll and .drv.  To keep things uniform in the
74      -- layers above, loadDLL always takes a filename with an extension, and
75      -- we drop it here on Windows only.
76      str | isWindowsHost = dropExtension str0
77          | otherwise     = str0
78   --
79   maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll
80   if maybe_errmsg == nullPtr
81         then return Nothing
82         else do str <- peekCString maybe_errmsg
83                 return (Just str)
84
85 loadArchive :: String -> IO ()
86 loadArchive str = do
87    withFilePath str $ \c_str -> do
88      r <- c_loadArchive c_str
89      when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
90
91 loadObj :: String -> IO ()
92 loadObj str = do
93    withFilePath str $ \c_str -> do
94      r <- c_loadObj c_str
95      when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
96
97 unloadObj :: String -> IO ()
98 unloadObj str =
99    withFilePath str $ \c_str -> do
100      r <- c_unloadObj c_str
101      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
102
103 resolveObjs :: IO SuccessFlag
104 resolveObjs = do
105    r <- c_resolveObjs
106    return (successIf (r /= 0))
107
108 -- ---------------------------------------------------------------------------
109 -- Foreign declarations to RTS entry points which does the real work;
110 -- ---------------------------------------------------------------------------
111
112 foreign import ccall unsafe "addDLL"       c_addDLL :: CFilePath -> IO CString
113 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()
114 foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO ()
115 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
116 foreign import ccall unsafe "loadArchive"  c_loadArchive :: CFilePath -> IO Int
117 foreign import ccall unsafe "loadObj"      c_loadObj :: CFilePath -> IO Int
118 foreign import ccall unsafe "unloadObj"    c_unloadObj :: CFilePath -> IO Int
119 foreign import ccall unsafe "resolveObjs"  c_resolveObjs :: IO Int
120 \end{code}