mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-20 10:40:19 +02:00
Code Activity

Replace libltdl with raw dlopen, dlsym

Browse source 
* NEWS: Update.
* am/bootstrap.am (SOURCES):
* module/Makefile.am (SOURCES): Add system/foreign-library.scm.
* configure.ac: Replace ltdl check with -ldl check.
* libguile/dynl.c: Rewrite to just expose core dlopen / dlsym / etc to a
  helper Scheme module.
  (scm_dynamic_link, scm_dynamic_pointer, scm_dynamic_function)
  (scm_dynamic_object_p, scm_dynamic_call): Rewrite in terms of (system
  foreign-library).
* libguile/extensions.c (load_extension): Avoid scm_dynamic_call.
* module/system/foreign-library.scm: New file.
* module/oop/goops.scm (<dynamic-object>): Hackily export
  <foreign-library> instead of a class here.
* doc/ref/api-foreign.texi (Foreign Function Interface): Rewrite to only
  document the new interfaces.  Eventually we will deprecate
  dynamic-link and friends.
* doc/ref/guile.texi (API Reference): Move Foreign Objects after Foreign
  Function Interface.  Seems there should be some closer relationship
  but this will do for now.
* doc/ref/tour.texi (Putting Extensions into Modules):
* doc/ref/libguile-parallel.texi (Parallel Installations): Update for
  rename of Modules and Extensions to Foreign Extensions.
* libguile/deprecated.h:
* libguile/deprecated.c (scm_dynamic_unlink): Deprecate.
* libguile/guile.c: Remove ltdl include.
* test-suite/tests/foreign.test: Update tests to use new API, and update
  error expectations.
This commit is contained in:
Andy Wingo 2021-01-22 16:39:11 +01:00
parent 480d86df68
commit 2e26538d6a
17 changed files with 934 additions and 911 deletions
Download patch file Download diff file Expand all files Collapse all files

439
libguile/dynl.c
View file

