[project @ 2002-05-01 15:46:14 by simonmar]

Cleanup and overhaul the bogus dynamic library loading code in
InteractiveUI.  Bugs fixed:

  - when linking in extra_libraries from a package,
    we now search library_paths in addition to the default
    dlopen() paths.

  - the path-searching machinery for dynamic libraries specified
    on the command line was broken, it didn't work unless the library
    was found on the first path in the list.

ghc/compiler/ghci/InteractiveUI.hs

 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.121 2002/04/24 09:42:18 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.122 2002/05/01 15:46:15 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
 -- (c) The GHC Team 2000
 --
 -----------------------------------------------------------------------------
-module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
+module InteractiveUI ( 
+	interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
+	LibrarySpec(..),
+	ghciWelcomeMsg
+   ) where
 
 #include "../includes/config.h"
 #include "HsVersions.h"
@@ -70,7 +74,7 @@ import Monad
 import GlaExts		( unsafeCoerce# )
 
 import Foreign		( nullPtr )
-import CString		( peekCString )
+import CString		( CString, peekCString, withCString )
 
 -----------------------------------------------------------------------------
 
@@ -993,11 +997,24 @@ ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 -- For dynamic objects only, try to find the object file in all the 
 -- directories specified in v_Library_Paths before giving up.
 
-type LibrarySpec
-   = Either FilePath String
+data LibrarySpec = Object FilePath | DLL String
 
-showLS (Left nm)  = "(static) " ++ nm
-showLS (Right nm) = "(dynamic) " ++ nm
+-- Packages that don't need loading, because the compiler shares them with
+-- the interpreted program.
+dont_load_these = [ "rts" ]
+
+-- Packages that are already linked into GHCi.  For mingw32, we only
+-- skip gmp and rts, since std and after need to load the msvcrt.dll
+-- library which std depends on.
+loaded_in_ghci
+#          ifndef mingw32_TARGET_OS
+           = [ "std", "concurrent", "posix", "text", "util" ]
+#          else
+	   = [ ]
+#          endif
+
+showLS (Object nm)  = "(static) " ++ nm
+showLS (DLL nm) = "(dynamic) " ++ nm
 
 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
 linkPackages dflags cmdline_lib_specs pkgs
@@ -1007,6 +1024,7 @@ linkPackages dflags cmdline_lib_specs pkgs
 	if (null cmdline_lib_specs)
 	   then return ()
 	   else do maybePutStr dflags "final link ... "
+
 		   ok <- resolveObjs
 		   if ok then maybePutStrLn dflags "done."
 	      		 else throwDyn (InstallationError 
@@ -1016,15 +1034,15 @@ linkPackages dflags cmdline_lib_specs pkgs
         preloadLib dflags lib_paths lib_spec
            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
                 case lib_spec of
-                   Left static_ish
+                   Object static_ish
                       -> do b <- preload_static lib_paths static_ish
                             maybePutStrLn dflags (if b  then "done." 
 							else "not found")
-                   Right dll_unadorned
+                   DLL dll_unadorned
                       -> -- We add "" to the set of paths to try, so that
                          -- if none of the real paths match, we force addDLL
                          -- to look in the default dynamic-link search paths.
-                         do maybe_errstr <- preload_dynamic (lib_paths++[""]) 
+                         do maybe_errstr <- loadDynamic (lib_paths++[""]) 
                                                             dll_unadorned
                             case maybe_errstr of
                                Nothing -> return ()
@@ -1046,80 +1064,107 @@ linkPackages dflags cmdline_lib_specs pkgs
                 if not b then return False
                          else loadObj name >> return True
 
-        -- return Nothing == success, else Just error message from addDLL
-        preload_dynamic [] name
-           = return Nothing
-        preload_dynamic (path:paths) rootname
-           = do -- addDLL returns NULL on success
-                maybe_errmsg <- addDLL path rootname
-                if    maybe_errmsg == nullPtr
-                 then preload_dynamic paths rootname
-                 else do str <- peekCString maybe_errmsg
-                         return (Just str)
-
         give_up 
            = (throwDyn . CmdLineError)
                 "user specified .o/.so/.DLL could not be loaded."
 
--- Packages that don't need loading, because the compiler shares them with
--- the interpreted program.
-dont_load_these = [ "rts" ]
-
--- Packages that are already linked into GHCi.  For mingw32, we only
--- skip gmp and rts, since std and after need to load the msvcrt.dll
--- library which std depends on.
-loaded_in_ghci
-#          ifndef mingw32_TARGET_OS
-           = [ "std", "concurrent", "posix", "text", "util" ]
-#          else
-	   = [ ]
-#          endif
-
 linkPackage :: DynFlags -> PackageConfig -> IO ()
 linkPackage dflags pkg
    | name pkg `elem` dont_load_these = return ()
    | otherwise
    = do 
-        -- For each obj, try obj.o and if that fails, obj.so.
-        -- Complication: all the .so's must be loaded before any of the .o's.  
         let dirs      =  library_dirs pkg
-        let objs      =  hs_libraries pkg ++ extra_libraries pkg
-        classifieds   <- mapM (locateOneObj dirs) objs
+        let libs      =  hs_libraries pkg ++ extra_libraries pkg
+        classifieds   <- mapM (locateOneObj dirs) libs
 
-	-- Don't load the .so libs if this is a package GHCi is already
-	-- linked against, because we'll already have the .so linked in.
-	let (so_libs, obj_libs) = partition isRight classifieds
-        let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
-		      | otherwise      		       = so_libs ++ obj_libs
+        -- Complication: all the .so's must be loaded before any of the .o's.  
+	let dlls = [ dll | DLL dll <- classifieds ]
+	    objs = [ obj | Object obj <- classifieds ]
 
 	maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
-        mapM loadClassified sos_first
+
+	-- If this package is already part of the GHCi binary, we'll already
+	-- have the right DLLs for this package loaded, so don't try to
+	-- load them again.
+	when (name pkg `notElem` loaded_in_ghci) $
+	    loadDynamics dirs dlls
+	
+	-- After loading all the DLLs, we can load the static objects.
+	mapM loadObj objs
+
         maybePutStr dflags "linking ... "
         ok <- resolveObjs
 	if ok then maybePutStrLn dflags "done."
 	      else panic ("can't load package `" ++ name pkg ++ "'")
-     where
-        isRight (Right _) = True
-        isRight (Left _)  = False
-
-loadClassified :: LibrarySpec -> IO ()
-loadClassified (Left obj_absolute_filename)
-   = do loadObj obj_absolute_filename
-loadClassified (Right dll_unadorned)
-   = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
-        if    maybe_errmsg == nullPtr
-         then return ()
-         else do str <- peekCString maybe_errmsg
-                 throwDyn (CmdLineError ("can't load .so/.DLL for: " 
-                                       ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 
+loadDynamics dirs [] = return ()
+loadDynamics dirs (dll:dlls) = do
+  r <- loadDynamic dirs dll
+  case r of
+    Nothing  -> loadDynamics dirs dlls
+    Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " 
+                                       ++ dll ++ " (" ++ err ++ ")" ))
+
+-- Try to find an object file for a given library in the given paths.
+-- If it isn't present, we assume it's a dynamic library.
 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
-locateOneObj []     obj 
-   = return (Right obj) -- we assume
-locateOneObj (d:ds) obj 
-   = do let path = d ++ '/':obj ++ ".o"
+locateOneObj [] lib
+   = return (DLL lib) -- we assume
+locateOneObj (d:ds) lib
+   = do let path = d ++ '/':lib ++ ".o"
         b <- doesFileExist path
-        if b then return (Left path) else locateOneObj ds obj
+        if b then return (Object path) else locateOneObj ds lib
+
+-- ----------------------------------------------------------------------------
+-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
+
+#ifdef mingw32_TARGET_OS
+loadDynamic paths rootname = do
+  -- ignore paths on windows (why? --SDM)
+  maybe_errmsg <- addDLL rootname
+  if maybe_errmsg == nullPtr
+	then return Nothing
+	else do str <- peekCString maybe_errmsg
+		return (Just str)
+
+addDLL :: String -> String -> IO (Ptr CChar)
+addDLL path lib = do
+  withCString path $ \c_path -> do
+  withCString lib $ \c_lib -> do
+    maybe_errmsg <- c_addDLL c_path c_lib
+    return maybe_errmsg
+
+#else
+
+-- return Nothing == success, else Just error message from dlopen
+loadDynamic (path:paths) rootname = do
+  let dll = path ++ '/':mkSOName rootname
+  b <- doesFileExist dll
+  if not b
+     then loadDynamic paths rootname
+     else addDLL dll
+loadDynamic [] rootname = do
+	-- tried all our known library paths, let dlopen() search its
+	-- own builtin paths now.
+   addDLL (mkSOName rootname)
+
+mkSOName root = "lib" ++ root ++ ".so"
+
+addDLL :: String -> IO (Maybe String)
+addDLL str = do
+  maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+  if maybe_errmsg == nullPtr
+	then return Nothing
+	else do str <- peekCString maybe_errmsg
+		return (Just str)
+
+foreign import ccall "addDLL" unsafe  
+  c_addDLL :: CString -> IO CString
+
+foreign import ccall "dlerror" unsafe  
+  dlerror :: IO CString
+
+#endif
 
 -----------------------------------------------------------------------------
 -- timing & statistics

ghc/includes/Linker.h

 /* -----------------------------------------------------------------------------
- * $Id: Linker.h,v 1.3 2001/07/23 10:43:18 simonmar Exp $
+ * $Id: Linker.h,v 1.4 2002/05/01 15:46:14 simonmar Exp $
  *
  * (c) The GHC Team, 2000
  *
@@ -26,6 +26,6 @@ HsInt loadObj( char *path );
 HsInt resolveObjs( void );
 
 /* load a dynamic library */
-char *addDLL( char* path, char* dll_name );
+char *addDLL( char* dll_name );
 
 #endif /* LINKER_H */

ghc/rts/Linker.c

 /* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.88 2002/04/23 17:33:54 ken Exp $
+ * $Id: Linker.c,v 1.89 2002/05/01 15:46:14 simonmar Exp $
  *
  * (c) The GHC Team, 2000, 2001
  *
@@ -473,23 +473,14 @@ static OpenedDLL* opened_dlls = NULL;
 
 
 
-char*
-addDLL ( __attribute((unused)) char* path, char* dll_name )
+char *
+addDLL( char *dll_name )
 {
 #  if defined(OBJFORMAT_ELF)
    void *hdl;
-   char *buf;
    char *errmsg;
 
-   if (path == NULL || strlen(path) == 0) {
-      buf = stgMallocBytes(strlen(dll_name) + 10, "addDll");
-      sprintf(buf, "lib%s.so", dll_name);
-   } else {
-      buf = stgMallocBytes(strlen(path) + 1 + strlen(dll_name) + 10, "addDll");
-      sprintf(buf, "%s/lib%s.so", path, dll_name);
-   }
-   hdl = dlopen(buf, RTLD_NOW | RTLD_GLOBAL );
-   free(buf);
+   hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
    if (hdl == NULL) {
       /* dlopen failed; return a ptr to the error msg. */
       errmsg = dlerror();