compiler/ghci/ObjLink.lhs

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