{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
--
--  (c) The University of Glasgow 2002-2006
--

-- ---------------------------------------------------------------------------
--      The dynamic linker for object code (.o .so .dll files)
-- ---------------------------------------------------------------------------

-- | Primarily, this module consists of an interface to the C-land
-- dynamic linker.
module GHCi.ObjLink
  ( initObjLinker, ShouldRetainCAFs(..)
  , loadDLL
  , loadArchive
  , loadObj
  , unloadObj
  , purgeObj
  , lookupSymbol
  , lookupSymbolInDLL
  , lookupClosure
  , resolveObjs
  , addLibrarySearchPath
  , removeLibrarySearchPath
  , findSystemLibrary
  )  where

import Prelude -- See note [Why do we import Prelude here?]
import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad    ( when )
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
import Foreign          ( nullPtr, peek )
import GHC.Exts
import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
import System.FilePath  ( dropExtension, normalise )


-- ---------------------------------------------------------------------------
-- RTS Linker Interface
-- ---------------------------------------------------------------------------

data ShouldRetainCAFs
  = RetainCAFs
    -- ^ Retain CAFs unconditionally in linked Haskell code.
    -- Note that this prevents any code from being unloaded.
    -- It should not be necessary unless you are GHCi or
    -- hs-plugins, which needs to be able call any function
    -- in the compiled code.
  | DontRetainCAFs
    -- ^ Do not retain CAFs.  Everything reachable from foreign
    -- exports will be retained, due to the StablePtrs
    -- created by the module initialisation code.  unloadObj
    -- frees these StablePtrs, which will allow the CAFs to
    -- be GC'd and the code to be removed.

initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs = CInt -> IO ()
c_initLinker_ CInt
1
initObjLinker ShouldRetainCAFs
_ = CInt -> IO ()
c_initLinker_ CInt
0

lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol :: forall a. String -> IO (Maybe (Ptr a))
lookupSymbol String
str_in = do
   let str :: String
str = String -> String
prefixUnderscore String
str_in
   String -> (CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a))
forall a. String -> (CFilePath -> IO a) -> IO a
withCAString String
str ((CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a)))
-> (CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a))
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Ptr a
addr <- CFilePath -> IO (Ptr a)
forall a. CFilePath -> IO (Ptr a)
c_lookupSymbol CFilePath
c_str
     if Ptr a
addr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
        then Maybe (Ptr a) -> IO (Maybe (Ptr a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr a)
forall a. Maybe a
Nothing
        else Maybe (Ptr a) -> IO (Maybe (Ptr a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr a -> Maybe (Ptr a)
forall a. a -> Maybe a
Just Ptr a
addr)

lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
lookupSymbolInDLL :: forall a. Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
lookupSymbolInDLL Ptr LoadedDLL
dll String
str_in = do
   let str :: String
str = String -> String
prefixUnderscore String
str_in
   String -> (CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a))
forall a. String -> (CFilePath -> IO a) -> IO a
withCAString String
str ((CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a)))
-> (CFilePath -> IO (Maybe (Ptr a))) -> IO (Maybe (Ptr a))
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Ptr a
addr <- Ptr LoadedDLL -> CFilePath -> IO (Ptr a)
forall a. Ptr LoadedDLL -> CFilePath -> IO (Ptr a)
c_lookupSymbolInNativeObj Ptr LoadedDLL
dll CFilePath
c_str
     if Ptr a
