src/code/win32-foreign-load.lisp

   1 ;;;; Loading shared object files, Win32 specifics
   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 (define-alien-type hinstance signed)
  15
  16 (define-alien-routine ("LoadLibraryA" loadlibrary) hinstance
  17   (file c-string))
  18
  19 (define-alien-routine ("FreeLibrary" freelibrary) int
  20   (handle hinstance))
  21
  22 (define-alien-routine ("GetProcAddress" getprocaddress) system-area-pointer
  23   (handle hinstance)
  24   (symbol c-string))
  25
  26 (define-alien-routine ("GetLastError" getlasterror) unsigned-int)
  27
  28 (define-alien-routine ("SetStdHandle" set-std-handle)
  29    void
  30  (id int)
  31  (handle int))
  32
  33 (sb!alien:define-alien-routine ("GetStdHandle" get-std-handle)
  34    sb!alien:int
  35  (id sb!alien:int))
  36
  37 (define-alien-routine ("GetModuleHandleW" get-module-handle)
  38     hinstance
  39   (name (c-string :external-format :ucs-2)))
  40
  41 (defvar *reset-stdio-on-dlopen* t)
  42
  43 (defconstant +stdio-handle+ -10)
  44
  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+)))
  50          (unwind-protect
  51               (progn
  52                 (set-std-handle +stdio-handle+ -1)
  53                 (loadlibrary namestring))
  54            (set-std-handle +stdio-handle+ stdio)))
  55        (loadlibrary namestring))))
  56
  57 (defun dlopen-or-lose (&optional obj)
  58   (if obj
  59       (let* ((namestring (shared-object-namestring obj))
  60              (handle (loadlibrary-without-stdio namestring)))
  61         (aver namestring)
  62         (when (zerop handle)
  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)
  67         handle)
  68       (extern-alien "runtime_module_handle" hinstance)))
  69
  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 ~
  75                shared object ~S: ~S"
  76               (shared-object-namestring obj)
  77               (getlasterror)))
  78     (setf (shared-object-handle obj) nil)))
  79
  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))
  92          (result nil))
  93     (dolist (handle
  94               (cons *runtime-dlhandle*
  95                     (mapcar #'shared-object-handle *shared-objects*)))
  96       (when handle
  97         (setf result (sap-int (getprocaddress handle extern)))
  98         (when (not (zerop result))
  99           (return result))))))
 100
 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
 113           collect
 114        (cons
 115          (sap-int (sap+ image-base (sap-ref-32 functions-sap offset)))
 116          (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))