summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2021-01-22 16:39:11 +0100
committerAndy Wingo <wingo@pobox.com>2021-02-03 23:02:21 +0100
commit2e26538d6a51bdd6c2e68ad4539ab3750ef8670a (patch)
tree85f3f2ae182708804c673e95dc3a739d868771a5 /module
parent480d86df6847deb55db6731811407c268d2254ed (diff)
downloadguile-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.am4
-rw-r--r--module/oop/goops.scm9
-rw-r--r--module/system/foreign-library.scm231
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?)))