addr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
       then Maybe (Ptr a) -> IO (Maybe (Ptr a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr a)
forall a. Maybe a
Nothing
       else Maybe (Ptr a) -> IO (Maybe (Ptr a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr a -> Maybe (Ptr a)
forall a. a -> Maybe a
Just Ptr a
addr)

lookupClosure :: String -> IO (Maybe HValueRef)
lookupClosure :: String -> IO (Maybe HValueRef)
lookupClosure String
str = do
  Maybe (Ptr Any)
m <- String -> IO (Maybe (Ptr Any))
forall a. String -> IO (Maybe (Ptr a))
lookupSymbol String
str
  case Maybe (Ptr Any)
m of
    Maybe (Ptr Any)
Nothing -> Maybe HValueRef -> IO (Maybe HValueRef)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HValueRef
forall a. Maybe a
Nothing
    Just (Ptr Addr#
addr) -> case Addr# -> (# Any #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
      (# Any
a #) -> HValueRef -> Maybe HValueRef
forall a. a -> Maybe a
Just (HValueRef -> Maybe HValueRef)
-> IO HValueRef -> IO (Maybe HValueRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HValue -> IO HValueRef
forall a. a -> IO (RemoteRef a)
mkRemoteRef (Any -> HValue
HValue Any
a)

prefixUnderscore :: String -> String
prefixUnderscore :: String -> String
prefixUnderscore
 | Bool
cLeadingUnderscore = (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:)
 | Bool
otherwise          = String -> String
forall a. a -> a
id

-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
-- an absolute pathname to the file, or a relative filename
-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
-- searches the standard locations for the appropriate library.
--
loadDLL :: String -> IO (Either String (Ptr LoadedDLL))
loadDLL :: String -> IO (Either String (Ptr LoadedDLL))
loadDLL String
str0 = do
  let
     -- On Windows, addDLL takes a filename without an extension, because
     -- it tries adding both .dll and .drv.  To keep things uniform in the
     -- layers above, loadDLL always takes a filename with an extension, and
     -- we drop it here on Windows only.
     str :: String
str | Bool
isWindowsHost = String -> String
dropExtension String
str0
         | Bool
otherwise     = String
str0
  --
  (Ptr LoadedDLL
maybe_handle, CFilePath
maybe_errmsg) <- String
-> (CFilePath -> IO (Ptr LoadedDLL, CFilePath))
-> IO (Ptr LoadedDLL, CFilePath)
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath (String -> String
normalise String
str) ((CFilePath -> IO (Ptr LoadedDLL, CFilePath))
 -> IO (Ptr LoadedDLL, CFilePath))
-> (CFilePath -> IO (Ptr LoadedDLL, CFilePath))
-> IO (Ptr LoadedDLL, CFilePath)
forall a b. (a -> b) -> a -> b
$ \CFilePath
dll ->
    (Ptr CFilePath -> IO (Ptr LoadedDLL, CFilePath))
-> IO (Ptr LoadedDLL, CFilePath)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CFilePath -> IO (Ptr LoadedDLL, CFilePath))
 -> IO (Ptr LoadedDLL, CFilePath))
-> (Ptr CFilePath -> IO (Ptr LoadedDLL, CFilePath))
-> IO (Ptr LoadedDLL, CFilePath)
forall a b. (a -> b) -> a -> b
$ \Ptr CFilePath
errmsg_ptr -> (,)
      (Ptr LoadedDLL -> CFilePath -> (Ptr LoadedDLL, CFilePath))
-> IO (Ptr LoadedDLL)
-> IO (CFilePath -> (Ptr LoadedDLL, CFilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CFilePath -> Ptr CFilePath -> IO (Ptr LoadedDLL)
c_loadNativeObj CFilePath
dll Ptr CFilePath
errmsg_ptr
      IO (CFilePath -> (Ptr LoadedDLL, CFilePath))
-> IO CFilePath -> IO (Ptr LoadedDLL, CFilePath)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr CFilePath -> IO CFilePath
forall a. Storable a => Ptr a -> IO a
peek Ptr CFilePath
errmsg_ptr

  if Ptr LoadedDLL
maybe_handle Ptr LoadedDLL -> Ptr LoadedDLL -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr LoadedDLL
forall a. Ptr a
nullPtr
    then do String
str <- CFilePath -> IO String
peekCString CFilePath
maybe_errmsg
            CFilePath -> IO ()
forall a. Ptr a -> IO ()
free CFilePath
maybe_errmsg
            Either String (Ptr LoadedDLL) -> IO (Either String (Ptr LoadedDLL))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Ptr LoadedDLL)
forall a b. a -> Either a b
Left String
str)
    else Either String (Ptr LoadedDLL) -> IO (Either String (Ptr LoadedDLL))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr LoadedDLL -> Either String (Ptr LoadedDLL)
forall a b. b -> Either a b
Right Ptr LoadedDLL
maybe_handle)

loadArchive :: String -> IO ()
loadArchive :: String -> IO ()
loadArchive String
str = do
   String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Int
r <- CFilePath -> IO Int
c_loadArchive CFilePath
c_str
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall (String
"loadArchive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": failed")))

loadObj :: String -> IO ()
loadObj :: String -> IO ()
loadObj String
str = do
   String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Int
r <- CFilePath -> IO Int
c_loadObj CFilePath
c_str
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall (String
"loadObj " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": failed")))

