diff options
Diffstat (limited to 'libguile/dynl.c')
-rw-r--r-- | libguile/dynl.c | 427 |
1 files changed, 115 insertions, 312 deletions
diff --git a/libguile/dynl.c b/libguile/dynl.c index e9c03e95b..8e1cc90d9 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -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) -{ - 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; -} - -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) +static SCM +dlerror_string (const char *fallback) { - 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; + const char *message = dlerror (); + if (message) + return scm_from_locale_string (message); + return scm_from_utf8_string ("Unknown error"); } -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 (<dl_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 (); + if (!handle) { + SCM message = dlerror_string ("Unknown error while opening module"); + SCM_MISC_ERROR ("file ~S, message ~S", scm_list_2 (name, message)); + } - SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, - SCM_UNBNDP (filename) - ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename), - handle); + return scm_from_pointer (handle, NULL); } #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 +SCM_DEFINE_STATIC (scm_dlclose, "dlclose", 1, 0, 0, (SCM obj), "") +#define FUNC_NAME s_scm_dlclose { - return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj)); -} -#undef FUNC_NAME + void *handle = scm_to_pointer (obj); - -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 (<dl_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 (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; - - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (<dl_lock); - chars = scm_to_locale_string (name); - scm_dynwind_free (chars); - val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); - scm_dynwind_end (); + if (!sym) { + SCM message = dlerror_string ("Unknown error"); + SCM_MISC_ERROR ("Error resolving ~S: ~S", scm_list_2 (name, message)); + } - 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 +scm_dynamic_object_p (SCM obj) +{ + return scm_call_1 (foreign_library_p (), obj); +} -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_pointer (SCM name, SCM obj) { - void (*fptr) (void); + return scm_call_2 (foreign_library_pointer (), obj, name); +} - if (scm_is_string (func)) - func = scm_dynamic_func (func, dobj); - SCM_VALIDATE_POINTER (SCM_ARG1, func); +SCM +scm_dynamic_func (SCM name, SCM obj) +{ + return scm_dynamic_pointer (name, obj); +} - fptr = SCM_POINTER_VALUE (func); - fptr (); +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 -void -scm_init_dynamic_linking () +static void +scm_init_system_foreign_library (void *unused) { - scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0); - scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print); + 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)); - /* 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 (<dl_lock, - scm_i_pthread_mutexattr_recursive); - - sysdep_dynl_init (); #include "dynl.x" } + +void +scm_init_dynamic_linking () +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_system_foreign_library", + scm_init_system_foreign_library, + NULL); + + // 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); +} |