X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign-load.lisp;h=de6bbd4e05df235d72512f958a184d8b5eb9c479;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=8986c9704e5c855de8e8a18690ef5389187303f5;hpb=568214ddf4c8ecc881caec98e20848d017974ec0;p=sbcl.git diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 8986c97..de6bbd4 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -11,167 +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)) - -(define-alien-variable undefined-alien-address unsigned-long) +(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 (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)) - (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 specified 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 platforms calling LOAD-SHARED-OBJECT again with a PATHNAME +EQUAL to the designated pathname of a previous call will replace the old +definitions; if a symbol was previously referenced through 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)) (tagbody :dlopen (restart-case - (dlopen-or-lose obj) + (dlopen-or-lose obj) (continue () - :report "Skip this shared object and continue." - (setf (shared-object-sap obj) nil)) + :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)) - (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))))))) + :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)) -(let ((symbols ()) - (undefineds ())) - (defun get-dynamic-foreign-symbol-address (symbol &optional datap) - (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)) - (addr (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)))))))) - (cond ((not addr) - (style-warn "Undefined alien: ~S" symbol) - (pushnew symbol undefineds :test #'equal) - (remove symbol symbols :test #'equal) - (if datap - undefined-alien-address - (foreign-symbol-address-as-integer - "undefined_alien_function"))) +(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 - (pushnew symbol symbols :test #'equal) - (remove symbol undefineds :test #'equal) + (setf (gethash symbol symbols) t) + (remhash symbol undefineds) addr)))) - (defun dynamic-foreign-symbols () - symbols) - (defun undefined-foreign-symbols () - undefineds)) + (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)))