src/code/win32-foreign-load.lisp

   1 ;;;; Loading shared object files
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!ALIEN")
  13
  14 ;;; Used to serialize modifications to *linkage-info*,
  15 ;;; *shared-objects* and the linkage-table proper. Calls thru
  16 ;;; linkage-table are unaffected.
  17 (defvar *shared-objects-lock*
  18   (sb!thread:make-mutex :name "shared object list lock"))
  19
  20 (define-unsupported-fun load-foreign
  21     "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  22   "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  23   (load-foreign))
  24
  25 (define-unsupported-fun load-1-foreign
  26     "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  27   "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  28   (load-1-foreign))
  29
  30 (define-alien-type hinstance long)
  31
  32 (define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance
  33   (file c-string))
  34
  35 (define-alien-routine ("FreeLibrary@4" freelibrary) int
  36   (handle hinstance))
  37
  38 (define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer
  39   (handle hinstance)
  40   (symbol c-string))
  41
  42 (define-alien-routine ("GetLastError@0" getlasterror) unsigned-int)
  43
  44 (defvar *shared-objects*)
  45
  46 (defstruct shared-object file handle)
  47
  48 (defun dlopen-or-lose (obj)
  49   (let* ((file (shared-object-file obj))
  50          (handle (loadlibrary file)))
  51     (aver file)
  52     (when (zerop handle)
  53       (setf (shared-object-handle obj) nil)
  54       (error "Error opening shared object ~S:~%  ~A."
  55              file (getlasterror)))
  56     (setf (shared-object-handle obj) handle)
  57     handle))
  58
  59 (defun dlclose-or-lose (&optional (obj nil objp))
  60   (let (dlerror)
  61     (cond ((and objp (shared-object-handle obj))
  62            (setf dlerror (if (freelibrary (shared-object-handle obj))
  63                              nil
  64                              (getlasterror))
  65                  (shared-object-handle obj) nil)))
  66     (when dlerror
  67       (cerror "Ignore the error and continue anyway" "dlerror returned an error: ~S" dlerror))))
  68
  69 (defun load-shared-object (file)
  70   "Load a shared library/dynamic shared object file/general dlopenable
  71 alien container, such as a .so on an ELF platform.
  72
  73 Reloading the same shared object will replace the old definitions; if
  74 a symbol was previously referenced thru the object and is not present
  75 in the reloaded version an error will be signalled. Sameness is
  76 determined using the library filename. Reloading may not work as
  77 expected if user or library-code has called dlopen on FILE.
  78
  79 References to foreign symbols in loaded shared objects do not survive
  80 intact through SB-EXT:SAVE-LISP-AND-DIE on all platforms. See
  81 SB-EXT:SAVE-LISP-AND-DIE for details."
  82   ;; FIXME: 1. This is copy-paste from foreign-load.lisp.
  83   ;; FIXME: 2. Once windows gets threads, this is going to need a lock.
  84   ;; FIXME: 3. No linkage table on windows?
  85   (let* ((filename (or (unix-namestring file) file))
  86          (old (find filename *shared-objects* :key #'shared-object-file :test #'equal))
  87          (obj (or old (make-shared-object :file filename))))
  88     (unless old
  89       (dlopen-or-lose obj))
  90     (setf *shared-objects* (append (remove obj *shared-objects*)
  91                                    (list obj)))
  92     (pathname filename)))
  93
  94 (defun try-reopen-shared-object (obj)
  95   (declare (type shared-object obj))
  96   (tagbody :dlopen
  97      (restart-case
  98          (dlopen-or-lose obj)
  99        (continue ()
 100          :report "Skip this shared object and continue."
 101          (setf (shared-object-handle obj) nil))
 102        (retry ()
 103          :report "Retry loading this shared object."
 104          (go :dlopen))
 105        (load-other ()
 106          :report "Specify an alternate shared object file to load."
 107          (setf (shared-object-file obj)
 108                (tagbody :query
 109                   (format *query-io* "~&Enter pathname (evaluated):~%")
 110                   (force-output *query-io*)
 111                   (let ((pathname (ignore-errors (pathname (read *query-io*)))))
 112                     (unless (pathnamep pathname)
 113                       (format *query-io* "~&Error: invalid pathname.~%")
 114                       (go :query))
 115                     (unix-namestring pathname)))))))
 116   obj)
 117
 118 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 119 ;;; initialization.
 120 ;;; Note that, so long as we don't have linkage-table, this is braindead.
 121 (defun reopen-shared-objects ()
 122   (setf *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
 123
 124 ;;; Close all dlopened libraries and clear out sap entries in
 125 ;;; *SHARED-OBJECTS*.
 126 (defun close-shared-objects ()
 127   (mapc #'dlclose-or-lose (reverse *shared-objects*)))
 128
 129 (defun find-dynamic-foreign-symbol-address (symbol)
 130   ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
 131   ;; but on platforms where dlsym is simulated we use the mangled name.
 132   ;; Win32 is a special case. It needs EXTERN-ALIEN-NAME to mangle the
 133   ;; name for static linkage, but also needs unmangled symbols for
 134   ;; GetProcAddress(). So we coerce to base-string instead.
 135   ;; Oh, and we assume that all runtime symbols are static-linked.
 136   ;; No *runtime-dlhandle* for us.
 137   ;; Also, GetProcAddress doesn't call SetLastError(0) on success,
 138   ;; and GetLastError() doesn't either. For now, we assume that
 139   ;; GetProcAddress() won't return NULL on success.
 140   (let* ((extern (coerce symbol 'base-string))
 141          (result nil))
 142     (dolist (obj *shared-objects*)
 143       (let ((handle (shared-object-handle obj)))
 144         (when handle
 145           (setf result (sap-int (getprocaddress handle extern)))
 146           (when (not (zerop result))
 147             (return result)))))))
 148
 149 (let ((symbols (make-hash-table :test #'equal))
 150       (undefineds (make-hash-table :test #'equal)))
 151   (defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
 152     "Returns the address of the foreign symbol as an integer. On linkage-table
 153 ports if the symbols isn't found a special guard address is returned instead,
 154 accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an
 155 error is immediately signalled if the symbol isn't found. The returned address
 156 is never in the linkage-table."
 157     (declare (ignorable datap))
 158     (let ((addr (find-dynamic-foreign-symbol-address symbol)))
 159       (cond  ((not addr)
 160               (error 'undefined-alien-error :name symbol))
 161              (addr
 162               (setf (gethash symbol symbols) t)
 163               (remhash symbol undefineds)
 164               addr))))
 165   (defun undefined-foreign-symbols-p ()
 166     (plusp (hash-table-count undefineds)))
 167   (defun dynamic-foreign-symbols-p ()
 168     (plusp (hash-table-count symbols)))
 169   (defun list-dynamic-foreign-symbols ()
 170     (loop for symbol being each hash-key in symbols
 171          collect symbol)))
 172