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-variable undefined-alien-address unsigned)
  29 (defvar *runtime-dlhandle*)
  30
  31 (defvar *shared-objects*)
  32
  33 (defstruct shared-object pathname namestring handle dont-save)
  34
  35 (defun load-shared-object (pathname &key dont-save)
  36   #!+sb-doc
  37   "Load a shared library / dynamic shared object file / similar foreign
  38 container specified by designated PATHNAME, such as a .so on an ELF platform.
  39
  40 Locating the shared object follows standard rules of the platform, consult the
  41 manual page for dlopen(3) for details. Typically paths specified by
  42 environment variables such as LD_LIBRARY_PATH are searched if the PATHNAME has
  43 no directory, but on some systems (eg. Mac OS X) search may happen even if
  44 PATHNAME is absolute. (On Windows LoadLibrary is used instead of dlopen(3).)
  45
  46 On non-Windows platforms calling LOAD-SHARED-OBJECT again with a PATHNAME
  47 EQUAL to the designated pathname of a previous call will replace the old
  48 definitions; if a symbol was previously referenced through the object and
  49 is not present in the reloaded version an error will be signalled. Reloading
  50 may not work as expected if user or library-code has called dlopen(3) on the
  51 same shared object.
  52
  53 LOAD-SHARED-OBJECT interacts with SB-EXT:SAVE-LISP-AND-DIE:
  54
  55 1. If DONT-SAVE is true (default is NIL), the shared object will be dropped
  56 when SAVE-LISP-AND-DIE is called -- otherwise shared objects are reloaded
  57 automatically when a saved core starts up. Specifying DONT-SAVE can be useful
  58 when the location of the shared object on startup is uncertain.
  59
  60 2. On most platforms references in compiled code to foreign symbols in shared
  61 objects (such as those generated by DEFINE-ALIEN-ROUTINE) remain valid across
  62 SAVE-LISP-AND-DIE. On those platforms where this is not supported, a WARNING
  63 will be signalled when the core is saved -- this is orthogonal from DONT-SAVE."
  64   (let ((pathname (pathname pathname)))
  65     (sb!thread:with-mutex (*shared-objects-lock*)
  66       (let* ((old (find pathname *shared-objects*
  67                         :key #'shared-object-pathname
  68                         :test #'equal))
  69              (obj (or old (make-shared-object
  70                            :pathname pathname
  71                            :namestring (native-namestring
  72                                         (translate-logical-pathname pathname)
  73                                         :as-file t)))))
  74         (setf (shared-object-dont-save obj) dont-save)
  75         ;; FIXME: Why doesn's dlopen-or-lose on already loaded stuff work on
  76         ;; Windows?
  77         ;;
  78         ;; Kovalenko 2010-11-24: It would work, but it does nothing
  79         ;; useful on Windows: library reference count is increased
  80         ;; after each LoadLibrary, making it harder to unload it, and
  81         ;; that's all the effect. Also, equal pathnames on Windows
  82         ;; always designate _exactly the same library image_; Unix
  83         ;; tricks like deleting an open library and replacing it with
  84         ;; another version just don't work here.
  85         #!-win32
  86         (dlopen-or-lose obj)
  87         #!+win32
  88         (unless old
  89           (dlopen-or-lose obj))
  90         (setf *shared-objects* (append (remove obj *shared-objects*)
  91                                        (list obj)))
  92         ;; FIXME: Why doesn't the linkage table work on Windows? (Or maybe it
  93         ;; does and this can be just #!+linkage-table?) Note: remember to change
  94         ;; FOREIGN-DEINIT as well then!
  95         ;;
  96         ;; Kovalenko 2010-11-24: I think so. Alien _data_ references
  97         ;; are the only thing on win32 that is even slightly
  98         ;; problematic. Handle function references in the same way as
  99         ;; other linkage-table platforms is easy.
 100         ;;
 101         #!+linkage-table
 102         (when (or old (undefined-foreign-symbols-p))
 103           (update-linkage-table))))
 104     pathname))
 105
 106 (defun unload-shared-object (pathname)
 107   #!+sb-doc
 108   "Unloads the shared object loaded earlier using the designated PATHNAME with
 109 LOAD-SHARED-OBJECT, to the degree supported on the platform.
 110
 111 Experimental."
 112   (let ((pathname (pathname pathname)))
 113     (sb!thread:with-mutex (*shared-objects-lock*)
 114       (let ((old (find pathname *shared-objects*
 115                        :key #'shared-object-pathname
 116                        :test #'equal)))
 117         (when old
 118           #!-hpux (dlclose-or-lose old)
 119           (setf *shared-objects* (remove old *shared-objects*))
 120           #!+linkage-table
 121           (update-linkage-table))))))
 122
 123 (defun try-reopen-shared-object (obj)
 124   (declare (type shared-object obj))
 125   (tagbody :dlopen
 126      (restart-case
 127          (dlopen-or-lose obj)
 128        (continue ()
 129          :report "Skip this shared object and continue."
 130          ;; By returning NIL the shared object is dropped from the list.
 131          (setf (shared-object-handle obj) nil)
 132          (return-from try-reopen-shared-object nil))
 133        (retry ()
 134          :report "Retry loading this shared object."
 135          (go :dlopen))
 136        (change-pathname ()
 137          :report "Specify a different pathname to load the shared object from."
 138          (tagbody :query
 139             (format *query-io* "~&Enter pathname (evaluated):~%")
 140             (force-output *query-io*)
 141             (let ((pathname (ignore-errors (pathname (read *query-io*)))))
 142               (unless (pathnamep pathname)
 143                 (format *query-io* "~&Error: invalid pathname.~%")
 144                 (go :query))
 145               (setf (shared-object-pathname obj) pathname)
 146               (setf (shared-object-namestring obj)
 147                     (native-namestring (translate-logical-pathname pathname)
 148                                        :as-file t))))
 149          (go :dlopen))))
 150   obj)
 151
 152 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 153 ;;; initialization.
 154 (defun reopen-shared-objects ()
 155   ;; Ensure that the runtime is open
 156   (setf *runtime-dlhandle* (dlopen-or-lose))
 157   ;; Without this many symbols aren't accessible.
 158   #!+android (load-shared-object "libc.so" :dont-save t)
 159   ;; Reopen stuff.
 160   (setf *shared-objects*
 161         (remove nil (mapcar #'try-reopen-shared-object *shared-objects*))))
 162
 163 ;;; Close all dlopened libraries and clear out sap entries in
 164 ;;; *SHARED-OBJECTS*, and drop the ones with DONT-SAVE set.
 165 (defun close-shared-objects ()
 166   (let (saved)
 167     (dolist (obj (reverse *shared-objects*))
 168       #!-hpux (dlclose-or-lose obj)
 169       (unless (shared-object-dont-save obj)
 170         (push obj saved)))
 171     (setf *shared-objects* saved))
 172   #!-hpux
 173   (dlclose-or-lose))
 174
 175 (let ((symbols (make-hash-table :test #'equal))
 176       (undefineds (make-hash-table :test #'equal)))
 177   (defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
 178     #!+sb-doc
 179     "Returns the address of the foreign symbol as an integer. On linkage-table
 180 ports if the symbols isn't found a special guard address is returned instead,
 181 accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an
 182 error is immediately signalled if the symbol isn't found. The returned address
 183 is never in the linkage-table."
 184     (declare (ignorable datap))
 185     (let ((addr (find-dynamic-foreign-symbol-address symbol)))
 186       (cond  #!-linkage-table
 187              ((not addr)
 188               (error 'undefined-alien-error :name symbol))
 189              #!+linkage-table
 190              ((not addr)
 191               (style-warn 'sb!kernel:undefined-alien-style-warning
 192                           :symbol symbol)
 193               (setf (gethash symbol undefineds) t)
 194               (remhash symbol symbols)
 195               (if datap
 196                   undefined-alien-address
 197                   (find-foreign-symbol-address "undefined_alien_function")))
 198              (addr
 199               (setf (gethash symbol symbols) t)
 200               (remhash symbol undefineds)
 201               addr))))
 202   (defun undefined-foreign-symbols-p ()
 203     (plusp (hash-table-count undefineds)))
 204   (defun dynamic-foreign-symbols-p ()
 205     (plusp (hash-table-count symbols)))
 206   (defun list-dynamic-foreign-symbols ()
 207     (loop for symbol being each hash-key in symbols
 208          collect symbol))
 209   (defun list-undefined-foreign-symbols ()
 210     (loop for symbol being each hash-key in undefineds
 211           collect symbol)))