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