X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign-load.lisp;h=185d95849f6f3220414124350dc7e74acf327620;hb=0338d1fc97a74b8ff332821ea275120b9de951c1;hp=74ce213453fa9cc3f875acd537cc1c978ce3ccc6;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 74ce213..185d958 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -11,11 +11,9 @@ (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 *foreign-lock* - (sb!thread:make-mutex :name "foreign definition lock")) +;;; 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." @@ -27,80 +25,101 @@ "~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)) +(progn + (define-alien-variable undefined-alien-address unsigned) + (defvar *runtime-dlhandle*)) -(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)) - -(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." - (sb!thread:with-mutex (*foreign-lock*) - (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)))) - (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)))) +(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 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*) + (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) (declare (type shared-object obj)) @@ -109,55 +128,49 @@ 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) + (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. (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*))) + (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*)) + #!-hpux (dlclose-or-lose obj) + (unless (shared-object-dont-save obj) + (push obj saved))) + (setf *shared-objects* saved)) + #!-hpux (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) @@ -173,7 +186,8 @@ is never in the linkage-table." (error 'undefined-alien-error :name symbol)) #!+linkage-table ((not addr) - (style-warn "Undefined alien: ~S" symbol) + (style-warn 'sb!kernel:undefined-alien-style-warning + :symbol symbol) (setf (gethash symbol undefineds) t) (remhash symbol symbols) (if datap @@ -189,5 +203,7 @@ is never in the linkage-table." (plusp (hash-table-count symbols))) (defun list-dynamic-foreign-symbols () (loop for symbol being each hash-key in symbols - collect symbol))) - + collect symbol)) + (defun list-undefined-foreign-symbols () + (loop for symbol being each hash-key in undefineds + collect symbol)))