src/code/foreign.lisp

   1 ;;;; support for dynamically loading foreign object files and
   2 ;;;; resolving symbols therein
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.)
  14
  15 ;;; On any OS where we don't support foreign object file loading, any
  16 ;;; query of a foreign symbol value is answered with "no definition
  17 ;;; known", i.e. NIL.
  18 #-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
  19 (defun get-dynamic-foreign-symbol-address (symbol)
  20   (declare (type simple-string symbol) (ignore symbol))
  21   nil)
  22
  23 ;;; dlsym()-based implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
  24 ;;; and functions (e.g. LOAD-FOREIGN) which affect it.  This should
  25 ;;; work on any ELF system with dlopen(3) and dlsym(3)
  26 ;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern
  27 ;;; enough to have a fairly well working dlopen/dlsym implementation.
  28 (macrolet ((define-unsupported-fun (fun-name &optional (error-message "unsupported on this system"))
  29                `(defun ,fun-name (&rest rest)
  30                  ,error-message
  31                  (declare (ignore rest))
  32                  (error 'unsupported-operator :name ',fun-name))))
  33   #-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
  34   (define-unsupported-fun load-shared-object)
  35   #+(or linux sunos FreeBSD OpenBSD NetBSD darwin)
  36   (progn
  37
  38     (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13.")
  39     (define-unsupported-fun load-1-foreign "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT.")
  40
  41 ;;; a list of handles returned from dlopen(3) (or possibly some
  42 ;;; bogus value temporarily during initialization)
  43     (defvar *handles-from-dlopen* nil)
  44
  45 ;;; Dynamically loaded stuff isn't there upon restoring from a save.
  46 ;;; Clearing the variable this way was originally done primarily for
  47 ;;; Irix, which resolves tzname at runtime, resulting in
  48 ;;; *HANDLES-FROM-DLOPEN* (which was then called *TABLES-FROM-DLOPEN*)
  49 ;;; being set in the saved core image, resulting in havoc upon
  50 ;;; restart; but it seems harmless and tidy for other OSes too.
  51 ;;;
  52 ;;; Of course, it can be inconvenient that dynamically loaded stuff
  53 ;;; goes away when we save and restore. However,
  54 ;;;  (1) trying to avoid it by system programming here could open a
  55 ;;;      huge can of worms, since e.g. now we would need to worry about
  56 ;;;      libraries possibly being in different locations (file locations
  57 ;;;      or memory locations) at restore time than at save time; and
  58 ;;;  (2) by the time the application programmer is so deep into the
  59 ;;;      the use of hard core extension features as to be doing
  60 ;;;      dynamic loading of foreign files and saving/restoring cores,
  61 ;;;      he probably has the sophistication to write his own after-save
  62 ;;;      code to reload the libraries without much difficulty.
  63
  64 ;;; dan 2001.05.10 suspects that objection (1) is bogus for
  65 ;;; dlsym()-enabled systems
  66
  67     (push (lambda () (setq *handles-from-dlopen* nil))
  68           *after-save-initializations*)
  69
  70     (define-alien-routine dlopen system-area-pointer
  71       (file c-string) (mode int))
  72
  73     (define-alien-routine dlsym system-area-pointer
  74       (lib system-area-pointer) (name c-string))
  75
  76     (define-alien-routine dlerror c-string)
  77
  78 ;;; Ensure that we've opened our own binary so we can dynamically resolve
  79 ;;; symbols in the C runtime.
  80 ;;;
  81 ;;; Old comment: This used to happen only in
  82 ;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were
  83 ;;; dlopen()ed already, but that didn't work if something was
  84 ;;; dlopen()ed before any problem global vars were used.  So now we do
  85 ;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as
  86 ;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
  87 ;;;
  88 ;;; FIXME: It would work just as well to do it once at startup, actually.
  89 ;;; Then at least we know it's done.    -dan 2001.05.10
  90     (defun ensure-runtime-symbol-table-opened ()
  91       (unless *handles-from-dlopen*
  92         ;; Prevent recursive call if dlopen() isn't defined.
  93         (setf *handles-from-dlopen* (int-sap 0))
  94         (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy)))
  95         (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*)))
  96           (error "can't open our own binary's symbol table: ~S" (dlerror)))))
  97
  98     (defun load-shared-object (file)
  99       "Load a shared library/dynamic shared object file/general
 100   dlopenable alien container.
 101
 102   To use LOAD-SHARED-OBJECT, at the Unix command line do this:
 103     echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
 104     make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
 105     ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
 106   then in SBCL do this:
 107     (LOAD-SHARED-OBJECT \"/tmp/ffi-test.so\")
 108     (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
 109   Now running (SUMMISH 10 20) should return 31.
 110 "
 111       (ensure-runtime-symbol-table-opened)
 112       ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
 113       ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
 114       ;; not all symbols are defined.
 115       (let* ((real-file (or (unix-namestring file) file))
 116              (sap (dlopen real-file (logior rtld-now rtld-global))))
 117         (if (zerop (sap-int sap))
 118             (error "can't open object ~S: ~S" real-file (dlerror))
 119             (pushnew sap *handles-from-dlopen* :test #'sap=)))
 120       (values))
 121
 122     (defun get-dynamic-foreign-symbol-address (symbol)
 123       (ensure-runtime-symbol-table-opened)
 124       ;; Find the symbol in any of the loaded object files. Search in
 125       ;; reverse order of loading, so that later loadings take precedence.
 126       ;;
 127       ;; FIXME: The way that we use PUSHNEW SAP in LOAD-SHARED-OBJECT means
 128       ;; that the list isn't guaranteed to be in reverse order of loading,
 129       ;; at least not if a file is loaded more than once. Is this the
 130       ;; right thing? (In what cases does it matter?)
 131       (dolist (handle (reverse *handles-from-dlopen*))
 132         ;; KLUDGE: We implicitly exclude the possibility that the variable
 133         ;; could actually be NULL, but the man page for dlsym(3)
 134         ;; recommends doing a more careful test. -- WHN 20000825
 135         (let ((possible-result (sap-int (dlsym handle symbol))))
 136           (unless (zerop possible-result)
 137             (return possible-result)))))
 138
 139     #+os-provides-dladdr
 140     ;;; Override the early definition in target-load.lisp
 141     (defun foreign-symbol-in-address (sap)
 142       (let ((addr (sap-int sap)))
 143         (with-alien ((info
 144                       (struct dl-info
 145                               (filename c-string)
 146                               (base unsigned)
 147                               (symbol c-string)
 148                               (symbol-address unsigned)))
 149                      (dladdr
 150                       (function unsigned
 151                                 unsigned (* (struct dl-info)))
 152                       :extern "dladdr"))
 153           (let ((err (alien-funcall dladdr addr (addr info))))
 154             (if (zerop err)
 155                 nil
 156                 (values (slot info 'symbol)
 157                         (slot info 'filename)
 158                         addr
 159                         (- addr (slot info 'symbol-address))))))))
 160
 161     ))                                  ; PROGN, MACROLET