X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-foreign-load.lisp;h=0bcf0cb95a729b66cf2265fe565bc3183723deb2;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=a0bfe7aafc22b10f8d691eac9e3052509a19d70c;hpb=ffb139d147687e7efa2754801a8bf60057579b96;p=sbcl.git diff --git a/src/code/win32-foreign-load.lisp b/src/code/win32-foreign-load.lisp index a0bfe7a..0bcf0cb 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,118 +11,71 @@ (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-alien-type hinstance signed) -(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 +(define-alien-routine ("LoadLibraryA" loadlibrary) hinstance (file c-string)) -(define-alien-routine ("FreeLibrary@4" freelibrary) int +(define-alien-routine ("FreeLibrary" freelibrary) int (handle hinstance)) -(define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer +(define-alien-routine ("GetProcAddress" 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-handle obj) nil) - (error "Error opening shared object ~S:~% ~A." - file (getlasterror))) - (setf (shared-object-handle obj) handle) - handle)) +(define-alien-routine ("GetLastError" getlasterror) unsigned-int) + +(define-alien-routine ("SetStdHandle" set-std-handle) + void + (id int) + (handle int)) + +(sb!alien:define-alien-routine ("GetStdHandle" get-std-handle) + sb!alien:int + (id sb!alien:int)) + +(define-alien-routine ("GetModuleHandleW" get-module-handle) + hinstance + (name (c-string :external-format :ucs-2))) + +(defvar *reset-stdio-on-dlopen* t) + +(defconstant +stdio-handle+ -10) + +(defun loadlibrary-without-stdio (namestring) + (flet ((loadlibrary (namestring) + (loadlibrary namestring))) + (if *reset-stdio-on-dlopen* + (let ((stdio (get-std-handle +stdio-handle+))) + (unwind-protect + (progn + (set-std-handle +stdio-handle+ -1) + (loadlibrary namestring)) + (set-std-handle +stdio-handle+ stdio))) + (loadlibrary namestring)))) + +(defun dlopen-or-lose (&optional obj) + (if obj + (let* ((namestring (shared-object-namestring obj)) + (handle (loadlibrary-without-stdio namestring))) + (aver namestring) + (when (zerop handle) + (setf (shared-object-handle obj) nil) + (error "Error opening shared object ~S:~% ~A." + namestring (getlasterror))) + (setf (shared-object-handle obj) handle) + handle) + (extern-alien "runtime_module_handle" hinstance))) (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*))) + (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, @@ -137,34 +90,27 @@ SB-EXT:SAVE-LISP-AND-DIE for details." ;; 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))) - + (dolist (handle + (cons *runtime-dlhandle* + (mapcar #'shared-object-handle *shared-objects*))) + (when handle + (setf result (sap-int (getprocaddress handle extern))) + (when (not (zerop result)) + (return result)))))) + +(defun runtime-exported-symbols () + ;; TODO: reimplement for x86-64. Not so hard. + (let* ((image-base (extern-alien "runtime_module_handle" system-area-pointer)) + (pe-base (sap+ image-base (sap-ref-32 image-base 60))) + (export-directory (sap+ pe-base (- #!+x86 248 #!+x86-64 264 (* 16 8)))) + (export-data (sap+ image-base (sap-ref-32 export-directory 0))) + (n-functions (sap-ref-32 export-data 20)) + (n-names (sap-ref-32 export-data 24)) + (functions-sap (sap+ image-base (sap-ref-32 export-data 28))) + (names-sap (sap+ image-base (sap-ref-32 export-data 32)))) + (loop repeat (min n-functions n-names) + for offset from 0 by #.sb!vm::n-word-bytes + collect + (cons + (sap-int (sap+ image-base (sap-ref-32 functions-sap offset))) + (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))