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     (sb-alien:define-alien-routine dlopen system-area-pointer
  71       (file sb-alien:c-string) (mode sb-alien:int))
  72     (sb-alien:define-alien-routine dlsym system-area-pointer
  73       (lib system-area-pointer)
  74       (name sb-alien:c-string))
  75     (sb-alien:define-alien-routine dlerror sb-alien:c-string)
  76
  77 ;;; Ensure that we've opened our own binary so we can dynamically resolve
  78 ;;; symbols in the C runtime.
  79 ;;;
  80 ;;; Old comment: This used to happen only in
  81 ;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were
  82 ;;; dlopen()ed already, but that didn't work if something was
  83 ;;; dlopen()ed before any problem global vars were used.  So now we do
  84 ;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as
  85 ;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
  86 ;;;
  87 ;;; FIXME: It would work just as well to do it once at startup, actually.
  88 ;;; Then at least we know it's done.    -dan 2001.05.10
  89     (defun ensure-runtime-symbol-table-opened ()
  90       (unless *handles-from-dlopen*
  91         ;; Prevent recursive call if dlopen() isn't defined.
  92         (setf *handles-from-dlopen* (int-sap 0))
  93         (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy)))
  94         (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*)))
  95           (error "can't open our own binary's symbol table: ~S" (dlerror)))))
  96
  97     (defun load-shared-object (file)
  98       "Load a shared library/dynamic shared object file/general
  99   dlopenable alien container.
 100
 101   To use LOAD-SHARED-OBJECT, at the Unix command line do this:
 102     echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
 103     make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
 104     ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
 105   then in SBCL do this:
 106     (LOAD-SHARED-OBJECT \"/tmp/ffi-test.so\")
 107     (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
 108   Now running (SUMMISH 10 20) should return 31.
 109 "
 110       (ensure-runtime-symbol-table-opened)
 111       ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
 112       ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
 113       ;; not all symbols are defined.
 114       (let* ((real-file (or (unix-namestring file) file))
 115              (sap (dlopen real-file (logior rtld-now rtld-global))))
 116         (if (zerop (sap-int sap))
 117             (error "can't open object ~S: ~S" real-file (dlerror))
 118             (pushnew sap *handles-from-dlopen* :test #'sap=)))
 119       (values))
 120
 121     (defun get-dynamic-foreign-symbol-address (symbol)
 122       (ensure-runtime-symbol-table-opened)
 123       ;; Find the symbol in any of the loaded object files. Search in
 124       ;; reverse order of loading, so that later loadings take precedence.
 125       ;;
 126       ;; FIXME: The way that we use PUSHNEW SAP in LOAD-SHARED-OBJECT means
 127       ;; that the list isn't guaranteed to be in reverse order of loading,
 128       ;; at least not if a file is loaded more than once. Is this the
 129       ;; right thing? (In what cases does it matter?)
 130       (dolist (handle (reverse *handles-from-dlopen*))
 131         ;; KLUDGE: We implicitly exclude the possibility that the variable
 132         ;; could actually be NULL, but the man page for dlsym(3)
 133         ;; recommends doing a more careful test. -- WHN 20000825
 134         (let ((possible-result (sap-int (dlsym handle symbol))))
 135           (unless (zerop possible-result)
 136             (return possible-result)))))
 137
 138     ))                                  ; PROGN, MACROLET