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