[Guile-commits] branch excise-ltdl updated: whoops, add foreign-library

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch excise-ltdl
in repository guile.

The following commit(s) were added to refs/heads/excise-ltdl by this push:
     new a39b592  whoops, add foreign-library
a39b592 is described below

commit a39b592ddc576a1d350eac1ba5777f7ec9a4bfef
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jan 28 17:28:18 2021 +0100

    whoops, add foreign-library
---
 module/system/foreign-library.scm | 231 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 231 insertions(+)

diff --git a/module/system/foreign-library.scm 
b/module/system/foreign-library.scm
new file mode 100644
index 0000000..6945fca
--- /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 'extensionsdir)))))
+
+;; 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?)))