X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-foreign-load.lisp;h=bb431f15dd568911c0f7c9006a2fe175fe9a418a;hb=fe19212267bef96fedb712ebb43abc91631aea18;hp=200552569493742ef906092ee2378a682500f626;hpb=b9519773faa7b3c98915eccb9cb1fd8a8270ee56;p=sbcl.git diff --git a/src/code/win32-foreign-load.lisp b/src/code/win32-foreign-load.lisp index 2005525..bb431f1 100644 --- a/src/code/win32-foreign-load.lisp +++ b/src/code/win32-foreign-load.lisp @@ -1,4 +1,4 @@ -;;;; Loading shared object files +;;;; Loading shared object files, Win32 specifics ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -11,22 +11,6 @@ (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 *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." - (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-type hinstance long) (define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance @@ -41,90 +25,26 @@ (define-alien-routine ("GetLastError@0" getlasterror) unsigned-int) -(defvar *shared-objects*) - -(defstruct shared-object file handle) - (defun dlopen-or-lose (obj) - (let* ((file (shared-object-file obj)) - (handle (loadlibrary file))) - (aver file) + (let* ((namestring (shared-object-namestring obj)) + (handle (loadlibrary namestring))) + (aver namestring) (when (zerop handle) (setf (shared-object-handle obj) nil) (error "Error opening shared object ~S:~% ~A." - file (getlasterror))) + namestring (getlasterror))) (setf (shared-object-handle obj) handle) handle)) (defun dlclose-or-lose (&optional (obj nil objp)) - (let (dlerror) - (cond ((and objp (shared-object-handle obj)) - (setf dlerror (if (freelibrary (shared-object-handle obj)) - nil - (getlasterror)) - (shared-object-handle 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." - ;; FIXME: 1. This is copy-paste from foreign-load.lisp. - ;; FIXME: 2. Once windows gets threads, this is going to need a lock. - ;; FIXME: 3. No linkage table on windows? - (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)))) - (unless old - (dlopen-or-lose obj)) - (setf *shared-objects* (append (remove obj *shared-objects*) - (list obj))) - (pathname filename))) - -(defun try-reopen-shared-object (obj) - (declare (type shared-object obj)) - (tagbody :dlopen - (restart-case - (dlopen-or-lose obj) - (continue () - :report "Skip this shared object and continue." - (setf (shared-object-handle obj) 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))))))) - obj) - -;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during -;;; initialization. -;;; Note that, so long as we don't have linkage-table, this is braindead. -(defun reopen-shared-objects () - (setf *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*))) - -;;; Close all dlopened libraries and clear out sap entries in -;;; *SHARED-OBJECTS*. -(defun close-shared-objects () - (mapc #'dlclose-or-lose (reverse *shared-objects*))) + (when (and objp (shared-object-handle obj)) + (unless (freelibrary (shared-object-handle obj)) + (cerror "Ignore the error and continue as if closing succeeded." + "FreeLibrary() caused an error while trying to close ~ + shared object ~S: ~S" + (shared-object-namestring obj) + (getlasterror))) + (setf (shared-object-handle obj) nil))) (defun find-dynamic-foreign-symbol-address (symbol) ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op, @@ -146,27 +66,4 @@ SB-EXT:SAVE-LISP-AND-DIE for details." (when (not (zerop result)) (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 ((not addr) - (error 'undefined-alien-error :name symbol)) - (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)))