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