1 ;;;; support for dynamically loading foreign object files
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;; not needed until we implement full-blown LOAD-FOREIGN
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
24 (base "/tmp/sbcl-tmp-~D~C"))
25 (let ((code (char-code #\A)))
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
34 (cond ((not (null fd))
35 (sb-unix:unix-close fd)
37 ((not (= errno sb-unix:eexist))
38 (error "could not create temporary file ~S: ~A"
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))
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
54 ;;; (On any OS which *does* support foreign object file loading, this
55 ;;; placeholder implementation is overwritten by a subsequent real
57 (defun get-dynamic-foreign-symbol-address (symbol)
58 (declare (type simple-string symbol) (ignore symbol))
61 ;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
62 ;;; and functions (e.g. LOAD-FOREIGN) which affect it
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
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
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*)
99 ;;; not needed until we implement full-blown LOAD-FOREIGN
101 (defvar *dso-linker* "/usr/bin/ld")
102 (defvar *dso-linker-options* '("-G" "-o"))
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)
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)))))
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..)
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.
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=)))
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.
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)))))
168 ;;; code partially ported from CMU CL to SBCL, but needs RUN-PROGRAM
170 (defun load-foreign (files &key
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.
178 (env sb-ext:*environment-list*))
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)))
196 (/show "running" *dso-linker*)
199 (let ((proc (sb-ext:run-program
201 (append *dso-linker-options*
203 (append (mapcar #'(lambda (name)
204 (unix-namestring name nil))
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