From 4bc6b918bb99e8dcd17bbe6479a06e52b2d04a6c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 25 Aug 2004 14:24:23 +0000 Subject: [PATCH] 0.8.13.78: Birds of Feather * Fix dladdr bogosities: test if dladdr is supported on the platform, and add an ldso_stub for it if so. This so that SBCL isn't dependant on the dladdr being at the same location at runtime as it was on the build-host. Move the dummy definition for FOREIGN-SYMBOL-IN-ADDRESS to target-load, so that backtraces on target will work before foreign.lisp is built. Clean up the real F-S-I-A definition to use the :os-provides-dladdr feature. * Fix manual bogosities: generate functions signalling UNSUPPORTED-OPERATOR-ERROR for SB-BSD-SOCKETS platform-dependant sockopts on platforms where they're not supported; make these functions have the normal doctrings. This so that manual building will work on non-Linux as well. Also clean up the .sbclrc examples slightly. --- contrib/sb-bsd-sockets/defpackage.lisp | 2 +- contrib/sb-bsd-sockets/sockopt.lisp | 88 +++++++++++++++++------------ doc/manual/start-stop.texinfo | 23 ++++---- make-config.sh | 2 + src/code/foreign.lisp | 54 ++++++++---------- src/code/target-load.lisp | 4 ++ tools-for-build/grovel-features.sh | 25 ++++++++ tools-for-build/ldso-stubs.lisp | 2 + tools-for-build/os-provides-dladdr-test.c | 20 +++++++ version.lisp-expr | 2 +- 10 files changed, 142 insertions(+), 80 deletions(-) create mode 100644 tools-for-build/grovel-features.sh create mode 100644 tools-for-build/os-provides-dladdr-test.c diff --git a/contrib/sb-bsd-sockets/defpackage.lisp b/contrib/sb-bsd-sockets/defpackage.lisp index 71d04f8..6779880 100644 --- a/contrib/sb-bsd-sockets/defpackage.lisp +++ b/contrib/sb-bsd-sockets/defpackage.lisp @@ -3,7 +3,6 @@ (:shadow close listen) #+cmu (:shadowing-import-from "CL" with-array-data) #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data) - #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL") #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL")) @@ -64,6 +63,7 @@ non-blocking-mode ) (:use "COMMON-LISP" "SB-BSD-SOCKETS-INTERNAL") + (:import-from "SB-INT" "UNSUPPORTED-OPERATOR" "FEATUREP") (:documentation " diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index 33ecabd..3eb9398 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -37,35 +37,42 @@ Code for options that not every system has should be conditionalised: (defmacro define-socket-option (lisp-name documentation - level number buffer-type mangle-arg mangle-return mangle-setf-buffer) + level number buffer-type mangle-arg mangle-return mangle-setf-buffer + &optional features info) (let ((find-level (if (numberp (eval level)) level - `(get-protocol-by-name ,(string-downcase (symbol-name level)))))) + `(get-protocol-by-name ,(string-downcase (symbol-name level))))) + (supportedp (or (null features) (featurep features)))) `(progn (export ',lisp-name) - (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket))) - ,@(when documentation (list documentation)) - (sb-alien:with-alien ((size sb-alien:integer) - (buffer ,buffer-type)) - (setf size (sb-alien:alien-size ,buffer-type :bytes)) - (if (= -1 (sockint::getsockopt fd ,find-level ,number - (sb-alien:addr buffer) - (sb-alien:addr size))) - (socket-error "getsockopt") - (,mangle-return buffer size)))) - (defun (setf ,lisp-name) (new-val socket - &aux (fd (socket-file-descriptor socket))) - (sb-alien:with-alien ((buffer ,buffer-type)) - (setf buffer ,(if mangle-arg - `(,mangle-arg new-val) - `new-val)) - (when (= -1 (sockint::setsockopt fd ,find-level ,number - (,mangle-setf-buffer buffer) - ,(if (eql buffer-type 'sb-alien:c-string) - `(length new-val) - `(sb-alien:alien-size ,buffer-type :bytes)))) - (socket-error "setsockopt"))))))) + (defun ,lisp-name (socket) + ,@(when documentation (list (concatenate 'string documentation " " info))) + ,(if supportedp + `(sb-alien:with-alien ((size sb-alien:integer) + (buffer ,buffer-type)) + (setf size (sb-alien:alien-size ,buffer-type :bytes)) + (if (= -1 (sockint::getsockopt (socket-file-descriptor socket) + ,find-level ,number + (sb-alien:addr buffer) + (sb-alien:addr size))) + (socket-error "getsockopt") + (,mangle-return buffer size))) + `(error 'unsupported-operator :name ',lisp-name))) + (defun (setf ,lisp-name) (new-val socket) + ,(if supportedp + `(sb-alien:with-alien ((buffer ,buffer-type)) + (setf buffer ,(if mangle-arg + `(,mangle-arg new-val) + `new-val)) + (when (= -1 (sockint::setsockopt (socket-file-descriptor socket) + ,find-level ,number + (,mangle-setf-buffer buffer) + ,(if (eql buffer-type 'sb-alien:c-string) + `(length new-val) + `(sb-alien:alien-size ,buffer-type :bytes)))) + (socket-error "setsockopt"))) + `(error 'unsupported-operator :name `(setf ,lisp-name))))))) ;;; sockopts that have integer arguments @@ -73,9 +80,9 @@ Code for options that not every system has should be conditionalised: (assert (= size (sb-alien:alien-size sb-alien:integer :bytes))) buffer) -(defmacro define-socket-option-int (name level number) +(defmacro define-socket-option-int (name level number &optional features (info "")) `(define-socket-option ,name nil ,level ,number - sb-alien:integer nil foreign-int-to-integer sb-alien:addr)) + sb-alien:integer nil foreign-int-to-integer sb-alien:addr ,features ,info)) (define-socket-option-int sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat) @@ -87,8 +94,9 @@ Code for options that not every system has should be conditionalised: sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf) (define-socket-option-int sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf) -#+linux(define-socket-option-int - sockopt-priority sockint::sol-socket sockint::so-priority) +(define-socket-option-int + sockopt-priority sockint::sol-socket sockint::so-priority :linux + "Available only on Linux.") ;;; boolean options are integers really @@ -100,11 +108,14 @@ Code for options that not every system has should be conditionalised: (defun bool-to-foreign-int (val) (if val 1 0)) -(defmacro define-socket-option-bool (name level c-name) +(defmacro define-socket-option-bool (name level c-name &optional features (info "")) `(define-socket-option ,name - ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name)) + ,(format nil "~@" + (symbol-name c-name)) ,level ,c-name - sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr)) + sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr + ,features ,info)) (define-socket-option-bool sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr) @@ -112,10 +123,12 @@ Code for options that not every system has should be conditionalised: sockopt-keep-alive sockint::sol-socket sockint::so-keepalive) (define-socket-option-bool sockopt-oob-inline sockint::sol-socket sockint::so-oobinline) -#+linux(define-socket-option-bool - sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat) -#+linux(define-socket-option-bool - sockopt-pass-credentials sockint::sol-socket sockint::so-passcred) +(define-socket-option-bool + sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat :linux + "Available only on Linux.") +(define-socket-option-bool + sockopt-pass-credentials sockint::sol-socket sockint::so-passcred :linux + "Available only on Linux.") (define-socket-option-bool sockopt-debug sockint::sol-socket sockint::so-debug) (define-socket-option-bool @@ -129,8 +142,9 @@ Code for options that not every system has should be conditionalised: (declare (ignore args)) x) -#+linux(define-socket-option sockopt-bind-to-device nil sockint::sol-socket - sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity) +(define-socket-option sockopt-bind-to-device nil sockint::sol-socket + sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity + :linux "Available only on Linux") ;;; other kinds of socket option diff --git a/doc/manual/start-stop.texinfo b/doc/manual/start-stop.texinfo index 8e9df47..53f34d1 100644 --- a/doc/manual/start-stop.texinfo +++ b/doc/manual/start-stop.texinfo @@ -301,20 +301,20 @@ initialization file does the trick: @lisp ;;; If the first user-processable command-line argument is a filename, ;;; disable the debugger, load the file handling shebang-line and quit. -(let ((script (and (second sb-ext:*posix-argv*) - (probe-file (second sb-ext:*posix-argv*))))) +(let ((script (and (second *posix-argv*) (probe-file (second *posix-argv*))))) (when script - ;; Handle the possible shebang-line + ;; Handle shebang-line (set-dispatch-macro-character #\# #\! (lambda (stream char arg) (declare (ignore char arg)) (read-line stream))) ;; Disable debugger - (setf sb-ext:*invoke-debugger-hook* - (lambda (condition hook) - (declare (ignore hook)) - (format *error-output* "Error: ~A~%" condition) - (quit :unix-status 1))) + (setf *invoke-debugger-hook* (lambda (condition hook) + (declare (ignore hook)) + ;; Uncomment to get backtraces on errors + ;; (sb-debug:backtrace 20) + (format *error-output* "Error: ~A~%" condition) + (quit))) (load script) (quit))) @end lisp @@ -364,7 +364,8 @@ handles recompilation automatically for ASDF-based systems. ;;; If a fasl was stale, try to recompile and load (once). (defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file)) (handler-case (call-next-method o c) - (sb-ext:invalid-fasl error () - (asdf:perform (make-instance 'asdf:compile-op) c) - (call-next-method)))) + ;; If a fasl was stale, try to recompile and load (once). + (sb-ext:invalid-fasl () + (asdf:perform (make-instance 'asdf:compile-op) c) + (call-next-method)))) @end lisp diff --git a/make-config.sh b/make-config.sh index 3f58b71..aba3e2a 100644 --- a/make-config.sh +++ b/make-config.sh @@ -201,6 +201,8 @@ else echo > /dev/null fi +sh tools-for-build/grovel-features.sh >> $ltf + echo //finishing $ltf echo ')' >> $ltf diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 5e1fc57..3102c08 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -26,10 +26,10 @@ ;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern ;;; enough to have a fairly well working dlopen/dlsym implementation. (macrolet ((define-unsupported-fun (fun-name &optional (error-message "unsupported on this system")) - `(defun ,fun-name (&rest rest) - ,error-message - (declare (ignore rest)) - (error 'unsupported-operator :name ',fun-name)))) + `(defun ,fun-name (&rest rest) + ,error-message + (declare (ignore rest)) + (error 'unsupported-operator :name ',fun-name)))) #-(or linux sunos FreeBSD OpenBSD NetBSD darwin) (define-unsupported-fun load-shared-object) #+(or linux sunos FreeBSD OpenBSD NetBSD darwin) @@ -136,32 +136,26 @@ (unless (zerop possible-result) (return possible-result))))) + #+os-provides-dladdr + ;;; Override the early definition in target-load.lisp (defun foreign-symbol-in-address (sap) - (declare (ignore sap))) - - (when (ignore-errors (foreign-symbol-address "dladdr")) - (setf (symbol-function 'foreign-symbol-in-address) - ;; KLUDGE: This COMPILE trick is to avoid trying to - ;; compile a reference to dladdr on platforms without it. - (compile nil - '(lambda (sap) - (let ((addr (sap-int sap))) - (with-alien ((info - (struct dl-info - (filename c-string) - (base unsigned) - (symbol c-string) - (symbol-address unsigned))) - (dladdr - (function unsigned - unsigned (* (struct dl-info))) - :extern "dladdr")) - (let ((err (alien-funcall dladdr addr (addr info)))) - (if (zerop err) - nil - (values (slot info 'symbol) - (slot info 'filename) - addr - (- addr (slot info 'symbol-address))))))))))) + (let ((addr (sap-int sap))) + (with-alien ((info + (struct dl-info + (filename c-string) + (base unsigned) + (symbol c-string) + (symbol-address unsigned))) + (dladdr + (function unsigned + unsigned (* (struct dl-info))) + :extern "dladdr")) + (let ((err (alien-funcall dladdr addr (addr info)))) + (if (zerop err) + nil + (values (slot info 'symbol) + (slot info 'filename) + addr + (- addr (slot info 'symbol-address)))))))) )) ; PROGN, MACROLET diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 560ba0e..c16eaba 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -309,3 +309,7 @@ (defun foreign-symbol-address (symbol) (int-sap (foreign-symbol-address-as-integer (sb!vm:extern-alien-name symbol)))) + +;;; Overridden in foreign.lisp once we're running on target +(defun foreign-symbol-in-address (sap) + (declare (ignore sap))) diff --git a/tools-for-build/grovel-features.sh b/tools-for-build/grovel-features.sh new file mode 100644 index 0000000..0931c18 --- /dev/null +++ b/tools-for-build/grovel-features.sh @@ -0,0 +1,25 @@ +# Automated platform feature testing + +DIR=tools-for-build + +# FIXME: Use this to test for dlopen presence and hence +# load-shared-object buildability + +# $1 feature +# $2 additional flags +# +# Assumes the presence of $1-test.c, which when built and +# run should return with 104 if the feature is present. +# +featurep() { + bin="$DIR/$1-test" + rm -f $bin + cc $DIR/$1-test.c $2 -o $bin 2>&1 > /dev/null && $bin 2>&1 /dev/null + if [ "$?" = 104 ] + then + printf " :$1" + fi + rm -f $bin +} + +featurep os-provides-dladdr -ldl diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp index 00cc8de..bf5b04e 100644 --- a/tools-for-build/ldso-stubs.lisp +++ b/tools-for-build/ldso-stubs.lisp @@ -258,6 +258,8 @@ ldso_stub__ ## fct: ; \\ "dlerror" "dlopen" "dlsym") + #!+os-provides-dladdr + '("dladdr") #!-(and sparc sunos) ;; !defined(SVR4) '("sigsetmask"))) diff --git a/tools-for-build/os-provides-dladdr-test.c b/tools-for-build/os-provides-dladdr-test.c new file mode 100644 index 0000000..4b0f472 --- /dev/null +++ b/tools-for-build/os-provides-dladdr-test.c @@ -0,0 +1,20 @@ +/* test to build and run so that we know if we have dladdr + */ + +/* bloody FSF dlcfn.h won't give us dladdr without this */ +#define _GNU_SOURCE + +#include + +int main () +{ + void * handle = dlopen((void*)0, RTLD_GLOBAL | RTLD_NOW); + void * addr = dlsym(handle, "printf"); + Dl_info * info = (Dl_info*) malloc(sizeof(Dl_info)); + dladdr(addr, info); + if (strcmp(info->dli_sname, "printf")) { + return 1; + } else { + return 104; + } +} diff --git a/version.lisp-expr b/version.lisp-expr index bf049a5..b5b3395 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.13.77" +"0.8.13.78" -- 1.7.10.4