-- | @unloadObj@ drops the given dynamic library from the symbol table
-- as well as enables the library to be removed from memory during
-- a future major GC.
unloadObj :: String -> IO ()
unloadObj :: String -> IO ()
unloadObj String
str =
   String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Int
r <- CFilePath -> IO Int
c_unloadObj CFilePath
c_str
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall (String
"unloadObj " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": failed")))

-- | @purgeObj@ drops the symbols for the dynamic library from the symbol
-- table. Unlike 'unloadObj', the library will not be dropped memory during
-- a future major GC.
purgeObj :: String -> IO ()
purgeObj :: String -> IO ()
purgeObj String
str =
   String -> (CFilePath -> IO ()) -> IO ()
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str ((CFilePath -> IO ()) -> IO ()) -> (CFilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CFilePath
c_str -> do
     Int
r <- CFilePath -> IO Int
c_purgeObj CFilePath
c_str
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> ErrorCall
ErrorCall (String
"purgeObj " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": failed")))

addLibrarySearchPath :: String -> IO (Ptr ())
addLibrarySearchPath :: String -> IO (Ptr ())
addLibrarySearchPath String
str =
   String -> (CFilePath -> IO (Ptr ())) -> IO (Ptr ())
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str CFilePath -> IO (Ptr ())
c_addLibrarySearchPath

removeLibrarySearchPath :: Ptr () -> IO Bool
removeLibrarySearchPath :: Ptr () -> IO Bool
removeLibrarySearchPath = Ptr () -> IO Bool
c_removeLibrarySearchPath

findSystemLibrary :: String -> IO (Maybe String)
findSystemLibrary :: String -> IO (Maybe String)
findSystemLibrary String
str = do
    CFilePath
result <- String -> (CFilePath -> IO CFilePath) -> IO CFilePath
forall a. String -> (CFilePath -> IO a) -> IO a
withFilePath String
str CFilePath -> IO CFilePath
c_findSystemLibrary
    case CFilePath
result CFilePath -> CFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== CFilePath
forall a. Ptr a
nullPtr of
        Bool
True  -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        Bool
False -> do String
path <- CFilePath -> IO String
peekFilePath CFilePath
result
                    CFilePath -> IO ()
forall a. Ptr a -> IO ()
free CFilePath
result
                    Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
path

resolveObjs :: IO Bool
resolveObjs :: IO Bool
resolveObjs = do
   Int
r <- IO Int
c_resolveObjs
   Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)

-- ---------------------------------------------------------------------------
-- Foreign declarations to RTS entry points which does the real work;
-- ---------------------------------------------------------------------------

foreign import ccall unsafe "loadNativeObj"           c_loadNativeObj           :: CFilePath -> Ptr CString -> IO (Ptr LoadedDLL)
foreign import ccall unsafe "lookupSymbolInNativeObj" c_lookupSymbolInNativeObj :: Ptr LoadedDLL -> CString -> IO (Ptr a)
foreign import ccall unsafe "initLinker_"             c_initLinker_             :: CInt -> IO ()
foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)
foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int
foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int
foreign import ccall unsafe "purgeObj"                c_purgeObj                :: CFilePath -> IO Int
foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int
foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int
foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())
foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath
foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool

-- -----------------------------------------------------------------------------
-- Configuration

#include "ghcautoconf.h"

cLeadingUnderscore :: Bool
#if defined(LEADING_UNDERSCORE)
cLeadingUnderscore = True
#else
cLeadingUnderscore :: Bool
cLeadingUnderscore = Bool
False
#endif

isWindowsHost :: Bool
#if defined(mingw32_HOST_OS)
isWindowsHost = True
#else
isWindowsHost :: Bool
isWindowsHost = Bool
False
#endif