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 *shared-objects*.
  15 (defvar *shared-objects-lock*
  16   (sb!thread:make-mutex :name "shared object list lock"))
  17
  18 (define-unsupported-fun load-foreign
  19     "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  20   "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  21   (load-foreign))
  22
  23 (define-unsupported-fun load-1-foreign
  24     "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  25   "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  26   (load-1-foreign))
  27
  28 (define-alien-routine dlopen system-area-pointer
  29   (file c-string) (mode int))
  30
  31 (define-alien-routine dlclose int
  32   (handle system-area-pointer))
  33
  34 (define-alien-routine dlerror c-string)
  35
  36 (define-alien-routine
  37     #!-openbsd dlsym
  38     #!+openbsd ("os_dlsym" dlsym)
  39     system-area-pointer
  40   (handle system-area-pointer)
  41   (symbol c-string))
  42
  43 (define-alien-variable undefined-alien-address unsigned-long)
  44
  45 (defvar *runtime-dlhandle*)
  46 (defvar *shared-objects*)
  47
  48 (defstruct shared-object file sap)
  49
  50 (defun dlopen-or-lose (&optional (obj nil objp))
  51   (when objp
  52     (dlclose-or-lose obj))
  53   (dlerror) ; clear errors
  54   (let* ((file (and obj (shared-object-file obj)))
  55          (sap (dlopen file (logior rtld-global rtld-now))))
  56     (aver (or (not objp) file))
  57     (when (zerop (sap-int sap))
  58       (if objp
  59           (setf (shared-object-sap obj) nil)
  60           (setf *runtime-dlhandle* nil))
  61       (error "Error opening ~:[runtime~;shared object ~:*~S~]:~%  ~A."
  62              file (dlerror)))
  63     (when objp
  64       (setf (shared-object-sap obj) sap))
  65     sap))
  66
  67 (defun dlclose-or-lose (&optional (obj nil objp))
  68   (dlerror)
  69   (let (dlerror)
  70     (cond ((and (not objp) *runtime-dlhandle*)
  71            (dlclose *runtime-dlhandle*)
  72            (setf dlerror (dlerror)
  73                  *runtime-dlhandle* nil))
  74           ((and objp (shared-object-sap obj))
  75            (dlclose (shared-object-sap obj))
  76            (setf dlerror (dlerror)
  77                  (shared-object-sap obj) nil)))
  78     (when dlerror
  79       (cerror "Ignore the error and continue anyway" "dlerror returned an error: ~S" dlerror))))
  80
  81 (defun load-shared-object (file)
  82   "Load a shared library/dynamic shared object file/general dlopenable
  83 alien container, such as a .so on an ELF platform.
  84
  85 Reloading the same shared object will replace the old definitions; if
  86 a symbol was previously referenced thru the object and is not present
  87 in the reloaded version an error will be signalled. Sameness is
  88 determined using the library filename. Reloading may not work as
  89 expected if user or library-code has called dlopen on FILE.
  90
  91 References to foreign symbols in loaded shared objects do not survive
  92 intact through SB-EXT:SAVE-LISP-AND-DIE on all platforms. See
  93 SB-EXT:SAVE-LISP-AND-DIE for details."
  94   (let ((filename (or (unix-namestring file) file))
  95         (old nil))
  96     (sb!thread:with-mutex (*shared-objects-lock*)
  97       (setf old (find filename *shared-objects* :key #'shared-object-file :test #'equal))
  98       (let* ((obj (or old (make-shared-object :file filename))))
  99         (dlopen-or-lose obj)
 100         (setf *shared-objects* (append (remove obj *shared-objects*)
 101                                        (list obj)))))
 102     #!+linkage-table
 103     (when (or old (undefined-foreign-symbols-p))
 104       (update-linkage-table))
 105     (pathname filename)))
 106
 107 (defun try-reopen-shared-object (obj)
 108   (declare (type shared-object obj))
 109   (tagbody :dlopen
 110      (restart-case
 111          (dlopen-or-lose obj)
 112        (continue ()
 113          :report "Skip this shared object and continue."
 114          (setf (shared-object-sap obj) nil))
 115        (retry ()
 116          :report "Retry loading this shared object."
 117          (go :dlopen))
 118        (load-other ()
 119          :report "Specify an alternate shared object file to load."
 120          (setf (shared-object-file obj)
 121                (tagbody :query
 122                   (format *query-io* "~&Enter pathname (evaluated):~%")
 123                   (force-output *query-io*)
 124                   (let ((pathname (ignore-errors (pathname (read *query-io*)))))
 125                     (unless (pathnamep pathname)
 126                       (format *query-io* "~&Error: invalid pathname.~%")
 127                       (go :query))
 128                     (unix-namestring pathname)))))))
 129   obj)
 130
 131 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 132 ;;; initialization.
 133 (defun reopen-shared-objects ()
 134   ;; Ensure that the runtime is open
 135   (setf *runtime-dlhandle* (dlopen-or-lose)
 136         *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
 137
 138 ;;; Close all dlopened libraries and clear out sap entries in
 139 ;;; *SHARED-OBJECTS*.
 140 (defun close-shared-objects ()
 141   (mapc #'dlclose-or-lose (reverse *shared-objects*))
 142   (dlclose-or-lose))
 143
 144 (defun find-dynamic-foreign-symbol-address (symbol)
 145   (dlerror)                             ; clear old errors
 146   (unless *runtime-dlhandle*
 147     (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
 148   ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
 149   ;; but on platforms where dlsym is simulated we use the mangled name.
 150   (let* ((extern (extern-alien-name symbol))
 151          (result (sap-int (dlsym *runtime-dlhandle* extern)))
 152          (err (dlerror)))
 153     (if (or (not (zerop result)) (not err))
 154         result
 155         (dolist (obj *shared-objects*)
 156           (let ((sap (shared-object-sap obj)))
 157             (when sap
 158               (setf result (sap-int (dlsym sap extern))
 159                     err (dlerror))
 160               (when (or (not (zerop result)) (not err))
 161                 (return result))))))))
 162
 163 (let ((symbols (make-hash-table :test #'equal))
 164       (undefineds (make-hash-table :test #'equal)))
 165   (defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
 166     "Returns the address of the foreign symbol as an integer. On linkage-table
 167 ports if the symbols isn't found a special guard address is returned instead,
 168 accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an
 169 error is immediately signalled if the symbol isn't found. The returned address
 170 is never in the linkage-table."
 171     (declare (ignorable datap))
 172     (let ((addr (find-dynamic-foreign-symbol-address symbol)))
 173       (cond  #!-linkage-table
 174              ((not addr)
 175               (error 'undefined-alien-error :name symbol))
 176              #!+linkage-table
 177              ((not addr)
 178               (style-warn "Undefined alien: ~S" symbol)
 179               (setf (gethash symbol undefineds) t)
 180               (remhash symbol symbols)
 181               (if datap
 182                   undefined-alien-address
 183                   (foreign-symbol-address "undefined_alien_function")))
 184              (addr
 185               (setf (gethash symbol symbols) t)
 186               (remhash symbol undefineds)
 187               addr))))
 188   (defun undefined-foreign-symbols-p ()
 189     (plusp (hash-table-count undefineds)))
 190   (defun dynamic-foreign-symbols-p ()
 191     (plusp (hash-table-count symbols)))
 192   (defun list-dynamic-foreign-symbols ()
 193     (loop for symbol being each hash-key in symbols
 194          collect symbol)))
 195