Enable new warning for fragile/incorrect CPP #if usage
[ghc.git] / libraries / ghci / GHCi / ObjLink.hs
1 {-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
2 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
3 --
4 -- (c) The University of Glasgow 2002-2006
5 --
6
7 -- ---------------------------------------------------------------------------
8 -- The dynamic linker for object code (.o .so .dll files)
9 -- ---------------------------------------------------------------------------
10
11 -- | Primarily, this module consists of an interface to the C-land
12 -- dynamic linker.
13 module GHCi.ObjLink
14 ( initObjLinker, ShouldRetainCAFs(..)
15 , loadDLL
16 , loadArchive
17 , loadObj
18 , unloadObj
19 , purgeObj
20 , lookupSymbol
21 , lookupClosure
22 , resolveObjs
23 , addLibrarySearchPath
24 , removeLibrarySearchPath
25 , findSystemLibrary
26 ) where
27
28 import GHCi.RemoteTypes
29 import Control.Exception (throwIO, ErrorCall(..))
30 import Control.Monad ( when )
31 import Foreign.C
32 import Foreign.Marshal.Alloc ( free )
33 import Foreign ( nullPtr )
34 import GHC.Exts
35 import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
36 import System.FilePath ( dropExtension, normalise )
37
38
39
40
41 -- ---------------------------------------------------------------------------
42 -- RTS Linker Interface
43 -- ---------------------------------------------------------------------------
44
45 data ShouldRetainCAFs
46 = RetainCAFs
47 -- ^ Retain CAFs unconditionally in linked Haskell code.
48 -- Note that this prevents any code from being unloaded.
49 -- It should not be necessary unless you are GHCi or
50 -- hs-plugins, which needs to be able call any function
51 -- in the compiled code.
52 | DontRetainCAFs
53 -- ^ Do not retain CAFs. Everything reachable from foreign
54 -- exports will be retained, due to the StablePtrs
55 -- created by the module initialisation code. unloadObj
56 -- frees these StablePtrs, which will allow the CAFs to
57 -- be GC'd and the code to be removed.
58
59 initObjLinker :: ShouldRetainCAFs -> IO ()
60 initObjLinker RetainCAFs = c_initLinker_ 1
61 initObjLinker _ = c_initLinker_ 0
62
63 lookupSymbol :: String -> IO (Maybe (Ptr a))
64 lookupSymbol str_in = do
65 let str = prefixUnderscore str_in
66 withCAString str $ \c_str -> do
67 addr <- c_lookupSymbol c_str
68 if addr == nullPtr
69 then return Nothing
70 else return (Just addr)
71
72 lookupClosure :: String -> IO (Maybe HValueRef)
73 lookupClosure str = do
74 m <- lookupSymbol str
75 case m of
76 Nothing -> return Nothing
77 Just (Ptr addr) -> case addrToAny# addr of
78 (# a #) -> Just <$> mkRemoteRef (HValue a)
79
80 prefixUnderscore :: String -> String
81 prefixUnderscore
82 | cLeadingUnderscore = ('_':)
83 | otherwise = id
84
85 -- | loadDLL loads a dynamic library using the OS's native linker
86 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
87 -- an absolute pathname to the file, or a relative filename
88 -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL
89 -- searches the standard locations for the appropriate library.
90 --
91 loadDLL :: String -> IO (Maybe String)
92 -- Nothing => success
93 -- Just err_msg => failure
94 loadDLL str0 = do
95 let
96 -- On Windows, addDLL takes a filename without an extension, because
97 -- it tries adding both .dll and .drv. To keep things uniform in the
98 -- layers above, loadDLL always takes a filename with an extension, and
99 -- we drop it here on Windows only.
100 str | isWindowsHost = dropExtension str0
101 | otherwise = str0
102 --
103 maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll
104 if maybe_errmsg == nullPtr
105 then return Nothing
106 else do str <- peekCString maybe_errmsg
107 free maybe_errmsg
108 return (Just str)
109
110 loadArchive :: String -> IO ()
111 loadArchive str = do
112 withFilePath str $ \c_str -> do
113 r <- c_loadArchive c_str
114 when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed")))
115
116 loadObj :: String -> IO ()
117 loadObj str = do
118 withFilePath str $ \c_str -> do
119 r <- c_loadObj c_str
120 when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed")))
121
122 -- | @unloadObj@ drops the given dynamic library from the symbol table
123 -- as well as enables the library to be removed from memory during
124 -- a future major GC.
125 unloadObj :: String -> IO ()
126 unloadObj str =
127 withFilePath str $ \c_str -> do
128 r <- c_unloadObj c_str
129 when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed")))
130
131 -- | @purgeObj@ drops the symbols for the dynamic library from the symbol
132 -- table. Unlike 'unloadObj', the library will not be dropped memory during
133 -- a future major GC.
134 purgeObj :: String -> IO ()
135 purgeObj str =
136 withFilePath str $ \c_str -> do
137 r <- c_purgeObj c_str
138 when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed")))
139
140 addLibrarySearchPath :: String -> IO (Ptr ())
141 addLibrarySearchPath str =
142 withFilePath str c_addLibrarySearchPath
143
144 removeLibrarySearchPath :: Ptr () -> IO Bool
145 removeLibrarySearchPath = c_removeLibrarySearchPath
146
147 findSystemLibrary :: String -> IO (Maybe String)
148 findSystemLibrary str = do
149 result <- withFilePath str c_findSystemLibrary
150 case result == nullPtr of
151 True -> return Nothing
152 False -> do path <- peekFilePath result
153 free result
154 return $ Just path
155
156 resolveObjs :: IO Bool
157 resolveObjs = do
158 r <- c_resolveObjs
159 return (r /= 0)
160
161 -- ---------------------------------------------------------------------------
162 -- Foreign declarations to RTS entry points which does the real work;
163 -- ---------------------------------------------------------------------------
164
165 foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString
166 foreign import ccall unsafe "initLinker_" c_initLinker_ :: CInt -> IO ()
167 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
168 foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int
169 foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int
170 foreign import ccall unsafe "purgeObj" c_purgeObj :: CFilePath -> IO Int
171 foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int
172 foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
173 foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ())
174 foreign import ccall unsafe "findSystemLibrary" c_findSystemLibrary :: CFilePath -> IO CFilePath
175 foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool
176
177 -- -----------------------------------------------------------------------------
178 -- Configuration
179
180 #include "ghcautoconf.h"
181
182 cLeadingUnderscore :: Bool
183 #ifdef LEADING_UNDERSCORE
184 cLeadingUnderscore = True
185 #else
186 cLeadingUnderscore = False
187 #endif
188
189 isWindowsHost :: Bool
190 #ifdef mingw32_HOST_OS
191 isWindowsHost = True
192 #else
193 isWindowsHost = False
194 #endif