X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign.lisp;h=87d8939f7030acfe774c03e9ed47e50fb1f726b2;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=ee6029568652a74786c4c2af664a36d154af95b9;hpb=5108495b13b99452d5a85c4600f68432ff8894b2;p=sbcl.git diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index ee60295..87d8939 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -1,4 +1,5 @@ -;;;; support for dynamically loading foreign object files +;;;; support for dynamically loading foreign object files and +;;;; resolving symbols therein ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -9,20 +10,29 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-SYS") +(in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.) + +;;; SEMI-KLUDGE: Preferable would be to use something like O_NOFOLLOW +;;; which will refuse to open() a file if it is a symlink; but I've +;;; been told that is a FreeBSD/Linux-only thing. Meanwhile, this will +;;; make our filenames a lot less predictable. +;;; (The man file for open() says O_EXCL should treat even a symlink as +;;; an existing file. I wonder if it really does that.) +;;; Also, no more dependence on ASCII character ordering. +;;; -- mrd 20021101 +(defun generate-random-string (&optional (len 6)) + (let* ((characters "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") + (num (length characters)) + (string (make-string len))) + (dotimes (i len string) + (setf (char string i) + (char characters (random num)))))) (defun pick-temporary-file-name (&optional - ;; KLUDGE: There are various security - ;; nastyisms associated with easily - ;; guessable temporary file names, - ;; and we haven't done anything to - ;; work around them here. -- pointed - ;; out by Dan Barlow on sbcl-devel - ;; 20000702 - (base "/tmp/sbcl-tmp-~D~C")) - (let ((code (char-code #\A))) + (base "/tmp/sbcl-tmp-~D~A")) + (let ((code (generate-random-string))) (loop - (let ((name (format nil base (sb-unix:unix-getpid) (code-char code)))) + (let ((name (format nil base (sb-unix:unix-getpid) code))) (multiple-value-bind (fd errno) (sb-unix:unix-open name (logior sb-unix:o_wronly @@ -36,14 +46,8 @@ (simple-file-perror "couldn't create temporary file ~S" name errno)) - ;; KLUDGE: depends on ASCII character ordering -- WHN 20000128 - ((= code (char-code #\Z)) - (setf code (char-code #\a))) - ((= code (char-code #\z)) - (return nil)) (t - (incf code)))))))) - + (setf code (generate-random-string))))))))) ;;; On any OS where we don't support foreign object file loading, any ;;; query of a foreign symbol value is answered with "no definition @@ -52,13 +56,27 @@ ;;; (On any OS which *does* support foreign object file loading, this ;;; placeholder implementation is overwritten by a subsequent real ;;; implementation.) +;;; +;;; You may want to use SB-SYS:FOREIGN-SYMBOL-ADDRESS instead of +;;; calling this directly; see code/target-load.lisp. (defun get-dynamic-foreign-symbol-address (symbol) (declare (type simple-string symbol) (ignore symbol)) nil) -;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS -;;; and functions (e.g. LOAD-FOREIGN) which affect it -#+(or linux FreeBSD) +;;; dlsym()-based implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS +;;; and functions (e.g. LOAD-FOREIGN) which affect it. This should +;;; work on any ELF system with dlopen(3) and dlsym(3) +;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern +;;; enough to have a fairly well working dlopen/dlsym implementation. +#-(or linux sunos FreeBSD OpenBSD) +(macrolet ((define-unsupported-fun (fun-name) + `(defun ,fun-name (&rest rest) + "unsupported on this system" + (declare (ignore rest)) + (error 'unsupported-operator :name ',fun-name)))) + (define-unsupported-fun load-1-foreign) + (define-unsupported-fun load-foreign)) +#+(or linux sunos FreeBSD OpenBSD) (progn ;;; flags for dlopen() @@ -70,15 +88,16 @@ ; obj file were linked directly ; into the program)? -;;; a list of tables returned from dlopen(3) (or possibly some +;;; a list of handles returned from dlopen(3) (or possibly some ;;; bogus value temporarily during initialization) -(defvar *tables-from-dlopen* nil) +(defvar *handles-from-dlopen* nil) + ;;; Dynamically loaded stuff isn't there upon restoring from a save. ;;; Clearing the variable this way was originally done primarily for ;;; Irix, which resolves tzname at runtime, resulting in -;;; *TABLES-FROM-DLOPEN* being set in the saved core image, resulting -;;; in havoc upon restart; but it seems harmless and tidy for other -;;; OSes too. +;;; *HANDLES-FROM-DLOPEN* (which was then called *TABLES-FROM-DLOPEN*) +;;; being set in the saved core image, resulting in havoc upon +;;; restart; but it seems harmless and tidy for other OSes too. ;;; ;;; Of course, it can be inconvenient that dynamically loaded stuff ;;; goes away when we save and restore. However, @@ -91,35 +110,42 @@ ;;; dynamic loading of foreign files and saving/restoring cores, ;;; he probably has the sophistication to write his own after-save ;;; code to reload the libraries without much difficulty. -(push (lambda () (setq *tables-from-dlopen* nil)) + +;;; dan 2001.05.10 suspects that objection (1) is bogus for +;;; dlsym()-enabled systems + +(push (lambda () (setq *handles-from-dlopen* nil)) *after-save-initializations*) (defvar *dso-linker* "/usr/bin/ld") -(defvar *dso-linker-options* '("-G" "-o")) - +(defvar *dso-linker-options* '("-shared" "-o")) -(sb-alien:def-alien-routine dlopen system-area-pointer - (file sb-c-call:c-string) (mode sb-c-call:int)) -(sb-alien:def-alien-routine dlsym system-area-pointer +(sb-alien:define-alien-routine dlopen system-area-pointer + (file sb-alien:c-string) (mode sb-alien:int)) +(sb-alien:define-alien-routine dlsym system-area-pointer (lib system-area-pointer) - (name sb-c-call:c-string)) -(sb-alien:def-alien-routine dlerror sb-c-call:c-string) - -;;; Ensure that we've opened our own binary so we can resolve global -;;; variables in the Lisp image that come from libraries. This used to -;;; happen only in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no -;;; libraries were dlopen()ed already, but that didn't work if -;;; something was dlopen()ed before any problem global vars were used. -;;; So now we do this in any function that can add to the -;;; *TABLES-FROM-DLOPEN*, as well as in -;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS. -(defun ensure-lisp-table-opened () - (unless *tables-from-dlopen* + (name sb-alien:c-string)) +(sb-alien:define-alien-routine dlerror sb-alien:c-string) + +;;; Ensure that we've opened our own binary so we can dynamically resolve +;;; symbols in the C runtime. +;;; +;;; Old comment: This used to happen only in +;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were +;;; dlopen()ed already, but that didn't work if something was +;;; dlopen()ed before any problem global vars were used. So now we do +;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as +;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS. +;;; +;;; FIXME: It would work just as well to do it once at startup, actually. +;;; Then at least we know it's done. -dan 2001.05.10 +(defun ensure-runtime-symbol-table-opened () + (unless *handles-from-dlopen* ;; Prevent recursive call if dlopen() isn't defined. - (setf *tables-from-dlopen* (int-sap 0)) - (setf *tables-from-dlopen* (list (dlopen nil rtld-lazy))) - (when (zerop (sb-sys:sap-int (first *tables-from-dlopen*))) - (error "can't open global symbol table: ~S" (dlerror))))) + (setf *handles-from-dlopen* (int-sap 0)) + (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy))) + (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*))) + (error "can't open our own binary's symbol table: ~S" (dlerror))))) (defun load-1-foreign (file) "the primitive upon which the more general LOAD-FOREIGN is built: load @@ -131,10 +157,10 @@ ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o then in SBCL do this: (LOAD-1-FOREIGN \"/tmp/ffi-test.so\") - (DEF-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT)) + (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT)) Now running (SUMMISH 10 20) should return 31. " - (ensure-lisp-table-opened) + (ensure-runtime-symbol-table-opened) ;; Note: We use RTLD-GLOBAL so that it can find all the symbols ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if ;; not all symbols are defined. @@ -142,11 +168,11 @@ (sap (dlopen real-file (logior rtld-now rtld-global)))) (if (zerop (sap-int sap)) (error "can't open object ~S: ~S" real-file (dlerror)) - (pushnew sap *tables-from-dlopen* :test #'sap=))) + (pushnew sap *handles-from-dlopen* :test #'sap=))) (values)) (defun get-dynamic-foreign-symbol-address (symbol) - (ensure-lisp-table-opened) + (ensure-runtime-symbol-table-opened) ;; Find the symbol in any of the loaded object files. Search in ;; reverse order of loading, so that later loadings take precedence. ;; @@ -154,11 +180,11 @@ ;; that the list isn't guaranteed to be in reverse order of loading, ;; at least not if a file is loaded more than once. Is this the ;; right thing? (In what cases does it matter?) - (dolist (table *tables-from-dlopen*) + (dolist (handle *handles-from-dlopen*) ;; KLUDGE: We implicitly exclude the possibility that the variable ;; could actually be NULL, but the man page for dlsym(3) ;; recommends doing a more careful test. -- WHN 20000825 - (let ((possible-result (sap-int (dlsym table symbol)))) + (let ((possible-result (sap-int (dlsym handle symbol)))) (unless (zerop possible-result) (return possible-result))))) @@ -201,7 +227,7 @@ (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) (let ((output-file (pick-temporary-file-name - (concatenate 'string "/tmp/~D~C" (string (gensym))))) + (concatenate 'string "/tmp/~D~A" (string (gensym))))) (error-output (make-string-output-stream))) (/show "running" *dso-linker*)