@ -1,6 +1,6 @@
/* dynl.c - dynamic linking
Copyright 1990-2003,2008-2011,2017-2018
Copyright 1990-2003,2008-2011,2017-2018,2021
Free Software Foundation, Inc.
This file is part of Guile.
@ -28,369 +28,172 @@
# include <config.h>
#endif
#include <alloca.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ltdl.h>
#include <dlfcn.h>
#include "boolean.h"
#include "deprecation.h"
#include "dynwind.h"
#include "eval.h"
#include "extensions.h"
#include "foreign.h"
#include "gc.h"
#include "gsubr.h"
#include "keywords.h"
#include "libpath.h"
#include "list.h"
#include "ports.h"
#include "smob.h"
#include "modules.h"
#include "numbers.h"
#include "strings.h"
#include "threads.h"
#include "variable.h"
#include "version.h"
#include "dynl.h"
/* From the libtool manual: "Note that libltdl is not threadsafe,
i.e. a multithreaded application has to use a mutex for libltdl.".
Note: We initialize it as a recursive mutex below. */
static scm_i_pthread_mutex_t ltdl_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* LT_PATH_SEP-separated extension library search path, searched last */
static char *system_extensions_path;
static void *
sysdep_dynl_link (const char *fname, const char *subr)
static SCM
dlerror_string (const char *fallback)
{
lt_dlhandle handle;
/* Try the literal filename first or, if NULL, the program itself */
handle = lt_dlopen (fname);
if (handle == NULL)
{
handle = lt_dlopenext (fname);
if (handle == NULL
#ifdef LT_DIRSEP_CHAR
&& strchr (fname, LT_DIRSEP_CHAR) == NULL
#endif
&& strchr (fname, '/') == NULL)
{
/* FNAME contains no directory separators and was not in the
usual library search paths, so now we search for it in
SYSTEM_EXTENSIONS_PATH. */
char *fname_attempt
= scm_gc_malloc_pointerless (strlen (system_extensions_path)
+ strlen (fname) + 2,
"dynl fname_attempt");
char *path; /* remaining path to search */
char *end; /* end of current path component */
char *s;
/* Iterate over the components of SYSTEM_EXTENSIONS_PATH */
for (path = system_extensions_path;
*path != '\0';
path = (*end == '\0') ? end : (end + 1))
{
/* Find end of path component */
end = strchr (path, LT_PATHSEP_CHAR);
if (end == NULL)
end = strchr (path, '\0');
/* Skip empty path components */
if (path == end)
continue;
/* Construct FNAME_ATTEMPT, starting with path component */
s = fname_attempt;
memcpy (s, path, end - path);
s += end - path;
/* Append directory separator, but avoid duplicates */
if (s[-1] != '/'
#ifdef LT_DIRSEP_CHAR
&& s[-1] != LT_DIRSEP_CHAR
#endif
)
*s++ = '/';
/* Finally, append FNAME (including null terminator) */
strcpy (s, fname);
/* Try to load it, and terminate the search if successful */
handle = lt_dlopenext (fname_attempt);
if (handle != NULL)
break;
}
}
}
if (handle == NULL)
{
SCM fn;
SCM msg;
fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
msg = scm_from_locale_string (lt_dlerror ());
scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
}
return (void *) handle;
const char *message = dlerror ();
if (message)
return scm_from_locale_string (message);
return scm_from_utf8_string ("Unknown error");
}
static void
sysdep_dynl_unlink (void *handle, const char *subr)
{
if (lt_dlclose ((lt_dlhandle) handle))
{
scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
}
}
static void *
sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
fptr = lt_dlsym ((lt_dlhandle) handle, symb);
if (!fptr)
scm_misc_error (subr, "Symbol not found: ~a",
scm_list_1 (scm_from_locale_string (symb)));
return fptr;
}
static void
sysdep_dynl_init ()
{
char *env;
lt_dlinit ();
/* Initialize 'system_extensions_path' from
$GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set:
<SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>.
'lt_dladdsearchdir' can't be used because it is searched before
the system-dependent search path, which is the one 'libtool
--mode=execute -dlopen' fiddles with (info "(libtool) Libltdl
Interface"). See
<http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>.
The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH
can't be used because they would be propagated to subprocesses
which may cause problems for other programs. See
<http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */
env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
if (env)
system_extensions_path = env;
else
{
system_extensions_path
= scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR)
+ strlen (SCM_EXTENSIONS_DIR) + 2,
"system_extensions_path");
sprintf (system_extensions_path, "%s%c%s",
SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR);
}
}
scm_t_bits scm_tc16_dynamic_obj;
#define DYNL_FILENAME SCM_SMOB_OBJECT
#define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<dynamic-object ", port);
scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
if (DYNL_HANDLE (exp) == NULL)
scm_puts (" (unlinked)", port);
scm_putc ('>', port);
return 1;
}
SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
(SCM filename),
"Find the shared object (shared library) denoted by\n"
"@var{filename} and link it into the running Guile\n"
"application. The returned\n"
"scheme object is a ``handle'' for the library which can\n"
"be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
"Searching for object files is system dependent. Normally,\n"
"if @var{filename} does have an explicit directory it will\n"
"be searched for in locations\n"
"such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
"When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
"returned. This handle provides access to the symbols\n"
"available to the program at run-time, including those exported\n"
"by the program itself and the shared libraries already loaded.\n")
#define FUNC_NAME s_scm_dynamic_link
SCM_DEFINE_STATIC (scm_dlopen, "dlopen", 2, 0, 0, (SCM name, SCM flags), "")
#define FUNC_NAME s_scm_dlopen
{
void *handle;
char *file;
int c_flags = scm_to_int (flags);
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&ltdl_lock);
if (SCM_UNBNDP (filename))
file = NULL;
if (scm_is_false (name))
handle = dlopen (NULL, c_flags);
else
{
file = scm_to_locale_string (filename);
scm_dynwind_free (file);
char *c_name = scm_to_locale_string (name);
handle = dlopen (c_name, c_flags);
free (c_name);
}
handle = sysdep_dynl_link (file, FUNC_NAME);
scm_dynwind_end ();
SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
SCM_UNBNDP (filename)
? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
handle);
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a dynamic object handle,\n"
"or @code{#f} otherwise.")
#define FUNC_NAME s_scm_dynamic_object_p
{
return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
(SCM dobj),
"Unlink a dynamic object from the application, if possible. The\n"
"object must have been linked by @code{dynamic-link}, with \n"
"@var{dobj} the corresponding handle. After this procedure\n"
"is called, the handle can no longer be used to access the\n"
"object.")
#define FUNC_NAME s_scm_dynamic_unlink
{
/*fixme* GC-problem */
SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&ltdl_lock);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
} else {
sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
SET_DYNL_HANDLE (dobj, NULL);
if (!handle) {
SCM message = dlerror_string ("Unknown error while opening module");
SCM_MISC_ERROR ("file ~S, message ~S", scm_list_2 (name, message));
}
return scm_from_pointer (handle, NULL);
}
#undef FUNC_NAME
SCM_DEFINE_STATIC (scm_dlclose, "dlclose", 1, 0, 0, (SCM obj), "")
#define FUNC_NAME s_scm_dlclose
{
void *handle = scm_to_pointer (obj);
if (dlclose (handle) != 0) {
SCM message = dlerror_string ("Unknown error");
SCM_MISC_ERROR ("Error closing module: ~S", scm_list_1 (message));
}
scm_dynwind_end ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
(SCM name, SCM dobj),
"Return a ``wrapped pointer'' to the symbol @var{name}\n"
"in the shared object referred to by @var{dobj}. The returned\n"
"pointer points to a C object.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_pointer
SCM_DEFINE_STATIC (scm_dlsym, "dlsym", 2, 0, 0, (SCM obj, SCM name), "")
#define FUNC_NAME s_scm_dlsym
{
void *val;
void *handle = scm_to_pointer (obj);
char *c_name = scm_to_utf8_string (name);
SCM_VALIDATE_STRING (1, name);
SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
void *sym = dlsym (handle, c_name);
free (c_name);
if (DYNL_HANDLE (dobj) == NULL)
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
else
{
char *chars;
if (!sym) {
SCM message = dlerror_string ("Unknown error");
SCM_MISC_ERROR ("Error resolving ~S: ~S", scm_list_2 (name, message));
}
scm_dynwind_begin (0);
scm_i_dynwind_pthread_mutex_lock (&ltdl_lock);
chars = scm_to_locale_string (name);
scm_dynwind_free (chars);
val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end ();
return scm_from_pointer (val, NULL);
}
return scm_from_pointer (sym, NULL);
}
#undef FUNC_NAME
#define DEFINE_LAZY_VAR(c_name, mod_name, sym_name) \
static SCM c_name##_var; \
static void init_##c_name##_var (void) \
{ \
c_name##_var = scm_c_public_lookup (mod_name, sym_name); \
} \
static SCM c_name (void) \
{ \
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; \
scm_i_pthread_once (&once, init_##c_name##_var); \
return scm_variable_ref (c_name##_var); \
}
SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
(SCM name, SCM dobj),
"Return a ``handle'' for the function @var{name} in the\n"
"shared object referred to by @var{dobj}. The handle\n"
"can be passed to @code{dynamic-call} to actually\n"
"call the function.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
DEFINE_LAZY_VAR (load_foreign_library,
"system foreign-library", "load-foreign-library");
DEFINE_LAZY_VAR (foreign_library_p,
"system foreign-library", "foreign-library?");
DEFINE_LAZY_VAR (foreign_library_pointer,
"system foreign-library", "foreign-library-pointer");
SCM
scm_dynamic_link (SCM filename)
{
return scm_dynamic_pointer (name, dobj);
return scm_call_1 (load_foreign_library (), filename);
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
(SCM func, SCM dobj),
"Call a C function in a dynamic object. Two styles of\n"
"invocation are supported:\n\n"
"@itemize @bullet\n"
"@item @var{func} can be a function handle returned by\n"
"@code{dynamic-func}. In this case @var{dobj} is\n"
"ignored\n"
"@item @var{func} can be a string with the name of the\n"
"function to call, with @var{dobj} the handle of the\n"
"dynamic object in which to find the function.\n"
"This is equivalent to\n"
"@smallexample\n\n"
"(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
"@end smallexample\n"
"@end itemize\n\n"
"In either case, the function is passed no arguments\n"
"and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
SCM
scm_dynamic_object_p (SCM obj)
{
void (*fptr) (void);
return scm_call_1 (foreign_library_p (), obj);
}
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
SCM_VALIDATE_POINTER (SCM_ARG1, func);
SCM
scm_dynamic_pointer (SCM name, SCM obj)
{
return scm_call_2 (foreign_library_pointer (), obj, name);
}
fptr = SCM_POINTER_VALUE (func);
fptr ();
SCM
scm_dynamic_func (SCM name, SCM obj)
{
return scm_dynamic_pointer (name, obj);
}
SCM
scm_dynamic_call (SCM name, SCM obj)
{
SCM pointer = scm_dynamic_pointer (name, obj);
void (*f)(void) = SCM_POINTER_VALUE (pointer);
f();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static void
scm_init_system_foreign_library (void *unused)
{
scm_c_define ("RTLD_LAZY", scm_from_int (RTLD_LAZY));
scm_c_define ("RTLD_NOW", scm_from_int (RTLD_NOW));
scm_c_define ("RTLD_GLOBAL", scm_from_int (RTLD_GLOBAL));
scm_c_define ("RTLD_LOCAL", scm_from_int (RTLD_LOCAL));
#include "dynl.x"
}
void
scm_init_dynamic_linking ()
{
scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_system_foreign_library",
scm_init_system_foreign_library,
NULL);
/* Make LTDL_LOCK recursive so that a pre-unwind handler can still use
'dynamic-link', as is the case at the REPL. See
<https://bugs.gnu.org/29275>. */
scm_i_pthread_mutex_init (&ltdl_lock,
scm_i_pthread_mutexattr_recursive);
sysdep_dynl_init ();
#include "dynl.x"
// FIXME: Deprecate all of these, once (system foreign-library) has
// had enough time in the world.
scm_c_define_gsubr
("dynamic-link", 0, 1, 0, (scm_t_subr) scm_dynamic_link);
scm_c_define_gsubr
("dynamic-object?", 1, 0, 0, (scm_t_subr) scm_dynamic_object_p);
scm_c_define_gsubr
("dynamic-func", 2, 0, 0, (scm_t_subr) scm_dynamic_func);
scm_c_define_gsubr
("dynamic-pointer", 2, 0, 0, (scm_t_subr) scm_dynamic_pointer);
scm_c_define_gsubr
("dynamic-call", 2, 0, 0, (scm_t_subr) scm_dynamic_call);
}