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