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