From c568b864cdc7aac49b0635a8ca497d5f66921c46 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Fri, 21 Nov 2003 04:33:24 +0000
Subject: [PATCH] From Helmut Eller on cmucl-imp: a little patch to get nicer
 names for foreign functions in the backtrace.

I slightly frobbed the order of the displayed info to display the
function first.  Suggestions welcome for a nicer arrangement.
---
 code/debug-int.lisp | 32 ++++++++++++++++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index a60f9cf5c..de87d2d8b 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.105 2003/08/24 07:52:56 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.106 2003/11/21 04:33:24 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1238,6 +1238,34 @@
 				 (if up-frame (1+ (frame-number up-frame)) 0)
 				 escaped))))))
 
+#+(and x86 linux)
+(defun find-foreign-function-name (address)
+  "Return a string describing the foreign function near ADDRESS"
+  (let ((addr (sys:sap-int address)))
+    (alien:with-alien ((info (alien:struct dl-info
+					   (filename c-call:c-string)
+					   (base alien:unsigned)
+					   (symbol c-call:c-string)
+					   (symbol-address alien:unsigned)))
+		       (dladdr (function alien:unsigned alien:unsigned
+					 (* (alien:struct dl-info)))
+			       :extern "dladdr"))
+      (let ((err (alien:alien-funcall dladdr addr (alien:addr info))))
+	(cond ((zerop err)
+	       "Foreign function call land")
+	      (t
+	       (format nil "~A+#x~x [#x~X] ~A"
+		       (alien:slot info 'symbol)
+		       (- addr (alien:slot info 'symbol-address))
+		       addr
+		       (alien:slot info 'filename)
+		       )))))))
+
+#+(and x86 (not linux))
+(defun find-foreign-function-name (ra)
+  (declare (ignore ra))
+  "Foreign function call land")
+
 #+x86
 (defun compute-calling-frame (caller ra up-frame)
   (declare (type system:system-area-pointer caller ra))
@@ -1277,7 +1305,7 @@
 			     "The Undefined Function"))
 			   (:foreign-function
 			    (make-bogus-debug-function
-			     "Foreign function call land"))
+			     (find-foreign-function-name ra)))
 			   ((nil)
 			    (make-bogus-debug-function
 			     "Bogus stack frame"))
-- 
GitLab