X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign-load.lisp;h=185d95849f6f3220414124350dc7e74acf327620;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=d678b0de7896a19acf28bcea93944752d50c8c99;hpb=1f7bb609de31bba1a85817496ecbde52a07edf14;p=sbcl.git diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index d678b0d..185d958 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -11,91 +11,199 @@ (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 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) - (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)))