X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign-load.lisp;h=185d95849f6f3220414124350dc7e74acf327620;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=fae0fb4c76b1e03b69b75c447a347718c145af0c;hpb=4919f9971429d18fab618b9b49e164c6b57bea6f;p=sbcl.git diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index fae0fb4..185d958 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -11,124 +11,199 @@ (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." - "~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 (&optional (obj nil objp)) - (when objp - (dlclose-or-lose obj)) - (dlerror) ; clear errors - (let* ((file (when 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) *runtime-dlhandle*) - (setf *runtime-dlhandle* nil)) - (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A" - obj (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 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 old - (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) - (with-simple-restart (skip "~@") - (dlopen-or-lose obj) - obj)) + (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) - *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 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 ((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)))