Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17207/src/code
Modified Files:
debug-int.lisp foreign.lisp
Log Message:
0.8.13.10: I don't think we're in lisp-land anymore...
* Display foreign function names in backtraces on platforms
with dladdr. Essentially a port of Helmut Eller's patch
for CMUCL. Works fine on x86 and Sparc at least.
* Clean up some spurious sb-alien package prefixes from
foreign.lisp while at it.
Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- debug-int.lisp 28 Jul 2004 08:43:29 -0000 1.81
+++ debug-int.lisp 29 Jul 2004 11:29:53 -0000 1.82
@@ -780,6 +780,12 @@
(#.lra-save-offset
(setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+(defun foreign-function-debug-name (sap)
+ (multiple-value-bind (name file base offset) (foreign-symbol-in-address sap)
+ (if name
+ (format nil "foreign function: ~A [~A: #x~X + #x~X]" name file base offset)
+ (format nil "foreign function: #x~X" (sap-int sap)))))
+
;;; This returns a frame for the one existing in time immediately
;;; prior to the frame referenced by current-fp. This is current-fp's
;;; caller or the next frame down the control stack. If there is no
@@ -826,7 +832,7 @@
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- (format nil "foreign function call land:")))
+ (foreign-function-debug-name (int-sap (get-lisp-obj-address lra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
@@ -871,9 +877,7 @@
(make-bogus-debug-fun
"undefined function"))
(:foreign-function
- (make-bogus-debug-fun
- (format nil "foreign function call land: ra=#x~X"
- (sap-int ra))))
+ (make-bogus-debug-fun (foreign-function-debug-name ra)))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
Index: foreign.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/foreign.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- foreign.lisp 19 Jul 2004 20:13:23 -0000 1.21
+++ foreign.lisp 29 Jul 2004 11:29:53 -0000 1.22
@@ -67,13 +67,14 @@
(push (lambda () (setq *handles-from-dlopen* nil))
*after-save-initializations*)
- (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-alien:c-string))
- (sb-alien:define-alien-routine dlerror sb-alien:c-string)
-
+ (define-alien-routine dlopen system-area-pointer
+ (file c-string) (mode int))
+
+ (define-alien-routine dlsym system-area-pointer
+ (lib system-area-pointer) (name c-string))
+
+ (define-alien-routine dlerror c-string)
+
;;; Ensure that we've opened our own binary so we can dynamically resolve
;;; symbols in the C runtime.
;;;
@@ -135,4 +136,32 @@
(unless (zerop possible-result)
(return possible-result)))))
+ (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)))))))))))
+
)) ; PROGN, MACROLET
|