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