1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
%
% (c) The University of Glasgow, 2000-2006
%
-- ---------------------------------------------------------------------------
-- The dynamic linker for object code (.o .so .dll files)
-- ---------------------------------------------------------------------------
Primarily, this module consists of an interface to the C-land dynamic linker.
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module ObjLink (
initObjLinker, -- :: IO ()
loadDLL, -- :: String -> IO (Maybe String)
loadArchive, -- :: String -> IO ()
loadObj, -- :: String -> IO ()
unloadObj, -- :: String -> IO ()
insertSymbol, -- :: String -> String -> Ptr a -> IO ()
lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
resolveObjs -- :: IO SuccessFlag
) where
import Panic
import BasicTypes ( SuccessFlag, successIf )
import Config ( cLeadingUnderscore )
import Util
import Control.Monad ( when )
import Foreign.C
import Foreign ( nullPtr )
import GHC.Exts ( Ptr(..) )
#if __GLASGOW_HASKELL__ >= 703
import GHC.IO.Encoding (getFileSystemEncoding)
#else
import GHC.IO.Encoding (TextEncoding, fileSystemEncoding)
#endif
import qualified GHC.Foreign as GHC
import System.FilePath ( dropExtension )
-- ---------------------------------------------------------------------------
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
#if __GLASGOW_HASKELL__ < 703
getFileSystemEncoding :: IO TextEncoding
getFileSystemEncoding = return fileSystemEncoding
#endif
-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
withFileCString :: FilePath -> (CString -> IO a) -> IO a
withFileCString fp f = do
enc <- getFileSystemEncoding
GHC.withCString enc fp f
insertSymbol :: String -> String -> Ptr a -> IO ()
insertSymbol obj_name key symbol
= let str = prefixUnderscore key
in withFileCString obj_name $ \c_obj_name ->
withCAString str $ \c_str ->
c_insertSymbol c_obj_name c_str symbol
lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
withCAString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
prefixUnderscore :: String -> String
prefixUnderscore
| cLeadingUnderscore == "YES" = ('_':)
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
-- an absolute pathname to the file, or a relative filename
-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
-- searches the standard locations for the appropriate library.
--
loadDLL :: String -> IO (Maybe String)
-- Nothing => success
-- Just err_msg => failure
loadDLL str0 = do
let
-- On Windows, addDLL takes a filename without an extension, because
-- it tries adding both .dll and .drv. To keep things uniform in the
-- layers above, loadDLL always takes a filename with an extension, and
-- we drop it here on Windows only.
str | isWindowsHost = dropExtension str0
| otherwise = str0
--
maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr
then return Nothing
else do str <- peekCString maybe_errmsg
return (Just str)
loadArchive :: String -> IO ()
loadArchive str = do
withFileCString str $ \c_str -> do
r <- c_loadArchive c_str
when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
loadObj :: String -> IO ()
loadObj str = do
withFileCString str $ \c_str -> do
r <- c_loadObj c_str
when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
unloadObj :: String -> IO ()
unloadObj str =
withFileCString str $ \c_str -> do
r <- c_unloadObj c_str
when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
resolveObjs :: IO SuccessFlag
resolveObjs = do
r <- c_resolveObjs
return (successIf (r /= 0))
-- ---------------------------------------------------------------------------
-- Foreign declarations to RTS entry points which does the real work;
-- ---------------------------------------------------------------------------
foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString
foreign import ccall unsafe "initLinker" initObjLinker :: IO ()
foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall unsafe "loadArchive" c_loadArchive :: CString -> IO Int
foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int
foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int
foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
\end{code}
|
