src/code/foreign.lisp

   1 ;;;; support for dynamically loading foreign 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-SYS")
  13
  14 (defun pick-temporary-file-name (&optional
  15                                  ;; KLUDGE: There are various security
  16                                  ;; nastyisms associated with easily
  17                                  ;; guessable temporary file names,
  18                                  ;; and we haven't done anything to
  19                                  ;; work around them here. -- pointed
  20                                  ;; out by Dan Barlow on sbcl-devel
  21                                  ;; 20000702
  22                                  (base "/tmp/sbcl-tmp-~D~C"))
  23   (let ((code (char-code #\A)))
  24     (loop
  25       (let ((name (format nil base (sb-unix:unix-getpid) (code-char code))))
  26         (multiple-value-bind (fd errno)
  27             (sb-unix:unix-open name
  28                                (logior sb-unix:o_wronly
  29                                        sb-unix:o_creat
  30                                        sb-unix:o_excl)
  31                                #o666)
  32           (cond ((not (null fd))
  33                  (sb-unix:unix-close fd)
  34                  (return name))
  35                 ((not (= errno sb-unix:eexist))
  36                  (simple-file-perror "couldn't create temporary file ~S"
  37                                      name
  38                                      errno))
  39                 ;; KLUDGE: depends on ASCII character ordering -- WHN 20000128
  40                 ((= code (char-code #\Z))
  41                  (setf code (char-code #\a)))
  42                 ((= code (char-code #\z))
  43                  (return nil))
  44                 (t
  45                  (incf code))))))))
  46
  47
  48 ;;; On any OS where we don't support foreign object file loading, any
  49 ;;; query of a foreign symbol value is answered with "no definition
  50 ;;; known", i.e. NIL.
  51 ;;;
  52 ;;; (On any OS which *does* support foreign object file loading, this
  53 ;;; placeholder implementation is overwritten by a subsequent real
  54 ;;; implementation.)
  55 (defun get-dynamic-foreign-symbol-address (symbol)
  56   (declare (type simple-string symbol) (ignore symbol))
  57   nil)
  58
  59 ;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
  60 ;;; and functions (e.g. LOAD-FOREIGN) which affect it
  61 #+(or linux FreeBSD)
  62 (progn
  63
  64 ;;; flags for dlopen()
  65 (defconstant rtld-lazy 1)               ; lazy function call binding?
  66 (defconstant rtld-now 2)                ; immediate function call binding?
  67 (defconstant rtld-global #x100)         ; symbols of loaded obj file
  68                                         ; (and its dependencies) made
  69                                         ; visible (as though the
  70                                         ; obj file were linked directly
  71                                         ; into the program)?
  72
  73 ;;; a list of tables returned from dlopen(3) (or possibly some
  74 ;;; bogus value temporarily during initialization)
  75 (defvar *tables-from-dlopen* nil)
  76 ;;; Dynamically loaded stuff isn't there upon restoring from a save.
  77 ;;; Clearing the variable this way was originally done primarily for
  78 ;;; Irix, which resolves tzname at runtime, resulting in
  79 ;;; *TABLES-FROM-DLOPEN* being set in the saved core image, resulting
  80 ;;; in havoc upon restart; but it seems harmless and tidy for other
  81 ;;; OSes too.
  82 ;;;
  83 ;;; Of course, it can be inconvenient that dynamically loaded stuff
  84 ;;; goes away when we save and restore. However,
  85 ;;;  (1) trying to avoid it by system programming here could open a
  86 ;;;      huge can of worms, since e.g. now we would need to worry about
  87 ;;;      libraries possibly being in different locations (file locations
  88 ;;;      or memory locations) at restore time than at save time; and
  89 ;;;  (2) by the time the application programmer is so deep into the
  90 ;;;      the use of hard core extension features as to be doing
  91 ;;;      dynamic loading of foreign files and saving/restoring cores,
  92 ;;;      he probably has the sophistication to write his own after-save
  93 ;;;      code to reload the libraries without much difficulty.
  94 (push (lambda () (setq *tables-from-dlopen* nil))
  95       *after-save-initializations*)
  96
  97 (defvar *dso-linker* "/usr/bin/ld")
  98 (defvar *dso-linker-options* '("-G" "-o"))
  99
 100
 101 (sb-alien:def-alien-routine dlopen system-area-pointer
 102   (file sb-c-call:c-string) (mode sb-c-call:int))
 103 (sb-alien:def-alien-routine dlsym system-area-pointer
 104   (lib system-area-pointer)
 105   (name sb-c-call:c-string))
 106 (sb-alien:def-alien-routine dlerror sb-c-call:c-string)
 107
 108 ;;; Ensure that we've opened our own binary so we can resolve global
 109 ;;; variables in the Lisp image that come from libraries. This used to
 110 ;;; happen only in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no
 111 ;;; libraries were dlopen()ed already, but that didn't work if
 112 ;;; something was dlopen()ed before any problem global vars were used.
 113 ;;; So now we do this in any function that can add to the
 114 ;;; *TABLES-FROM-DLOPEN*, as well as in
 115 ;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
 116 (defun ensure-lisp-table-opened ()
 117   (unless *tables-from-dlopen*
 118     ;; Prevent recursive call if dlopen() isn't defined.
 119     (setf *tables-from-dlopen* (int-sap 0))
 120     (setf *tables-from-dlopen* (list (dlopen nil rtld-lazy)))
 121     (when (zerop (sb-sys:sap-int (first *tables-from-dlopen*)))
 122       (error "can't open global symbol table: ~S" (dlerror)))))
 123
 124 (defun load-1-foreign (file)
 125   "the primitive upon which the more general LOAD-FOREIGN is built: load
 126   a single foreign object file
 127
 128   To use LOAD-1-FOREIGN, at the Unix command line do this:
 129     echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
 130     make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
 131     ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
 132   then in SBCL do this:
 133     (LOAD-1-FOREIGN \"/tmp/ffi-test.so\")
 134     (DEF-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
 135   Now running (SUMMISH 10 20) should return 31.
 136 "
 137   (ensure-lisp-table-opened)
 138   ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
 139   ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
 140   ;; not all symbols are defined.
 141   (let* ((real-file (or (unix-namestring file) file))
 142          (sap (dlopen real-file (logior rtld-now rtld-global))))
 143        (if (zerop (sap-int sap))
 144            (error "can't open object ~S: ~S" real-file (dlerror))
 145            (pushnew sap *tables-from-dlopen* :test #'sap=)))
 146   (values))
 147
 148 (defun get-dynamic-foreign-symbol-address (symbol)
 149   (ensure-lisp-table-opened)
 150   ;; Find the symbol in any of the loaded object files. Search in
 151   ;; reverse order of loading, so that later loadings take precedence.
 152   ;;
 153   ;; FIXME: The way that we use PUSHNEW SAP in LOAD-1-FOREIGN means
 154   ;; that the list isn't guaranteed to be in reverse order of loading,
 155   ;; at least not if a file is loaded more than once. Is this the
 156   ;; right thing? (In what cases does it matter?)
 157   (dolist (table *tables-from-dlopen*)
 158     ;; KLUDGE: We implicitly exclude the possibility that the variable
 159     ;; could actually be NULL, but the man page for dlsym(3)
 160     ;; recommends doing a more careful test. -- WHN 20000825
 161     (let ((possible-result (sap-int (dlsym table symbol))))
 162       (unless (zerop possible-result)
 163         (return possible-result)))))
 164
 165 (defun load-foreign (files
 166                      &key
 167                      (libraries '("-lc"))
 168                      ;; FIXME: The old documentation said
 169                      ;;   The BASE-FILE argument is used to specify a
 170                      ;;   file to use as the starting place for
 171                      ;;   defined symbols. The default is the C start
 172                      ;;   up code for Lisp.
 173                      ;; But the code ignored the BASE-FILE argument.
 174                      ;; The comment above
 175                      ;;   (DECLARE (IGNORE BASE-FILE))
 176                      ;; said
 177                      ;;   dlopen() remembers the name of an object,
 178                      ;;   when dlopen()ing the same name twice, the
 179                      ;;   old object is reused.
 180                      ;; So I deleted all reference to BASE-FILE,
 181                      ;; including the now-bogus reference to the
 182                      ;; BASE-FILE argument in the documentation. But
 183                      ;; are there any other subtleties of the new code
 184                      ;; which need to be documented in its place?
 185                      (env nil env-p)
 186                      (environment (if env-p
 187                                       (unix-environment-sbcl-from-cmu env)
 188                                       (posix-environ))
 189                                   environment-p))
 190   #+sb-doc
 191   "LOAD-FOREIGN loads a list of C object files into a running Lisp. The FILES
 192   argument should be a single file or a list of files. The files may be
 193   specified as namestrings or as pathnames. The libraries argument should be a
 194   list of library files as would be specified to ld. They will be searched in
 195   the order given. The default is just \"-lc\", i.e., the C library. The
 196   ENVIRONMENT argument is a list of SIMPLE-STRINGs corresponding to the Unix
 197   environment (\"man environ\") definitions for the invocation of the linker.
 198   The default is the environment that Lisp is itself running in. Instead of
 199   using the ENVIRONMENT argument, it is also possible to use the ENV argument,
 200   using the alternate, lossy representation used by CMU CL."
 201   (when (and env-p environment-p)
 202     (error "can't specify :ENV and :ENVIRONMENT simultaneously"))
 203   (let ((output-file (pick-temporary-file-name
 204                       (concatenate 'string "/tmp/~D~C" (string (gensym)))))
 205         (error-output (make-string-output-stream)))
 206
 207     (/show "running" *dso-linker*)
 208     (force-output)
 209     (unwind-protect
 210         (let ((proc (sb-ext:run-program
 211                      *dso-linker*
 212                      (append *dso-linker-options*
 213                              (list output-file)
 214                              (append (mapcar #'(lambda (name)
 215                                                  (unix-namestring name nil))
 216                                              (if (atom files)
 217                                                  (list files)
 218                                                files))
 219                                      libraries))
 220                      :environment environment
 221                      :input nil
 222                      :output error-output
 223                      :error :output)))
 224           (unless proc
 225             (error "could not run ~A" *dso-linker*))
 226           (unless (zerop (sb-ext:process-exit-code proc))
 227             (sb-sys:serve-all-events 0)
 228             (error "~A failed:~%~A" *dso-linker*
 229                    (get-output-stream-string error-output)))
 230           (load-1-foreign output-file))
 231       #-sb-show (sb-unix:unix-unlink output-file)
 232       #+sb-show (/show "not unlinking" output-file)))) ; so we can look at it
 233
 234 ) ; PROGN