src/code/foreign-load.lisp

   1 ;;;; Loading shared object files
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!ALIEN")
  13
  14 ;;; Used to serialize modifications to *linkage-info*,
  15 ;;; *shared-objects* and the linkage-table proper. Calls thru
  16 ;;; linkage-table are unaffected.
  17 (defvar *foreign-lock*
  18   (sb!thread:make-mutex :name "foreign definition lock"))
  19
  20 (define-unsupported-fun load-foreign
  21     "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  22   "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  23   (load-foreign))
  24
  25 (define-unsupported-fun load-1-foreign
  26     "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  27   "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  28   (load-1-foreign))
  29
  30 (define-alien-routine dlopen system-area-pointer
  31   (file c-string) (mode int))
  32
  33 (define-alien-routine dlclose int
  34   (handle system-area-pointer))
  35
  36 (define-alien-routine dlerror c-string)
  37
  38 (define-alien-routine dlsym system-area-pointer
  39   (handle system-area-pointer)
  40   (symbol c-string))
  41
  42 (defvar *runtime-dlhandle*)
  43 (defvar *shared-objects*)
  44
  45 (defstruct shared-object file sap)
  46
  47 (defun dlopen-or-lose (&optional (obj nil objp))
  48   (when objp
  49     (dlclose-or-lose obj))
  50   (dlerror) ; clear errors
  51   (let* ((file (when obj (shared-object-file obj)))
  52          (sap (dlopen file (logior rtld-global rtld-now))))
  53     (aver (or (not objp) file))
  54     (when (zerop (sap-int sap))
  55       (if objp
  56           (setf (shared-object-sap obj) *runtime-dlhandle*)
  57           (setf *runtime-dlhandle* nil))
  58       (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
  59              obj (dlerror)))
  60     (when objp
  61       (setf (shared-object-sap obj) sap))
  62     sap))
  63
  64 (defun dlclose-or-lose (&optional (obj nil objp))
  65   (dlerror)
  66   (let (dlerror)
  67     (cond ((and (not objp) *runtime-dlhandle*)
  68            (dlclose *runtime-dlhandle*)
  69            (setf dlerror (dlerror)
  70                  *runtime-dlhandle* nil))
  71           ((and objp (shared-object-sap obj))
  72            (dlclose (shared-object-sap obj))
  73            (setf dlerror (dlerror)
  74                  (shared-object-sap obj) nil)))
  75     (when dlerror
  76       (cerror dlerror))))
  77
  78 (defun load-shared-object (file)
  79   "Load a shared library/dynamic shared object file/general dlopenable
  80 alien container, such as a .so on an ELF platform.
  81
  82 Reloading the same shared object will replace the old definitions; if
  83 a symbol was previously referenced thru the object and is not present
  84 in the reloaded version an error will be signalled. Sameness is
  85 determined using the library filename. Reloading may not work as
  86 expected if user or library-code has called dlopen on FILE.
  87
  88 References to foreign symbols in loaded shared objects do not survive
  89 intact through SB-EXT:SAVE-LISP-AND die on all platforms. See
  90 SB-EXT:SAVE-LISP-AND-DIE for details."
  91   (sb!thread:with-mutex (*foreign-lock*)
  92     (let* ((filename (or (unix-namestring file) file))
  93            (old (find filename *shared-objects* :key #'shared-object-file :test #'equal))
  94            (obj (or old (make-shared-object :file filename))))
  95       (dlopen-or-lose obj)
  96       (setf *shared-objects* (append (remove obj *shared-objects*)
  97                                      (list obj)))
  98       #!+linkage-table
  99       (when old
 100         (update-linkage-table))
 101       (pathname filename))))
 102
 103 (defun try-reopen-shared-object (obj)
 104   (with-simple-restart (skip "~@<Skip this shared object and continue. ~
 105                               References to foreign symbols in this ~
 106                               shared object will fail with undefined ~
 107                               consequences.~:>")
 108     (dlopen-or-lose obj)
 109     obj))
 110
 111 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 112 ;;; initialization.
 113 (defun reopen-shared-objects ()
 114   ;; Ensure that the runtime is open
 115   (setf *runtime-dlhandle* (dlopen-or-lose)
 116         *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
 117
 118 ;;; Close all dlopened libraries and clear out sap entries in
 119 ;;; *SHARED-OBJECTS*.
 120 (defun close-shared-objects ()
 121   (mapc #'dlclose-or-lose (reverse *shared-objects*))
 122   (dlclose-or-lose))
 123
 124 (defun get-dynamic-foreign-symbol-address (symbol)
 125   (dlerror) ; clear old errors
 126   (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
 127         (err (dlerror)))
 128     (if (or (not (zerop result)) (not err))
 129         result
 130         (dolist (obj *shared-objects*)
 131           (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
 132                 err (dlerror))
 133           (when (or (not (zerop result)) (not err))
 134             (return result))))))