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