From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 29 Jul 2004 11:29:52 +0000 (+0000)
Subject: 0.8.13.10: I don't think we're in lisp-land anymore...
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bcb7a9c9d1cc1566d449efdfd40476d16477a2c9;p=sbcl.git

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.
---

diff --git a/NEWS b/NEWS
index bd89023..4f52e72 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,7 @@
 changes in sbcl-0.8.14 relative to sbcl-0.8.13:
+  * new feature: on platforms where "dladdr" is available foreign
+    function names now appear in backtraces.  (based on Helmut Eller's
+    work for CMUCL)
   * bug fix: backtraces involving undefined functions or assembly
     routines are more informative.  (thanks to Brian Downing)
   * bug fix: mutually referent alien structures now work correctly.
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index f41aa60..44bd7d8 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1792,6 +1792,7 @@ SB-KERNEL) have been undone, but probably more remain."
 				      "ENABLE-INTERRUPT" "ENUMERATION"
 				      "FD-STREAM-FD" "FD-STREAM-P" 
 				      "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER"
+				      "FOREIGN-SYMBOL-IN-ADDRESS"
 				      "GET-PAGE-SIZE" "GET-SYSTEM-INFO"
 				      "IGNORE-INTERRUPT"
 				      "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT"
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index d58a2c2..352f968 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -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"))
diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp
index fc4a3b8..5e1fc57 100644
--- a/src/code/foreign.lisp
+++ b/src/code/foreign.lisp
@@ -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
diff --git a/version.lisp-expr b/version.lisp-expr
index e3a00ac..8eebb8e 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.9"
+"0.8.13.10"