From: Christophe Rhodes Date: Wed, 11 Jan 2006 14:28:35 +0000 (+0000) Subject: 0.9.8.34: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=48ec282d877900caf5ea4ab42e9d87e566ce6b43;p=sbcl.git 0.9.8.34: Merge patch from nyef for load-shared-object on win32. ... there's a scary amount of duplication between win32-foreign-load and foreign-load; hope some gardening takes place at some point. ... attempt to make make-config.sh put the relevant target features in place. --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 627a884..dd675e7 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -464,7 +464,8 @@ ("src/code/load") #!+linkage-table ("src/code/linkage-table" :not-host) - #!+os-provides-dlopen ("src/code/foreign-load" :not-host) + #!+(and os-provides-dlopen (not win32)) ("src/code/foreign-load" :not-host) + #!+(and os-provides-dlopen win32) ("src/code/win32-foreign-load" :not-host) ("src/code/foreign") ("src/code/fop") ; needs macros from code/load.lisp diff --git a/make-config.sh b/make-config.sh index 128cf33..9210260 100644 --- a/make-config.sh +++ b/make-config.sh @@ -257,6 +257,11 @@ if [ "$sbcl_arch" = "x86" ]; then if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ]; then printf ' :linkage-table' >> $ltf fi + if [ "$sbcl_os" = "win32" ]; then + # of course it doesn't provide dlopen, but there is + # roughly-equivalent magic nevertheless. + printf ' :os-provides-dlopen' >> $ltf + fi elif [ "$sbcl_arch" = "x86-64" ]; then printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 49994d6..4e10afe 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -151,9 +151,10 @@ if the symbol isn't found." (defun !foreign-cold-init () (dolist (symbol *!initial-foreign-symbols*) (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))) + #!+(and os-provides-dlopen (not win32)) + (setf *runtime-dlhandle* (dlopen-or-lose)) #!+os-provides-dlopen - (setf *runtime-dlhandle* (dlopen-or-lose) - *shared-objects* nil)) + (setf *shared-objects* nil)) #!-os-provides-dlopen (define-unsupported-fun load-shared-object) diff --git a/src/code/win32-foreign-load.lisp b/src/code/win32-foreign-load.lisp new file mode 100644 index 0000000..5413825 --- /dev/null +++ b/src/code/win32-foreign-load.lisp @@ -0,0 +1,170 @@ +;;;; Loading shared object files + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(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")) + +(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 + (file c-string)) + +(define-alien-routine ("FreeLibrary@4" freelibrary) int + (handle hinstance)) + +(define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer + (handle hinstance) + (symbol c-string)) + +(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) + (when (zerop handle) + (setf (shared-object-sap obj) nil) + (error "Error opening shared object ~S:~% ~A." + file (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." + (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)))) + (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*))) + +(defun find-dynamic-foreign-symbol-address (symbol) + ;; 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. + ;; Win32 is a special case. It needs EXTERN-ALIEN-NAME to mangle the + ;; name for static linkage, but also needs unmangled symbols for + ;; GetProcAddress(). So we coerce to base-string instead. + ;; Oh, and we assume that all runtime symbols are static-linked. + ;; No *runtime-dlhandle* for us. + ;; Also, GetProcAddress doesn't call SetLastError(0) on success, + ;; and GetLastError() doesn't either. For now, we assume that + ;; GetProcAddress() won't return NULL on success. + (let* ((extern (coerce symbol 'base-string)) + (result nil)) + (dolist (obj *shared-objects*) + (let ((handle (shared-object-handle obj))) + (when handle + (setf result (sap-int (getprocaddress handle extern))) + (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))) + diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 9e41866..0f2cd29 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -620,6 +620,7 @@ void scratch(void) dup(0); LoadLibrary(0); GetProcAddress(0, 0); + FreeLibrary(0); mkdir(0); isatty(0); access(0,0); diff --git a/version.lisp-expr b/version.lisp-expr index 84e08c1..542b165 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.8.33" +"0.9.8.34"