* Add &key :DONT-SAVE to control interaction with SAVE-LISP-AND-DIE.
* Better documentation, including mention of LD_LIBRARY_PATH.
* Refactor the OAOOM mess between win32-foreign-load.lisp and
foreign-load.lisp: add unix-foreign-load.lisp, and move the shared
code to foreign-load.lisp.
* The "try another pathname" restart in TRY-RELOAD-SHARED-OBJECT
changed the pathname but did not reload. Fix that.
--eval toplevel arguments as SIMPLE-ERRORS, which caused restarts
associated with the original error to be lost. (thanks to Ariel
Badichi)
+ * enhancement: :DONT-SAVE keyword argument has been added to
+ LOAD-SHARED-OBJECT for controlling interaction with
+ SAVE-LISP-AND-DIE.
* bug fix: ADJUST-ARRAY on multidimensional arrays used bogusly give
them a fill pointer unless :DISPLACED-TO or :INITIAL-CONTENTS were
provided. (reported by Cedric St-Jean)
("src/code/load")
#!+linkage-table ("src/code/linkage-table" :not-host)
- #!+(and os-provides-dlopen (not win32)) ("src/code/foreign-load" :not-host)
+ #!+os-provides-dlopen ("src/code/foreign-load" :not-host)
+ #!+(and os-provides-dlopen (not win32)) ("src/code/unix-foreign-load" :not-host)
#!+(and os-provides-dlopen win32) ("src/code/win32-foreign-load" :not-host)
("src/code/foreign")
"~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))
+#!-win32
+(progn
+ (define-alien-variable undefined-alien-address unsigned-long)
+ (defvar *runtime-dlhandle*))
-(define-alien-routine dlclose int
- (handle system-area-pointer))
-
-(define-alien-routine dlerror c-string)
-
-(define-alien-routine
- #!-openbsd dlsym
- #!+openbsd ("os_dlsym" dlsym)
- system-area-pointer
- (handle system-area-pointer)
- (symbol c-string))
-
-(define-alien-variable undefined-alien-address unsigned-long)
-
-(defvar *runtime-dlhandle*)
(defvar *shared-objects*)
-(defstruct shared-object file sap)
-
-(defun dlopen-or-lose (&optional (obj nil objp))
- (when objp
- (dlclose-or-lose obj))
- (dlerror) ; clear errors
- (let* ((file (and obj (shared-object-file obj)))
- (sap (dlopen file (logior rtld-global rtld-now))))
- (aver (or (not objp) file))
- (when (zerop (sap-int sap))
- (if objp
- (setf (shared-object-sap obj) nil)
- (setf *runtime-dlhandle* nil))
- (error "Error opening ~:[runtime~;shared object ~:*~S~]:~% ~A."
- file (dlerror)))
- (when objp
- (setf (shared-object-sap obj) sap))
- sap))
-
-(defun dlclose-or-lose (&optional (obj nil objp))
- (dlerror)
- (let (dlerror)
- (cond ((and (not objp) *runtime-dlhandle*)
- (dlclose *runtime-dlhandle*)
- (setf dlerror (dlerror)
- *runtime-dlhandle* nil))
- ((and objp (shared-object-sap obj))
- (dlclose (shared-object-sap obj))
- (setf dlerror (dlerror)
- (shared-object-sap obj) nil)))
- (when dlerror
- (cerror "Ignore the error and continue anyway" "dlerror returned an error: ~S" dlerror))))
-
-(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.
-
-Reloading the same shared object will replace the old definitions; if
-a symbol was previously referenced thru the object and is not present
-in the reloaded version an error will be signalled. Sameness is
-determined using the library filename. Reloading may not work as
-expected if user or library-code has called dlopen on FILE.
-
-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 ((filename (or (unix-namestring file) file))
- (old nil))
+(defstruct shared-object pathname namestring handle dont-save)
+
+(defun load-shared-object (pathname &key dont-save)
+ "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 speficied 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 platoforms calling LOAD-SHARED-OBJECT again with an PATHNAME
+EQUAL to the designated pathname of a previous call will replace the old
+definitions; if a symbol was previously referenced thru 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*)
- (setf old (find filename *shared-objects* :key #'shared-object-file :test #'equal))
- (let* ((obj (or old (make-shared-object :file filename))))
+ (let* ((old (find pathname *shared-objects*
+ :key #'shared-object-pathname
+ :test #'equal))
+ (obj (or old (make-shared-object
+ :pathname pathname
+ :namestring (native-namestring 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?
+ #!-win32
(dlopen-or-lose obj)
+ #!+win32
+ (unless old
+ (dlopen-or-lose obj))
(setf *shared-objects* (append (remove obj *shared-objects*)
- (list obj)))))
- #!+linkage-table
- (when (or old (undefined-foreign-symbols-p))
- (update-linkage-table))
- (pathname filename)))
+ (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!
+ #!+(and linkage-table (not win32))
+ (when (or old (undefined-foreign-symbols-p))
+ (update-linkage-table))))
+ pathname))
(defun try-reopen-shared-object (obj)
(declare (type shared-object obj))
(dlopen-or-lose obj)
(continue ()
:report "Skip this shared object and continue."
- (setf (shared-object-sap obj) nil))
+ ;; 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))
- (load-other ()
- :report "Specify an alternate shared object file to load."
- (setf (shared-object-file obj)
- (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))
- (unix-namestring pathname)))))))
+ (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
+ (shared-object-namestring obj) (native-namestring pathname :as-file t))))
+ (go :dlopen))))
obj)
;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
;;; initialization.
(defun reopen-shared-objects ()
;; Ensure that the runtime is open
- (setf *runtime-dlhandle* (dlopen-or-lose)
- *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
+ #!-win32
+ (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 ()
- (mapc #'dlclose-or-lose (reverse *shared-objects*))
+ (let (saved)
+ (dolist (obj (reverse *shared-objects*))
+ (dlclose-or-lose obj)
+ (unless (shared-object-dont-save obj)
+ (push obj saved)))
+ (setf *shared-objects* saved))
+ #!-win32
(dlclose-or-lose))
-(defun find-dynamic-foreign-symbol-address (symbol)
- (dlerror) ; clear old errors
- (unless *runtime-dlhandle*
- (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
- ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
- ;; but on platforms where dlsym is simulated we use the mangled name.
- (let* ((extern (extern-alien-name symbol))
- (result (sap-int (dlsym *runtime-dlhandle* extern)))
- (err (dlerror)))
- (if (or (not (zerop result)) (not err))
- result
- (dolist (obj *shared-objects*)
- (let ((sap (shared-object-sap obj)))
- (when sap
- (setf result (sap-int (dlsym sap extern))
- err (dlerror))
- (when (or (not (zerop result)) (not err))
- (return result))))))))
-
(let ((symbols (make-hash-table :test #'equal))
(undefineds (make-hash-table :test #'equal)))
(defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
is never in the linkage-table."
(declare (ignorable datap))
(let ((addr (find-dynamic-foreign-symbol-address symbol)))
- (cond #!-linkage-table
+ (cond #!-(and linkage-table (not win32))
((not addr)
(error 'undefined-alien-error :name symbol))
- #!+linkage-table
+ #!+(and linkage-table (not win32))
((not addr)
(style-warn 'sb!kernel:undefined-alien-style-warning
:symbol symbol)
;;; Cleanups before saving a core
#-sb-xc-host
(defun foreign-deinit ()
- #!+(and os-provides-dlopen (not linkage-table))
+ #!+(and os-provides-dlopen (or (not linkage-table) win32))
(when (dynamic-foreign-symbols-p)
(warn "~@<Saving cores with alien definitions referring to non-static ~
foreign symbols is unsupported on this platform: references to ~
(in-package "SB!IMPL")
-(defvar *shared-object-lock*) ; initialized in foreign-load.lisp
-
(define-alien-routine arch-write-linkage-table-jmp void
(table-address system-area-pointer)
(real-address system-area-pointer))
This is reinitialized to reflect the working directory where the
saved core is loaded.
-Foreign objects loaded with SB-ALIEN:LOAD-SHARED-OBJECT are automatically
-reloaded on startup, but references to foreign symbols do not survive intact
-on all platforms: in this case a WARNING is signalled when saving the core. If
-no warning is signalled, then the foreign symbol references will remain
-intact. Platforms where this is currently the case are x86/FreeBSD, x86/Linux,
-x86/NetBSD, sparc/Linux, sparc/SunOS, and ppc/Darwin.
+SAVE-LISP-AND-DIE interacts with SB-ALIEN:LOAD-FOREIGN-OBJECT: see its
+documentation for details.
On threaded platforms only a single thread may remain running after
SB-EXT:*SAVE-HOOKS* have run. Applications using multiple threads can
--- /dev/null
+;;;; Loading shared object files, Unix specifics
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ALIEN")
+
+(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
+ #!-openbsd dlsym
+ #!+openbsd ("os_dlsym" dlsym)
+ system-area-pointer
+ (handle system-area-pointer)
+ (symbol c-string))
+
+(defun dlopen-or-lose (&optional (obj nil objp))
+ (when objp
+ (dlclose-or-lose obj))
+ (dlerror) ; clear errors
+ (let* ((namestring (and obj (shared-object-namestring obj)))
+ (sap (dlopen namestring (logior rtld-global rtld-now))))
+ (when (zerop (sap-int sap))
+ (if objp
+ (setf (shared-object-handle obj) nil)
+ (setf *runtime-dlhandle* nil))
+ (error "Error opening ~:[runtime~;shared object ~:*~S~]:~% ~A."
+ namestring (dlerror)))
+ (when objp
+ (setf (shared-object-handle obj) sap))
+ sap))
+
+(defun dlclose-or-lose (&optional (obj nil objp))
+ (dlerror)
+ (let (dlerror)
+ (cond ((and (not objp) *runtime-dlhandle*)
+ (dlclose *runtime-dlhandle*)
+ (setf dlerror (dlerror)
+ *runtime-dlhandle* nil))
+ ((and objp (shared-object-handle obj))
+ (dlclose (shared-object-handle obj))
+ (setf dlerror (dlerror)
+ (shared-object-handle obj) nil)))
+ (when dlerror
+ (cerror "Ignore the error and continue as if closing succeeded."
+ "dlerror() returned an error while trying to close ~
+ ~:[runtime~;shared object ~:*~S~]: ~S"
+ (when obj (shared-object-namestring obj))
+ dlerror))))
+
+(defun find-dynamic-foreign-symbol-address (symbol)
+ (dlerror) ; clear old errors
+ (unless *runtime-dlhandle*
+ (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
+ ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
+ ;; but on platforms where dlsym is simulated we use the mangled name.
+ (let* ((extern (extern-alien-name symbol))
+ (result (sap-int (dlsym *runtime-dlhandle* extern)))
+ (err (dlerror)))
+ (if (or (not (zerop result)) (not err))
+ result
+ (dolist (obj *shared-objects*)
+ (let ((sap (shared-object-handle obj)))
+ (when sap
+ (setf result (sap-int (dlsym sap extern))
+ err (dlerror))
+ (when (or (not (zerop result)) (not err))
+ (return result))))))))
+
+
-;;;; Loading shared object files
+;;;; Loading shared object files, Win32 specifics
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!ALIEN")
-;;; Used to serialize modifications to *linkage-info*,
-;;; *shared-objects* and the linkage-table proper. Calls thru
-;;; linkage-table are unaffected.
-(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."
- (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-type hinstance long)
(define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance
(define-alien-routine ("GetLastError@0" getlasterror) unsigned-int)
-(defvar *shared-objects*)
-
-(defstruct shared-object file handle)
-
(defun dlopen-or-lose (obj)
- (let* ((file (shared-object-file obj))
- (handle (loadlibrary file)))
- (aver file)
+ (let* ((namestring (shared-object-namestring obj))
+ (handle (loadlibrary namestring)))
+ (aver namestring)
(when (zerop handle)
(setf (shared-object-handle obj) nil)
(error "Error opening shared object ~S:~% ~A."
- file (getlasterror)))
+ namestring (getlasterror)))
(setf (shared-object-handle obj) handle)
handle))
(defun dlclose-or-lose (&optional (obj nil objp))
- (let (dlerror)
- (cond ((and objp (shared-object-handle obj))
- (setf dlerror (if (freelibrary (shared-object-handle obj))
- nil
- (getlasterror))
- (shared-object-handle obj) nil)))
- (when dlerror
- (cerror "Ignore the error and continue anyway" "dlerror returned an error: ~S" dlerror))))
-
-(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.
-
-Reloading the same shared object will replace the old definitions; if
-a symbol was previously referenced thru the object and is not present
-in the reloaded version an error will be signalled. Sameness is
-determined using the library filename. Reloading may not work as
-expected if user or library-code has called dlopen on FILE.
-
-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."
- ;; FIXME: 1. This is copy-paste from foreign-load.lisp.
- ;; FIXME: 2. Once windows gets threads, this is going to need a lock.
- ;; FIXME: 3. No linkage table on windows?
- (let* ((filename (or (unix-namestring file) file))
- (old (find filename *shared-objects* :key #'shared-object-file :test #'equal))
- (obj (or old (make-shared-object :file filename))))
- (unless old
- (dlopen-or-lose obj))
- (setf *shared-objects* (append (remove obj *shared-objects*)
- (list obj)))
- (pathname filename)))
-
-(defun try-reopen-shared-object (obj)
- (declare (type shared-object obj))
- (tagbody :dlopen
- (restart-case
- (dlopen-or-lose obj)
- (continue ()
- :report "Skip this shared object and continue."
- (setf (shared-object-handle obj) nil))
- (retry ()
- :report "Retry loading this shared object."
- (go :dlopen))
- (load-other ()
- :report "Specify an alternate shared object file to load."
- (setf (shared-object-file obj)
- (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))
- (unix-namestring pathname)))))))
- obj)
-
-;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
-;;; initialization.
-;;; Note that, so long as we don't have linkage-table, this is braindead.
-(defun reopen-shared-objects ()
- (setf *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
-
-;;; Close all dlopened libraries and clear out sap entries in
-;;; *SHARED-OBJECTS*.
-(defun close-shared-objects ()
- (mapc #'dlclose-or-lose (reverse *shared-objects*)))
+ (when (and objp (shared-object-handle obj))
+ (unless (freelibrary (shared-object-handle obj))
+ (cerror "Ignore the error and continue as if closing succeeded."
+ "FreeLibrary() caused an error while trying to close ~
+ shared object ~S: ~S"
+ (shared-object-namestring obj)
+ (getlasterror)))
+ (setf (shared-object-handle obj) nil)))
(defun find-dynamic-foreign-symbol-address (symbol)
;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
(when (not (zerop result))
(return result)))))))
-(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 ((not addr)
- (error 'undefined-alien-error :name symbol))
- (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)))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.21.14"
+"1.0.21.15"
projects / sbcl.git / commitdiff