From 1caa31680cbf995f3c8af3db7ce9084f87126b37 Mon Sep 17 00:00:00 2001 From: Jarhmander Date: Wed, 15 Nov 2023 18:55:23 -0500 Subject: [PATCH] Make (load-shared-object #f) portable (#753) --- c/externs.h | 1 + c/foreign.c | 49 +++++++++++++++++++++++++++++++++++++++-------- c/windows.c | 31 ++++++++++++++++++++++++++++++ csug/foreign.stex | 26 +++++++++++++++++++++++-- mats/foreign.ms | 12 ++++++++++++ 5 files changed, 109 insertions(+), 10 deletions(-) diff --git a/c/externs.h b/c/externs.h index 229e1fad4..eb98bea13 100644 --- a/c/externs.h +++ b/c/externs.h @@ -445,6 +445,7 @@ extern ptr *S_get_call_arena(ptr tc); /* windows.c */ extern INT S_getpagesize(void); extern ptr S_LastErrorString(void); +extern HMODULE *S_enum_process_modules(void); extern void *S_ntdlopen(const char *path); extern void *S_ntdlsym(void *h, const char *s); extern ptr S_ntdlerror(void); diff --git a/c/foreign.c b/c/foreign.c index 8f02b955d..c8493e122 100644 --- a/c/foreign.c +++ b/c/foreign.c @@ -112,17 +112,42 @@ static ptr lookup_dynamic(const char *s, ptr tbl) { ptr p; for (p = tbl; p != Snil; p = Scdr(p)) { + #ifdef HPUX - (void *)value = (void *)0; /* assignment to prevent compiler warning */ + void *value = NULL; shl_t handle = (shl_t)ptr_to_addr(Scar(p)); - if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0) + /* + * With NULL path, use RTLD_SELF to act like dlopen(NULL, ...) + * See: https://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/dlsym.3C.html + */ + if (!handle) + handle = (void*)RTLD_SELF; + + if (shl_findsym(&handle, s, TYPE_PROCEDURE, &value) == 0) return addr_to_ptr(proc2entry(value, NULL)); #else /* HPUX */ void *value; - - value = dlsym(ptr_to_addr(Scar(p)), s); - if (value != (void *)0) return addr_to_ptr(value); + void *handle = ptr_to_addr(Scar(p)); + +#ifdef WIN32 + if (!handle) { + HMODULE *modules = S_enum_process_modules(); + if (modules) { + for (HMODULE *m = modules; *m; ++m) { + value = dlsym(*m, s); + if (value != NULL) break; + } + free(modules); + if (value != NULL) + return addr_to_ptr(value); + } + } else +#endif /* WIN32 */ + { + value = dlsym(handle, s); + if (value != NULL) return addr_to_ptr(value); + } #endif /* HPUX */ } @@ -229,9 +254,17 @@ static void load_shared_object(const char *path) { tc_mutex_acquire(); - handle = dlopen(path, RTLD_NOW); - if (handle == (void *)NULL) - S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror()); +#if defined(WIN32) || defined(HPUX) + if (!path) { + handle = NULL; + } else +#endif /* machine types */ + { + handle = dlopen(path, RTLD_NOW); + if (handle == (void *)NULL) + S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror()); + } + S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic); tc_mutex_release(); diff --git a/c/windows.c b/c/windows.c index 2557ad3b3..235a60920 100644 --- a/c/windows.c +++ b/c/windows.c @@ -18,6 +18,7 @@ #include "system.h" #include +#include #include #include @@ -49,6 +50,36 @@ void *S_ntdlopen(const char *path) { return r; } +HMODULE *S_enum_process_modules(void) { + DWORD cur_num_bytes = 1024; + DWORD req_num_bytes; + HMODULE *modules = malloc(cur_num_bytes); + + if (!modules) + return NULL; + + for (;;) { + if (!EnumProcessModules(GetCurrentProcess(), modules, cur_num_bytes, &req_num_bytes)) + return NULL; + req_num_bytes += sizeof *modules; // for sentinel NULL value + if (req_num_bytes <= cur_num_bytes) + break; + HMODULE *new_mod = realloc(modules, req_num_bytes); + if (!new_mod) { + free(modules); + return NULL; + } + + modules = new_mod; + cur_num_bytes = req_num_bytes; + } + + const size_t numel = req_num_bytes/sizeof *modules; + modules[numel - 1] = NULL; + + return modules; +} + void *S_ntdlsym(void *h, const char *s) { return (void *)GetProcAddress(h, s); } diff --git a/csug/foreign.stex b/csug/foreign.stex index d1d04e77f..32c1eca6b 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -2670,8 +2670,9 @@ via one of the other methods described in this section. \endentryheader \noindent -\var{path} must be a string. -\scheme{load-shared-object} loads the shared object named by \var{path}. +\var{path} must be a string or \scheme{#f}. +If \var{path} is a string, \scheme{load-shared-object} loads the shared object +named by \var{path}. Shared objects may be system libraries or files created from ordinary C programs. All external symbols in the shared object, along with external symbols @@ -2685,6 +2686,26 @@ If \var{path} does not begin with a ``.'' or ``/'', the shared object is searched for in a default set of directories determined by the system. +If \var{path} is \scheme{#f}, external symbols in the executable itself (if +any), as well as those found in dependent shared objects, are also made +available as foreign entries. +Usually, executables do not export symbols, but can be instructed to do so with +proper compilation flags. +One may thus create an executable based on {\ChezScheme}, and have Scheme code +access exported symbols from it and also from any shared object dynamically +linked to it. + +Because {\ChezScheme} is usually dynamically linked to the operating system's C +library, all built-in C library functions are also accessible after evaluation +of \scheme{(load-shared-object #f)}. +This provides a simple way to gain access to standard C functions (such as +\var{memcpy} or \var{getenv}), which may be very convenient for Scheme programs +intended to be portable across different systems. +If {\ChezScheme} is statically linked however, the standard C functions may only +be accessible in this manner if they are present in the executable and +exported, otherwise the shared object containing the C library must be +explicitly named; see below for examples for some platforms. + On most Unix systems, \scheme{load-shared-object} is based on the system routine \scheme{dlopen}. %Under AIX, \scheme{load-shared-object} is based on the system routine @@ -2701,6 +2722,7 @@ The name of the shared object varies from one system to another. % On Sun Sparc systems running Solaris 2.X or higher % running Digital Unix 2.X or higher, and SGI systems running IRIX 5.X % or higher + On Linux systems: \schemedisplay diff --git a/mats/foreign.ms b/mats/foreign.ms index 117f0e3c8..1c95cb8b0 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -294,6 +294,18 @@ ) ]) +(mat load-shared-object-f + (equal? + (with-input-from-string + (separate-eval + '(begin + (printf "(~S " (foreign-entry? "memcpy")) + (load-shared-object #f) + (printf "~S)~%" (foreign-entry? "memcpy")) + (void))) + read) + '(#f #t))) + (mat foreign-entry? (foreign-entry? "id") (foreign-entry? "idid")