diff options
author | Andy Wingo <wingo@pobox.com> | 2021-01-22 16:39:11 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-02-03 23:02:21 +0100 |
commit | 2e26538d6a51bdd6c2e68ad4539ab3750ef8670a (patch) | |
tree | 85f3f2ae182708804c673e95dc3a739d868771a5 /module | |
parent | 480d86df6847deb55db6731811407c268d2254ed (diff) | |
download | guile-2e26538d6a51bdd6c2e68ad4539ab3750ef8670a.tar.gz |
Replace libltdl with raw dlopen, dlsym
* 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.
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 4 | ||||
-rw-r--r-- | module/oop/goops.scm | 9 | ||||
-rw-r--r-- | module/system/foreign-library.scm | 231 |
3 files changed, 240 insertions, 4 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 45113b542..86d540148 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2009-2020 Free Software Foundation, Inc. +## Copyright (C) 2009-2021 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -334,7 +334,7 @@ SOURCES = \ system/base/ck.scm \ \ system/foreign.scm \ - \ + system/foreign-library.scm \ system/foreign-object.scm \ \ system/repl/debug.scm \ diff --git a/module/oop/goops.scm b/module/oop/goops.scm index df6df4f7b..9edc16b07 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018 +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021 ;;;; Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;;; @@ -3307,10 +3307,15 @@ var{initargs}." (define <directory> (find-subclass <top> '<directory>)) (define <array> (find-subclass <top> '<array>)) (define <character-set> (find-subclass <top> '<character-set>)) -(define <dynamic-object> (find-subclass <top> '<dynamic-object>)) (define <guardian> (find-subclass <applicable> '<guardian>)) (define <macro> (find-subclass <top> '<macro>)) +;; <dynamic-object> used to be a SMOB type, albeit not exported even to +;; C. However now it's a record type, though still private. Cross our +;; fingers that nobody is using it in anger! +(define <dynamic-object> + (module-ref (resolve-module '(system foreign-library)) '<foreign-library>)) + (define (define-class-subtree class) (define! (class-name class) class) (for-each define-class-subtree (class-direct-subclasses class))) diff --git a/module/system/foreign-library.scm b/module/system/foreign-library.scm new file mode 100644 index 000000000..eaeb26700 --- /dev/null +++ b/module/system/foreign-library.scm @@ -0,0 +1,231 @@ +;;; Dynamically linking foreign libraries via dlopen and dlsym +;;; Copyright (C) 2021 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Implementation of dynamic-link. +;;; +;;; Code: + + +(define-module (system foreign-library) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:export (guile-extensions-path + ltdl-library-path + guile-system-extensions-path + + load-foreign-library + foreign-library? + foreign-library-pointer + foreign-library-function)) + +(define-record-type <foreign-library> + (make-foreign-library filename handle) + foreign-library? + (filename foreign-library-filename) + (handle foreign-library-handle set-foreign-library-handle!)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_system_foreign_library")) + +(define system-library-extensions + (cond + ((string-contains %host-type "-darwin-") + '(".bundle" ".so" ".dylib")) + ((or (string-contains %host-type "cygwin") + (string-contains %host-type "mingw") + (string-contains %host-type "msys")) + '(".dll")) + (else + '(".so")))) + +(define (has-extension? head exts) + (match exts + (() #f) + ((ext . exts) + (or (string-contains head ext) + (has-extension? head exts))))) + +(define (file-exists-with-extension head exts) + (if (has-extension? head exts) + (and (file-exists? head) head) + (let lp ((exts exts)) + (match exts + (() #f) + ((ext . exts) + (let ((head (string-append head ext))) + (if (file-exists? head) + head + (lp exts)))))))) + +(define (file-exists-in-path-with-extension basename path exts) + (match path + (() #f) + ((dir . path) + (or (file-exists-with-extension (in-vicinity dir basename) exts) + (file-exists-in-path-with-extension basename path exts))))) + +(define path-separator + (case (system-file-name-convention) + ((posix) #\:) + ((windows) #\;) + (else (error "unreachable")))) + +(define (parse-path var) + (match (getenv var) + (#f #f) + ;; Ignore e.g. "export GUILE_SYSTEM_EXTENSIONS_PATH=". + ("" '()) + (val (string-split val path-separator)))) + +(define guile-extensions-path + (make-parameter + (or (parse-path "GUILE_EXTENSIONS_PATH") '()))) + +(define ltdl-library-path + (make-parameter + (or (parse-path "LTDL_LIBRARY_PATH") '()))) + +(define guile-system-extensions-path + (make-parameter + (or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH") + (list (assq-ref %guile-build-info 'libdir) + (assq-ref %guile-build-info 'extensiondir))))) + +;; There are a few messy situations here related to libtool. +;; +;; Guile used to use libltdl, the dynamic library loader provided by +;; libtool. This loader used LTDL_LIBRARY_PATH, and for backwards +;; compatibility we still support that path. +;; +;; However, libltdl would not only open ".so" (or ".dll", etc) files, +;; but also the ".la" files created by libtool. In installed libraries +;; -- libraries that are in the target directories of "make install" -- +;; .la files are never needed, to the extent that most GNU/Linux +;; distributions remove them entirely. It is sufficient to just load +;; the ".so" (or ".dll", etc) files. +;; +;; But for uninstalled dynamic libraries, like those in a build tree, it +;; is a bit of a mess. If you have a project that uses libtool to build +;; libraries -- which is the case for Guile, and for most projects using +;; autotools -- and you build foo.so in directory D, libtool will put +;; foo.la in D, but foo.so goes in D/.libs. +;; +;; The nice thing about ltdl was that it could load the .la file, even +;; from a build tree, preventing the existence of ".libs" from leaking +;; out to the user. +;; +;; We don't use libltdl now, essentially for flexibility and +;; error-reporting reasons. But, it would be nice to keep this old +;; use-case working. So as a stopgap solution, we add a ".libs" subdir +;; to the path for each entry in LTDL_LIBRARY_PATH, in case the .so is +;; there instead of alongside the .la file. +(define (augment-ltdl-library-path path) + (match path + (() '()) + ((dir . path) + (cons* dir (in-vicinity dir ".libs") + (augment-ltdl-library-path path))))) + +(define (default-search-path search-ltdl-library-path?) + (append + (guile-extensions-path) + (if search-ltdl-library-path? + (augment-ltdl-library-path (ltdl-library-path)) + '()) + (guile-system-extensions-path))) + +(define* (load-foreign-library #:optional filename #:key + (extensions system-library-extensions) + (search-ltdl-library-path? #t) + (search-path (default-search-path + search-ltdl-library-path?)) + (search-system-paths? #t) + (lazy? #t) (global? #f)) + (define (error-not-found) + (scm-error 'misc-error "load-foreign-library" + "file: ~S, message: ~S" + (list filename "file not found") + #f)) + (define flags + (logior (if lazy? RTLD_LAZY RTLD_NOW) + (if global? RTLD_GLOBAL RTLD_LOCAL))) + (define (dlopen* name) (dlopen name flags)) + (make-foreign-library + filename + (cond + ((not filename) + ;; The self-open trick. + (dlopen* #f)) + ((or (absolute-file-name? filename) + (string-any file-name-separator? filename)) + (cond + ((or (file-exists-with-extension filename extensions) + (and search-ltdl-library-path? + (file-exists-with-extension + (in-vicinity (in-vicinity (dirname filename) ".libs") + (basename filename)) + extensions))) + => dlopen*) + (else + (error-not-found)))) + ((file-exists-in-path-with-extension filename search-path extensions) + => dlopen*) + (search-system-paths? + (if (or (null? extensions) (has-extension? filename extensions)) + (dlopen* filename) + (let lp ((extensions extensions)) + (match extensions + ((extension) + ;; Open in tail position to propagate any exception. + (dlopen* (string-append filename extension))) + ((extension . extensions) + ;; If there is more than one extension, unfortunately we + ;; only report the error for the last extension. This is + ;; not great because maybe the library was found with the + ;; first extension, failed to load and had an interesting + ;; error, but then we swallowed that interesting error and + ;; proceeded, eventually throwing a "file not found" + ;; exception. FIXME to use more structured exceptions and + ;; stop if the error that we get is more specific than + ;; just "file not found". + (or (false-if-exception + (dlopen* (string-append filename extension))) + (lp extensions))))))) + (else + (error-not-found))))) + +(define (->foreign-library lib) + (if (foreign-library? lib) + lib + (load-foreign-library lib))) + +(define* (foreign-library-pointer lib name) + (let ((handle (foreign-library-handle (->foreign-library lib)))) + (dlsym handle name))) + +(define* (foreign-library-function lib name + #:key + (return-type void) + (arg-types '()) + (return-errno? #f)) + (let ((pointer (foreign-library-pointer lib name))) + (pointer->procedure return-type pointer arg-types + #:return-errno? return-errno?))) |