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    loadObj,              -- :: String -> IO ()
  16    unloadObj,            -- :: String -> IO ()
  17    insertSymbol,         -- :: String -> String -> Ptr a -> IO ()
  18    lookupSymbol,         -- :: String -> IO (Maybe (Ptr a))
  19    resolveObjs           -- :: IO SuccessFlag
  20   )  where
  21
  22 import Panic
  23 import BasicTypes       ( SuccessFlag, successIf )
  24 import Config           ( cLeadingUnderscore )
  25
  26 import Control.Monad    ( when )
  27 import Foreign.C
  28 import Foreign          ( nullPtr )
  29 import GHC.Exts         ( Ptr(..) )
  30
  31
  32
  33 -- ---------------------------------------------------------------------------
  34 -- RTS Linker Interface
  35 -- ---------------------------------------------------------------------------
  36
  37 insertSymbol :: String -> String -> Ptr a -> IO ()
  38 insertSymbol obj_name key symbol
  39     = let str = prefixUnderscore key
  40       in withCString obj_name $ \c_obj_name ->
  41          withCString str $ \c_str ->
  42           c_insertSymbol c_obj_name c_str symbol
  43
  44 lookupSymbol :: String -> IO (Maybe (Ptr a))
  45 lookupSymbol str_in = do
  46    let str = prefixUnderscore str_in
  47    withCString str $ \c_str -> do
  48      addr <- c_lookupSymbol c_str
  49      if addr == nullPtr
  50         then return Nothing
  51         else return (Just addr)
  52
  53 prefixUnderscore :: String -> String
  54 prefixUnderscore
  55  | cLeadingUnderscore == "YES" = ('_':)
  56  | otherwise                   = id
  57
  58 loadDLL :: String -> IO (Maybe String)
  59 -- Nothing      => success
  60 -- Just err_msg => failure
  61 loadDLL str = do
  62   maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
  63   if maybe_errmsg == nullPtr
  64         then return Nothing
  65         else do str <- peekCString maybe_errmsg
  66                 return (Just str)
  67
  68 loadObj :: String -> IO ()
  69 loadObj str = do
  70    withCString str $ \c_str -> do
  71      r <- c_loadObj c_str
  72      when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
  73
  74 unloadObj :: String -> IO ()
  75 unloadObj str =
  76    withCString str $ \c_str -> do
  77      r <- c_unloadObj c_str
  78      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
  79
  80 resolveObjs :: IO SuccessFlag
  81 resolveObjs = do
  82    r <- c_resolveObjs
  83    return (successIf (r /= 0))
  84
  85 -- ---------------------------------------------------------------------------
  86 -- Foreign declarations to RTS entry points which does the real work;
  87 -- ---------------------------------------------------------------------------
  88
  89 foreign import ccall unsafe "addDLL"       c_addDLL :: CString -> IO CString
  90 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()
  91 foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
  92 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
  93 foreign import ccall unsafe "loadObj"      c_loadObj :: CString -> IO Int
  94 foreign import ccall unsafe "unloadObj"    c_unloadObj :: CString -> IO Int
  95 foreign import ccall unsafe "resolveObjs"  c_resolveObjs :: IO Int
  96 \end{code}