foreign-library.scm 9.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254
  1. ;;; Dynamically linking foreign libraries via dlopen and dlsym
  2. ;;; Copyright (C) 2021 Free Software Foundation, Inc.
  3. ;;;
  4. ;;; This library is free software: you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU Lesser General Public License as
  6. ;;; published by the Free Software Foundation, either version 3 of the
  7. ;;; License, or (at your option) any later version.
  8. ;;;
  9. ;;; This library is distributed in the hope that it will be useful, but
  10. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;; Lesser General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU Lesser General Public
  15. ;;; License along with this program. If not, see
  16. ;;; <http://www.gnu.org/licenses/>.
  17. ;;; Commentary:
  18. ;;;
  19. ;;; Implementation of dynamic-link.
  20. ;;;
  21. ;;; Code:
  22. (define-module (system foreign-library)
  23. #:use-module (ice-9 match)
  24. #:use-module (srfi srfi-9)
  25. #:use-module (system foreign)
  26. #:export (guile-extensions-path
  27. ltdl-library-path
  28. guile-system-extensions-path
  29. lib->cyg
  30. load-foreign-library
  31. foreign-library?
  32. foreign-library-pointer
  33. foreign-library-function))
  34. (define-record-type <foreign-library>
  35. (make-foreign-library filename handle)
  36. foreign-library?
  37. (filename foreign-library-filename)
  38. (handle foreign-library-handle set-foreign-library-handle!))
  39. (eval-when (expand load eval)
  40. (load-extension (string-append "libguile-" (effective-version))
  41. "scm_init_system_foreign_library"))
  42. (define system-library-extensions
  43. (cond
  44. ((string-contains %host-type "-darwin")
  45. '(".bundle" ".so" ".dylib"))
  46. ((or (string-contains %host-type "cygwin")
  47. (string-contains %host-type "mingw")
  48. (string-contains %host-type "msys"))
  49. '(".dll"))
  50. (else
  51. '(".so"))))
  52. (define (has-extension? head exts)
  53. (match exts
  54. (() #f)
  55. ((ext . exts)
  56. (or (string-contains head ext)
  57. (has-extension? head exts)))))
  58. (define (file-exists-with-extension head exts)
  59. (if (has-extension? head exts)
  60. (and (file-exists? head) head)
  61. (let lp ((exts exts))
  62. (match exts
  63. (() #f)
  64. ((ext . exts)
  65. (let ((head (string-append head ext)))
  66. (if (file-exists? head)
  67. head
  68. (lp exts))))))))
  69. (define (file-exists-in-path-with-extension basename path exts)
  70. (match path
  71. (() #f)
  72. ((dir . path)
  73. (or (file-exists-with-extension (in-vicinity dir basename) exts)
  74. (file-exists-in-path-with-extension basename path exts)))))
  75. (define path-separator
  76. (case (system-file-name-convention)
  77. ((posix) #\:)
  78. ((windows) #\;)
  79. (else (error "unreachable"))))
  80. (define (parse-path var)
  81. (match (getenv var)
  82. (#f #f)
  83. ;; Ignore e.g. "export GUILE_SYSTEM_EXTENSIONS_PATH=".
  84. ("" '())
  85. (val (string-split val path-separator))))
  86. (define guile-extensions-path
  87. (make-parameter
  88. (or (parse-path "GUILE_EXTENSIONS_PATH") '())))
  89. (define ltdl-library-path
  90. (make-parameter
  91. (or (parse-path "LTDL_LIBRARY_PATH") '())))
  92. (define guile-system-extensions-path
  93. (make-parameter
  94. (or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH")
  95. (list (assq-ref %guile-build-info 'libdir)
  96. (assq-ref %guile-build-info 'extensiondir)))))
  97. ;; There are a few messy situations here related to libtool.
  98. ;;
  99. ;; Guile used to use libltdl, the dynamic library loader provided by
  100. ;; libtool. This loader used LTDL_LIBRARY_PATH, and for backwards
  101. ;; compatibility we still support that path.
  102. ;;
  103. ;; However, libltdl would not only open ".so" (or ".dll", etc) files,
  104. ;; but also the ".la" files created by libtool. In installed libraries
  105. ;; -- libraries that are in the target directories of "make install" --
  106. ;; .la files are never needed, to the extent that most GNU/Linux
  107. ;; distributions remove them entirely. It is sufficient to just load
  108. ;; the ".so" (or ".dll", etc) files.
  109. ;;
  110. ;; But for uninstalled dynamic libraries, like those in a build tree, it
  111. ;; is a bit of a mess. If you have a project that uses libtool to build
  112. ;; libraries -- which is the case for Guile, and for most projects using
  113. ;; autotools -- and you build foo.so in directory D, libtool will put
  114. ;; foo.la in D, but foo.so goes in D/.libs.
  115. ;;
  116. ;; The nice thing about ltdl was that it could load the .la file, even
  117. ;; from a build tree, preventing the existence of ".libs" from leaking
  118. ;; out to the user.
  119. ;;
  120. ;; We don't use libltdl now, essentially for flexibility and
  121. ;; error-reporting reasons. But, it would be nice to keep this old
  122. ;; use-case working. So as a stopgap solution, we add a ".libs" subdir
  123. ;; to the path for each entry in LTDL_LIBRARY_PATH, in case the .so is
  124. ;; there instead of alongside the .la file.
  125. (define (augment-ltdl-library-path path)
  126. (match path
  127. (() '())
  128. ((dir . path)
  129. (cons* dir (in-vicinity dir ".libs")
  130. (augment-ltdl-library-path path)))))
  131. (define (default-search-path search-ltdl-library-path?)
  132. (append
  133. (guile-extensions-path)
  134. (if search-ltdl-library-path?
  135. (augment-ltdl-library-path (ltdl-library-path))
  136. '())
  137. (guile-system-extensions-path)))
  138. (define (lib->cyg name)
  139. "Convert a standard shared library name to a Cygwin shared library
  140. name."
  141. (if (not name)
  142. #f
  143. (let ((start (1+ (or (string-index-right
  144. name
  145. (lambda (c) (or (char=? #\\ c) (char=? #\/ c))))
  146. -1))))
  147. (cond
  148. ((>= (+ 3 start) (string-length name))
  149. name)
  150. ((string= name "lib" start (+ start 3))
  151. (string-append (substring name 0 start)
  152. "cyg"
  153. (substring name (+ start 3))))
  154. (else
  155. name)))))
  156. (define* (load-foreign-library #:optional filename #:key
  157. (extensions system-library-extensions)
  158. (search-ltdl-library-path? #t)
  159. (search-path (default-search-path
  160. search-ltdl-library-path?))
  161. (search-system-paths? #t)
  162. (lazy? #t) (global? #f) (rename-on-cygwin? #t))
  163. (define (error-not-found)
  164. (scm-error 'misc-error "load-foreign-library"
  165. "file: ~S, message: ~S"
  166. (list filename "file not found")
  167. #f))
  168. (define flags
  169. (logior (if lazy? RTLD_LAZY RTLD_NOW)
  170. (if global? RTLD_GLOBAL RTLD_LOCAL)))
  171. (define (dlopen* name) (dlopen name flags))
  172. (if (and rename-on-cygwin? (string-contains %host-type "cygwin"))
  173. (set! filename (lib->cyg filename)))
  174. (make-foreign-library
  175. filename
  176. (cond
  177. ((not filename)
  178. ;; The self-open trick.
  179. (dlopen* #f))
  180. ((or (absolute-file-name? filename)
  181. (string-any file-name-separator? filename))
  182. (cond
  183. ((or (file-exists-with-extension filename extensions)
  184. (and search-ltdl-library-path?
  185. (file-exists-with-extension
  186. (in-vicinity (in-vicinity (dirname filename) ".libs")
  187. (basename filename))
  188. extensions)))
  189. => dlopen*)
  190. (else
  191. (error-not-found))))
  192. ((file-exists-in-path-with-extension filename search-path extensions)
  193. => dlopen*)
  194. (search-system-paths?
  195. (if (or (null? extensions) (has-extension? filename extensions))
  196. (dlopen* filename)
  197. (let lp ((extensions extensions))
  198. (match extensions
  199. ((extension)
  200. ;; Open in tail position to propagate any exception.
  201. (dlopen* (string-append filename extension)))
  202. ((extension . extensions)
  203. ;; If there is more than one extension, unfortunately we
  204. ;; only report the error for the last extension. This is
  205. ;; not great because maybe the library was found with the
  206. ;; first extension, failed to load and had an interesting
  207. ;; error, but then we swallowed that interesting error and
  208. ;; proceeded, eventually throwing a "file not found"
  209. ;; exception. FIXME to use more structured exceptions and
  210. ;; stop if the error that we get is more specific than
  211. ;; just "file not found".
  212. (or (false-if-exception
  213. (dlopen* (string-append filename extension)))
  214. (lp extensions)))))))
  215. (else
  216. (error-not-found)))))
  217. (define (->foreign-library lib)
  218. (if (foreign-library? lib)
  219. lib
  220. (load-foreign-library lib)))
  221. (define* (foreign-library-pointer lib name)
  222. (let ((handle (foreign-library-handle (->foreign-library lib))))
  223. (dlsym handle name)))
  224. (define* (foreign-library-function lib name
  225. #:key
  226. (return-type void)
  227. (arg-types '())
  228. (return-errno? #f))
  229. (let ((pointer (foreign-library-pointer lib name)))
  230. (pointer->procedure return-type pointer arg-types
  231. #:return-errno? return-errno?)))