From fe19212267bef96fedb712ebb43abc91631aea18 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 9 Oct 2008 20:48:24 +0000 Subject: [PATCH] 1.0.21.15: LOAD-SHARED-OBJECT :DONT-SAVE and related * 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. --- NEWS | 3 + build-order.lisp-expr | 3 +- src/code/foreign-load.lisp | 195 +++++++++++++++++--------------------- src/code/foreign.lisp | 2 +- src/code/linkage-table.lisp | 2 - src/code/save.lisp | 8 +- src/code/unix-foreign-load.lisp | 82 ++++++++++++++++ src/code/win32-foreign-load.lisp | 129 +++---------------------- version.lisp-expr | 2 +- 9 files changed, 190 insertions(+), 236 deletions(-) create mode 100644 src/code/unix-foreign-load.lisp diff --git a/NEWS b/NEWS index 3c084de..c79ccf8 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,9 @@ changes in sbcl-1.0.22 relative to 1.0.21: --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) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 79840f4..c44ad43 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -484,7 +484,8 @@ ("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") diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 7f7445d..7b7b92e 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -25,84 +25,68 @@ "~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)) @@ -111,55 +95,48 @@ SB-EXT:SAVE-LISP-AND-DIE for details." (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) @@ -170,10 +147,10 @@ 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 + (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) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index f6a2462..bd89cd8 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -107,7 +107,7 @@ if the symbol isn't found." ;;; 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 "~@