1 ;;;; Loading shared object files, Win32 specifics
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!ALIEN")
14 (define-alien-type hinstance signed)
16 (define-alien-routine ("LoadLibraryA" loadlibrary) hinstance
19 (define-alien-routine ("FreeLibrary" freelibrary) int
22 (define-alien-routine ("GetProcAddress" getprocaddress) system-area-pointer
26 (define-alien-routine ("GetLastError" getlasterror) unsigned-int)
28 (define-alien-routine ("SetStdHandle" set-std-handle)
33 (sb!alien:define-alien-routine ("GetStdHandle" get-std-handle)
37 (define-alien-routine ("GetModuleHandleW" get-module-handle)
39 (name (c-string :external-format :ucs-2)))
41 (defvar *reset-stdio-on-dlopen* t)
43 (defconstant +stdio-handle+ -10)
45 (defun loadlibrary-without-stdio (namestring)
46 (flet ((loadlibrary (namestring)
47 (loadlibrary namestring)))
48 (if *reset-stdio-on-dlopen*
49 (let ((stdio (get-std-handle +stdio-handle+)))
52 (set-std-handle +stdio-handle+ -1)
53 (loadlibrary namestring))
54 (set-std-handle +stdio-handle+ stdio)))
55 (loadlibrary namestring))))
57 (defun dlopen-or-lose (&optional obj)
59 (let* ((namestring (shared-object-namestring obj))
60 (handle (loadlibrary-without-stdio namestring)))
63 (setf (shared-object-handle obj) nil)
64 (error "Error opening shared object ~S:~% ~A."
65 namestring (getlasterror)))
66 (setf (shared-object-handle obj) handle)
68 (extern-alien "runtime_module_handle" hinstance)))
70 (defun dlclose-or-lose (&optional (obj nil objp))
71 (when (and objp (shared-object-handle obj))
72 (unless (freelibrary (shared-object-handle obj))
73 (cerror "Ignore the error and continue as if closing succeeded."
74 "FreeLibrary() caused an error while trying to close ~
76 (shared-object-namestring obj)
78 (setf (shared-object-handle obj) nil)))
80 (defun find-dynamic-foreign-symbol-address (symbol)
81 ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
82 ;; but on platforms where dlsym is simulated we use the mangled name.
83 ;; Win32 is a special case. It needs EXTERN-ALIEN-NAME to mangle the
84 ;; name for static linkage, but also needs unmangled symbols for
85 ;; GetProcAddress(). So we coerce to base-string instead.
86 ;; Oh, and we assume that all runtime symbols are static-linked.
87 ;; No *runtime-dlhandle* for us.
88 ;; Also, GetProcAddress doesn't call SetLastError(0) on success,
89 ;; and GetLastError() doesn't either. For now, we assume that
90 ;; GetProcAddress() won't return NULL on success.
91 (let* ((extern (coerce symbol 'base-string))
94 (cons *runtime-dlhandle*
95 (mapcar #'shared-object-handle *shared-objects*)))
97 (setf result (sap-int (getprocaddress handle extern)))
98 (when (not (zerop result))
101 (defun runtime-exported-symbols ()
102 ;; TODO: reimplement for x86-64. Not so hard.
103 (let* ((image-base (extern-alien "runtime_module_handle" system-area-pointer))
104 (pe-base (sap+ image-base (sap-ref-32 image-base 60)))
105 (export-directory (sap+ pe-base (- #!+x86 248 #!+x86-64 264 (* 16 8))))
106 (export-data (sap+ image-base (sap-ref-32 export-directory 0)))
107 (n-functions (sap-ref-32 export-data 20))
108 (n-names (sap-ref-32 export-data 24))
109 (functions-sap (sap+ image-base (sap-ref-32 export-data 28)))
110 (names-sap (sap+ image-base (sap-ref-32 export-data 32))))
111 (loop repeat (min n-functions n-names)
112 for offset from 0 by #.sb!vm::n-word-bytes
115 (sap-int (sap+ image-base (sap-ref-32 functions-sap offset)))
116 (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))