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 ("SetStdHandle" set-std-handle)
  27    void
  28  (id int)
  29  (handle int))
  30
  31 (sb!alien:define-alien-routine ("GetStdHandle" get-std-handle)
  32    sb!alien:int
  33  (id sb!alien:int))
  34
  35 (define-alien-routine ("GetModuleHandleW" get-module-handle)
  36     hinstance
  37   (name (c-string :external-format :ucs-2)))
  38
  39 (defvar *reset-stdio-on-dlopen* t)
  40
  41 (defconstant +stdio-handle+ -10)
  42
  43 (defun loadlibrary-without-stdio (namestring)
  44   (flet ((loadlibrary (namestring)
  45            (loadlibrary namestring)))
  46    (if *reset-stdio-on-dlopen*
  47        (let ((stdio (get-std-handle +stdio-handle+)))
  48          (unwind-protect
  49               (progn
  50                 (set-std-handle +stdio-handle+ -1)
  51                 (loadlibrary namestring))
  52            (set-std-handle +stdio-handle+ stdio)))
  53        (loadlibrary namestring))))
  54
  55 (defun dlopen-or-lose (&optional obj)
  56   (if obj
  57       (let* ((namestring (shared-object-namestring obj))
  58              (handle (loadlibrary-without-stdio namestring)))
  59         (aver namestring)
  60         (when (zerop handle)
  61           (setf (shared-object-handle obj) nil)
  62           (error "Error opening shared object ~S:~% ~A"
  63                  namestring (sb!win32:format-system-message (sb!win32:get-last-error))))
  64         (setf (shared-object-handle obj) handle)
  65         handle)
  66       (extern-alien "runtime_module_handle" hinstance)))
  67
  68 (defun dlclose-or-lose (&optional (obj nil objp))
  69   (when (and objp (shared-object-handle obj))
  70     (unless (freelibrary (shared-object-handle obj))
  71       (cerror "Ignore the error and continue as if closing succeeded."
  72               "FreeLibrary() caused an error while trying to close ~
  73                shared object ~S:~% ~A"
  74               (shared-object-namestring obj)
  75               (sb!win32:format-system-message (sb!win32:get-last-error))))
  76     (setf (shared-object-handle obj) nil)))
  77
  78 (defun find-dynamic-foreign-symbol-address (symbol)
  79   ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
  80   ;; but on platforms where dlsym is simulated we use the mangled name.
  81   ;; Win32 is a special case. It needs EXTERN-ALIEN-NAME to mangle the
  82   ;; name for static linkage, but also needs unmangled symbols for
  83   ;; GetProcAddress(). So we coerce to base-string instead.
  84   ;; Oh, and we assume that all runtime symbols are static-linked.
  85   ;; No *runtime-dlhandle* for us.
  86   ;; Also, GetProcAddress doesn't call SetLastError(0) on success,
  87   ;; and GetLastError() doesn't either. For now, we assume that
  88   ;; GetProcAddress() won't return NULL on success.
  89   (let* ((extern (coerce symbol 'base-string))
  90          (result nil))
  91     (dolist (handle
  92               (cons *runtime-dlhandle*
  93                     (mapcar #'shared-object-handle *shared-objects*)))
  94       (when handle
  95         (setf result (sap-int (getprocaddress handle extern)))
  96         (when (not (zerop result))
  97           (return result))))))
  98
  99 (defun runtime-exported-symbols ()
 100   ;; TODO: reimplement for x86-64. Not so hard.
 101   (let* ((image-base (extern-alien "runtime_module_handle" system-area-pointer))
 102          (pe-base (sap+ image-base (sap-ref-32 image-base 60)))
 103          (export-directory (sap+ pe-base (- #!+x86 248 #!+x86-64 264 (* 16 8))))
 104          (export-data (sap+ image-base (sap-ref-32 export-directory 0)))
 105          (n-functions (sap-ref-32 export-data 20))
 106          (n-names (sap-ref-32 export-data 24))
 107          (functions-sap (sap+ image-base (sap-ref-32 export-data 28)))
 108          (names-sap (sap+ image-base (sap-ref-32 export-data 32))))
 109     (loop repeat (min n-functions n-names)
 110           for offset from 0 by #.sb!vm::n-word-bytes
 111           collect
 112        (cons
 113          (sap-int (sap+ image-base (sap-ref-32 functions-sap offset)))
 114          (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))