(in-package "SB!ALIEN")
+;;; Used to serialize modifications to *shared-objects*.
+(defvar *shared-objects-lock*
+ (sb!thread:make-mutex :name "shared object list lock"))
+
(define-unsupported-fun load-foreign
"Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
- "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
+ "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
(load-foreign))
-
+
(define-unsupported-fun load-1-foreign
"Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
"~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
(load-1-foreign))
-(define-alien-routine dlopen system-area-pointer
- (file c-string) (mode int))
-
-(define-alien-routine dlclose int
- (handle system-area-pointer))
-
-(define-alien-routine dlerror c-string)
-
-(define-alien-routine dlsym system-area-pointer
- (handle system-area-pointer)
- (symbol c-string))
+(progn
+ (define-alien-variable undefined-alien-address unsigned)
+ (defvar *runtime-dlhandle*))
-(defvar *runtime-dlhandle*)
(defvar *shared-objects*)
-(defstruct shared-object file sap)
-
-(defun dlopen-or-lose (filename)
- (dlerror) ; clear old errors
- (let ((sap (dlopen filename (logior rtld-global rtld-now))))
- (when (zerop (sap-int sap))
- (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
- filename (dlerror)))
- sap))
-
-(defun load-shared-object (file)
- "Load a shared library/dynamic shared object file/general
-dlopenable alien container, such as a .so on an ELF platform.
-
-References to foreign symbols in loaded shared objects do not survive
-intact through SB-EXT:SAVE-LISP-AND die on all platforms. See
-SB-EXT:SAVE-LISP-AND-DIE for details."
- (let* ((real-file (or (unix-namestring file) file))
- (sap (dlopen-or-lose real-file))
- (obj (make-shared-object :file real-file :sap sap)))
- (unless (member sap *shared-objects*
- :test #'sap= :key #'shared-object-sap)
- (setf *shared-objects* (append *shared-objects* (list obj))))
- (pathname real-file)))
+(defstruct shared-object pathname namestring handle dont-save)
+
+(defun load-shared-object (pathname &key dont-save)
+ #!+sb-doc
+ "Load a shared library / dynamic shared object file / similar foreign
+container specified by designated PATHNAME, such as a .so on an ELF platform.
+
+Locating the shared object follows standard rules of the platform, consult the
+manual page for dlopen(3) for details. Typically paths specified by
+environment variables such as LD_LIBRARY_PATH are searched if the PATHNAME has
+no directory, but on some systems (eg. Mac OS X) search may happen even if
+PATHNAME is absolute. (On Windows LoadLibrary is used instead of dlopen(3).)
+
+On non-Windows platforms calling LOAD-SHARED-OBJECT again with a PATHNAME
+EQUAL to the designated pathname of a previous call will replace the old
+definitions; if a symbol was previously referenced through the object and
+is not present in the reloaded version an error will be signalled. Reloading
+may not work as expected if user or library-code has called dlopen(3) on the
+same shared object.
+
+LOAD-SHARED-OBJECT interacts with SB-EXT:SAVE-LISP-AND-DIE:
+
+1. If DONT-SAVE is true (default is NIL), the shared object will be dropped
+when SAVE-LISP-AND-DIE is called -- otherwise shared objects are reloaded
+automatically when a saved core starts up. Specifying DONT-SAVE can be useful
+when the location of the shared object on startup is uncertain.
+
+2. On most platforms references in compiled code to foreign symbols in shared
+objects (such as those generated by DEFINE-ALIEN-ROUTINE) remain valid across
+SAVE-LISP-AND-DIE. On those platforms where this is not supported, a WARNING
+will be signalled when the core is saved -- this is orthogonal from DONT-SAVE."
+ (let ((pathname (pathname pathname)))
+ (sb!thread:with-mutex (*shared-objects-lock*)
+ (let* ((old (find pathname *shared-objects*
+ :key #'shared-object-pathname
+ :test #'equal))
+ (obj (or old (make-shared-object
+ :pathname pathname
+ :namestring (native-namestring
+ (translate-logical-pathname pathname)
+ :as-file t)))))
+ (setf (shared-object-dont-save obj) dont-save)
+ ;; FIXME: Why doesn's dlopen-or-lose on already loaded stuff work on
+ ;; Windows?
+ ;;
+ ;; Kovalenko 2010-11-24: It would work, but it does nothing
+ ;; useful on Windows: library reference count is increased
+ ;; after each LoadLibrary, making it harder to unload it, and
+ ;; that's all the effect. Also, equal pathnames on Windows
+ ;; always designate _exactly the same library image_; Unix
+ ;; tricks like deleting an open library and replacing it with
+ ;; another version just don't work here.
+ #!-win32
+ (dlopen-or-lose obj)
+ #!+win32
+ (unless old
+ (dlopen-or-lose obj))
+ (setf *shared-objects* (append (remove obj *shared-objects*)
+ (list obj)))
+ ;; FIXME: Why doesn't the linkage table work on Windows? (Or maybe it
+ ;; does and this can be just #!+linkage-table?) Note: remember to change
+ ;; FOREIGN-DEINIT as well then!
+ ;;
+ ;; Kovalenko 2010-11-24: I think so. Alien _data_ references
+ ;; are the only thing on win32 that is even slightly
+ ;; problematic. Handle function references in the same way as
+ ;; other linkage-table platforms is easy.
+ ;;
+ #!+linkage-table
+ (when (or old (undefined-foreign-symbols-p))
+ (update-linkage-table))))
+ pathname))
+
+(defun unload-shared-object (pathname)
+ #!+sb-doc
+ "Unloads the shared object loaded earlier using the designated PATHNAME with
+LOAD-SHARED-OBJECT, to the degree supported on the platform.
+
+Experimental."
+ (let ((pathname (pathname pathname)))
+ (sb!thread:with-mutex (*shared-objects-lock*)
+ (let ((old (find pathname *shared-objects*
+ :key #'shared-object-pathname
+ :test #'equal)))
+ (when old
+ #!-hpux (dlclose-or-lose old)
+ (setf *shared-objects* (remove old *shared-objects*))
+ #!+linkage-table
+ (update-linkage-table))))))
(defun try-reopen-shared-object (obj)
- (restart-case
- (let ((sap (dlopen-or-lose (shared-object-file obj))))
- (setf (shared-object-sap obj) sap)
- obj)
- (skip ()
- :report "Skip this shared object and continue. References to ~
- foreign symbols in this shared object will fail, ~
- causing potential corruption."
- *runtime-dlhandle*)))
+ (declare (type shared-object obj))
+ (tagbody :dlopen
+ (restart-case
+ (dlopen-or-lose obj)
+ (continue ()
+ :report "Skip this shared object and continue."
+ ;; By returning NIL the shared object is dropped from the list.
+ (setf (shared-object-handle obj) nil)
+ (return-from try-reopen-shared-object nil))
+ (retry ()
+ :report "Retry loading this shared object."
+ (go :dlopen))
+ (change-pathname ()
+ :report "Specify a different pathname to load the shared object from."
+ (tagbody :query
+ (format *query-io* "~&Enter pathname (evaluated):~%")
+ (force-output *query-io*)
+ (let ((pathname (ignore-errors (pathname (read *query-io*)))))
+ (unless (pathnamep pathname)
+ (format *query-io* "~&Error: invalid pathname.~%")
+ (go :query))
+ (setf (shared-object-pathname obj) pathname)
+ (setf (shared-object-namestring obj)
+ (native-namestring (translate-logical-pathname pathname)
+ :as-file t))))
+ (go :dlopen))))
+ obj)
;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
-;;; initialization.
+;;; initialization.
(defun reopen-shared-objects ()
;; Ensure that the runtime is open
- (setf *runtime-dlhandle* (dlopen-or-lose nil)
- *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
+ (setf *runtime-dlhandle* (dlopen-or-lose))
+ ;; Reopen stuff.
+ (setf *shared-objects*
+ (remove nil (mapcar #'try-reopen-shared-object *shared-objects*))))
;;; Close all dlopened libraries and clear out sap entries in
-;;; *SHARED-OBJECTS*.
+;;; *SHARED-OBJECTS*, and drop the ones with DONT-SAVE set.
(defun close-shared-objects ()
- (dolist (obj (reverse *shared-objects*))
- (dlclose (shared-object-sap obj))
- (setf (shared-object-sap obj) nil))
- (dlclose *runtime-dlhandle*)
- (setf *runtime-dlhandle* nil))
-
-(defun get-dynamic-foreign-symbol-address (symbol)
- (dlerror) ; clear old errors
- (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
- (err (dlerror)))
- (if (or (not (zerop result)) (not err))
- result
- (dolist (obj *shared-objects*)
- (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
- err (dlerror))
- (when (or (not (zerop result)) (not err))
- (return result))))))
+ (let (saved)
+ (dolist (obj (reverse *shared-objects*))
+ #!-hpux (dlclose-or-lose obj)
+ (unless (shared-object-dont-save obj)
+ (push obj saved)))
+ (setf *shared-objects* saved))
+ #!-hpux
+ (dlclose-or-lose))
+
+(let ((symbols (make-hash-table :test #'equal))
+ (undefineds (make-hash-table :test #'equal)))
+ (defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
+ "Returns the address of the foreign symbol as an integer. On linkage-table
+ports if the symbols isn't found a special guard address is returned instead,
+accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an
+error is immediately signalled if the symbol isn't found. The returned address
+is never in the linkage-table."
+ (declare (ignorable datap))
+ (let ((addr (find-dynamic-foreign-symbol-address symbol)))
+ (cond #!-linkage-table
+ ((not addr)
+ (error 'undefined-alien-error :name symbol))
+ #!+linkage-table
+ ((not addr)
+ (style-warn 'sb!kernel:undefined-alien-style-warning
+ :symbol symbol)
+ (setf (gethash symbol undefineds) t)
+ (remhash symbol symbols)
+ (if datap
+ undefined-alien-address
+ (foreign-symbol-address "undefined_alien_function")))
+ (addr
+ (setf (gethash symbol symbols) t)
+ (remhash symbol undefineds)
+ addr))))
+ (defun undefined-foreign-symbols-p ()
+ (plusp (hash-table-count undefineds)))
+ (defun dynamic-foreign-symbols-p ()
+ (plusp (hash-table-count symbols)))
+ (defun list-dynamic-foreign-symbols ()
+ (loop for symbol being each hash-key in symbols
+ collect symbol))
+ (defun list-undefined-foreign-symbols ()
+ (loop for symbol being each hash-key in undefineds
+ collect symbol)))
projects / sbcl.git / blobdiff