summaryrefslogtreecommitdiff
path: root/libguile/dynl.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/dynl.c')
-rw-r--r--libguile/dynl.c427
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 (&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 ();
+ 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 (&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 (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 (&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 ();
+ 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 (&ltdl_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);
+}