From 46a81e81c5c222cb63dc766d68559bc07edc8bb7 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 17 Mar 2005 23:13:55 +0000
Subject: [PATCH] Implement tracing for the known-return convention.  This is
 basically Helmut Eller's patch sent to cmucl-imp on 2005-03-08.  This
 basically means tracing recursive functions will show all recursions during
 the trace and not just the final call.

code/debug-int.lisp:
o Apply Helmut's patch.  Tweak it so when the known-return convention
  is being used, we tell MAKE-BOGUS-LRA that we're using the
  known-return so we can handle it properly.

lisp/breakpoint.c:
o Add an extra parameter to compute_offset so we know we're handling a
  function-end breakpoint or not.  Needed because reg_CODE isn't
  pointing to the bogus lra in this case, so the offsets are all
  wrong.  We compute the right offset for the known return and return
  the offset as negative so we can tell.
o Adjust all callers of compute_offset.
o Adjust handle_function_end_breakpoint to handle negative offsets
  from compute_offset so we can get the right code component for the
  bogus lra.
---
 code/debug-int.lisp | 106 ++++++++++++++++++++++++++++++--------------
 lisp/breakpoint.c   |  88 ++++++++++++++++++++++++++++++------
 2 files changed, 148 insertions(+), 46 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 2f56f9a6a..fd6be9062 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.119 2004/11/20 00:47:28 cwang Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.120 2005/03/17 23:13:51 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3965,23 +3965,24 @@ The result is a symbol or nil if the routine cannot be found."
        (:function-start
 	(%make-breakpoint hook-function what kind info))
        (:function-end
-	(unless (eq (c::compiled-debug-function-returns
-		     (compiled-debug-function-compiler-debug-fun what))
-		    :standard)
-	  (error ":FUNCTION-END breakpoints are currently unsupported ~
-		  for the known return convention."))
-		  
-	(let* ((bpt (%make-breakpoint hook-function what kind info))
-	       (starter (compiled-debug-function-end-starter what)))
-	  (unless starter
-	    (setf starter (%make-breakpoint #'list what :function-start nil))
-	    (setf (breakpoint-hook-function starter)
-		  (function-end-starter-hook starter what))
-	    (setf (compiled-debug-function-end-starter what) starter))
-	  (setf (breakpoint-start-helper bpt) starter)
-	  (push bpt (breakpoint-%info starter))
-	  (setf (breakpoint-cookie-fun bpt) function-end-cookie)
-	  bpt))))
+	(multiple-value-bind (settable known-return)
+	    (can-set-function-end-breakpoint-p what)
+	  (cond (settable
+		 (let* ((bpt (%make-breakpoint hook-function what kind info))
+			(starter (compiled-debug-function-end-starter what)))
+		   (unless starter
+		     (setf starter (%make-breakpoint #'list what :function-start 
+						     nil))
+		     (setf (breakpoint-hook-function starter)
+			   (function-end-starter-hook starter what known-return))
+		     (setf (compiled-debug-function-end-starter what) starter))
+		   (setf (breakpoint-start-helper bpt) starter)
+		   (push bpt (breakpoint-%info starter))
+		   (setf (breakpoint-cookie-fun bpt) function-end-cookie)
+		   bpt))
+		(t
+		 (error ":FUNCTION-END breakpoints are currently unsupported ~
+		       for the known return convention.")))))))
     (interpreted-debug-function
      (error ":function-end breakpoints are currently unsupported ~
 	     for interpreted-debug-functions."))))
@@ -3989,9 +3990,14 @@ The result is a symbol or nil if the routine cannot be found."
 (defun can-set-function-end-breakpoint-p (what)
   (typecase what
     (compiled-debug-function
-     (eq (c::compiled-debug-function-returns
-	  (compiled-debug-function-compiler-debug-fun what))
-	 :standard))))
+     (let ((returns (c::compiled-debug-function-returns
+		     (compiled-debug-function-compiler-debug-fun what))))
+       ;; First value says if we can set the function-end-breakpoint.
+       ;; The second value indicates if this is the known return
+       ;; convention.
+       (values (or (eq returns :standard)
+		   (typep returns 'vector))
+	       (not (eq returns :standard)))))))
 
 ;;; These are unique objects created upon entry into a function by a
 ;;; :function-end breakpoint's starter hook.  These are only created when users
@@ -4024,7 +4030,7 @@ The result is a symbol or nil if the routine cannot be found."
 ;;; to debug-fun's function, we must establish breakpoint-data about
 ;;; fun-end-bpt.
 ;;;
-(defun function-end-starter-hook (starter-bpt debug-fun)
+(defun function-end-starter-hook (starter-bpt debug-fun &optional known-return-p)
   (declare (type breakpoint starter-bpt)
 	   (type compiled-debug-function debug-fun))
   #'(lambda (frame breakpoint)
@@ -4038,7 +4044,8 @@ The result is a symbol or nil if the routine cannot be found."
 			      (get-context-value frame
 						 #-gengc vm::lra-save-offset
 						 #+gengc vm::ra-save-offset
-						 lra-sc-offset))
+						 lra-sc-offset)
+			      known-return-p)
 	  (setf (get-context-value frame
 				   #-gengc vm::lra-save-offset
 				   #+gengc vm::ra-save-offset
@@ -4448,15 +4455,27 @@ The result is a symbol or nil if the routine cannot be found."
 	 (cookie (gethash component *function-end-cookies*)))
     (remhash component *function-end-cookies*)
     (dolist (bpt breakpoints)
-      (funcall (breakpoint-hook-function bpt)
-	       frame bpt
-	       (get-function-end-breakpoint-values scp)
-	       cookie))))
-
-(defun get-function-end-breakpoint-values (scp)
-  (let ((ocfp (system:int-sap (vm:sigcontext-register scp
-						      #-(or x86 amd64) vm::ocfp-offset
-						      #+(or x86 amd64) vm::ebx-offset)))
+      (let ((values (get-function-end-breakpoint-values bpt scp)))
+	(funcall (breakpoint-hook-function bpt) frame bpt values cookie)))))
+
+;;; Return a list of return values at the function end breakpoint
+;;; BREAKPOINT.
+;;;
+(defun get-function-end-breakpoint-values (breakpoint sigcontext)
+  (let* ((what (breakpoint-what breakpoint))
+	 (returns (c::compiled-debug-function-returns
+		   (compiled-debug-function-compiler-debug-fun what))))
+    (etypecase returns 
+      ((member :standard)
+       (function-end-breakpoint-values/standard sigcontext))
+      (vector
+       (function-end-breakpoint-values/known-return sigcontext returns)))))
+
+;;; Return a list of return values at a breakpoint with standard
+;;; return convention.
+;;; 
+(defun function-end-breakpoint-values/standard (scp)
+  (let ((ocfp (sigcontext-ocfp-sap scp))
 	(nargs (kernel:make-lisp-obj
 		(vm:sigcontext-register scp vm::nargs-offset)))
  	(reg-arg-offsets '#.vm::register-arg-offsets)
@@ -4466,13 +4485,31 @@ The result is a symbol or nil if the routine cannot be found."
        (push (if reg-arg-offsets
 		 (kernel:make-lisp-obj
 		  (vm:sigcontext-register scp (pop reg-arg-offsets)))
-	       (kernel:stack-ref ocfp arg-num))
+		 (kernel:stack-ref ocfp arg-num))
 	     results)))
     (nreverse results)))
 
+;;; Return a list of return values at a breakpoint with known-return
+;;; convention.
+;;; 
+(defun function-end-breakpoint-values/known-return (sigcontext sc-offsets)
+  (let ((ocfp (sigcontext-ocfp-sap sigcontext)))
+    (loop for offset across sc-offsets
+	  collect (sub-access-debug-var-slot ocfp offset sigcontext))))
+
+;;; Extract the old frame pointer from a sigcontext structure.  The
+;;; result is a SAP.
+;;; 
+(defun sigcontext-ocfp-sap (sigcontext)
+  (system:int-sap
+   (vm:sigcontext-register sigcontext
+			   #-(or x86 amd64) vm::ocfp-offset
+			   #+(or x86 amd64) vm::ebx-offset)))
+
 ;;;
 ;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
 ;;;
+;;; (If you change these, look in breakpoint.c too!)
 
 (defconstant bogus-lra-constants #-(or x86 amd64) 2 #+(or x86 amd64) 3)
 (defconstant known-return-p-slot (+ vm:code-constants-offset #-(or x86 amd64) 1 #+(or x86 amd64) 2))
@@ -4529,6 +4566,9 @@ The result is a symbol or nil if the routine cannot be found."
 	(logandc2 (+ vm:code-constants-offset bogus-lra-constants 1)
 		  1))
        (vm:sanctify-for-execution code-object)
+       (format t "real-lra = ~A~%" real-lra)
+       (format t "new-lra at ~A~%" dst-start)
+       (format t "offset  = ~A~%" (system:sap- trap-loc src-start))
        (values new-lra code-object (system:sap- trap-loc src-start))))))
 
 
diff --git a/lisp/breakpoint.c b/lisp/breakpoint.c
index 21aedc42a..e3468d36b 100644
--- a/lisp/breakpoint.c
+++ b/lisp/breakpoint.c
@@ -1,6 +1,6 @@
 /*
 
- $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/breakpoint.c,v 1.14 2004/07/12 23:44:07 pmai Exp $
+ $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/breakpoint.c,v 1.15 2005/03/17 23:13:55 rtoy Exp $
 
  This code was written as part of the CMU Common Lisp project at
  Carnegie Mellon University, and has been placed in the public domain.
@@ -23,6 +23,10 @@
 #include "gencgc.h"
 #endif
 
+/*
+ * See MAKE-BOGUS-LRA in code/debug-int.lisp for these values.  (We
+ * really should generate these from the Lisp code.)
+ */
 #define REAL_LRA_SLOT 0
 #ifndef i386
 #define KNOWN_RETURN_P_SLOT 1
@@ -61,7 +65,7 @@ void breakpoint_do_displaced_inst(os_context_t *scp,
     arch_do_displaced_inst(scp, orig_inst);
 }
 
-#ifndef i386
+#if !(defined(i386) || (0 && defined(sparc) && defined(GENCGC)))
 static lispobj find_code(os_context_t *scp)
 {
 #ifdef reg_CODE
@@ -82,7 +86,7 @@ static lispobj find_code(os_context_t *scp)
 }
 #endif
 
-#ifdef i386
+#if defined(i386) || (0 && defined(sparc) && defined(GENCGC))
 static lispobj find_code(os_context_t *scp)
 {
   lispobj *codeptr = component_ptr_from_pc(SC_PC(scp));
@@ -94,7 +98,7 @@ static lispobj find_code(os_context_t *scp)
 }
 #endif
 
-static int compute_offset(os_context_t *scp, lispobj code)
+static int compute_offset(os_context_t *scp, lispobj code, boolean function_end)
 {
     if (code == NIL)
 	return 0;
@@ -113,10 +117,31 @@ static int compute_offset(os_context_t *scp, lispobj code)
 	    return 0;
 	else {
 	    int offset = pc - code_start;
-	    if (offset >= codeptr->code_size)
+	    if (offset >= codeptr->code_size) {
+              if (function_end) {
+#ifdef sparc
+                /*
+                 * We're in a function end breakpoint.  Compute the
+                 * offset from the (known) breakpoint location and the
+                 * beginning of the breakpoint guts.  (See *-assem.S.)
+                 *
+                 * Then make the offset negative so the caller knows
+                 * that the offset is not from the code object.
+                 */
+                extern char function_end_breakpoint_trap;
+                extern char function_end_breakpoint_guts;
+
+                offset = &function_end_breakpoint_trap - &function_end_breakpoint_guts;
+                return make_fixnum(-offset);
+#else
+                return 0;
+#endif                
+              } else {
 		return 0;
-	    else
-		return make_fixnum(offset);
+              }
+	    } else {
+              return make_fixnum(offset);
+            }
 	}
     }
 }
@@ -131,7 +156,7 @@ void handle_breakpoint(int signal, int subcode, os_context_t *scp)
     code = find_code(scp);
 
     funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
+	     compute_offset(scp, code, 0),
 	     code,
 	     alloc_sap(scp));
 
@@ -157,7 +182,7 @@ void handle_breakpoint(int signal, int subcode, os_context_t *scp)
     sigsetmask(scp->sc_mask);
 #endif
     funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
+	     compute_offset(scp, code, 0),
 	     code,
 	     scp_sap);
 
@@ -171,19 +196,56 @@ void *handle_function_end_breakpoint(int signal, int subcode,
 {
     lispobj code, lra;
     struct code *codeptr;
-
+    int offset;
+    
     fake_foreign_function_call(scp);
 
     code = find_code(scp);
     codeptr = (struct code *)PTR(code);
-
+    offset = compute_offset(scp, code, 1);
+
+    if (offset < 0)
+      {
+        /*
+         * We were in the function end breakpoint.  Which means we are
+         * in a bogus LRA, so compute where the code-component of this
+         * bogus lra object starts.  Adjust code, and codeptr
+         * appropriately so the breakpoint handler can do the right
+         * thing.
+         */
+        unsigned long pc;
+
+        pc = SC_PC(scp);
+        
+        offset = -offset;
+        /*
+         * Some magic here.  pc points to the trap instruction.  The
+         * offset gives us where the function_end_breakpoint_guts
+         * begins.  But we need to back up some more to get to the
+         * code-component object.  The magic 2 below is 
+         */
+        code = pc - fixnum_value(offset);
+        code -= sizeof(struct code) + BOGUS_LRA_CONSTANTS*sizeof(lispobj);
+        code += type_OtherPointer;
+        codeptr = (struct code *) PTR(code);
+      }
+    
     funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
+	     offset,
 	     code,
 	     alloc_sap(scp));
 
+    /*
+     * Breakpoint handling done, so get the real LRA where we're
+     * supposed to return to so we can return there.
+     */
     lra = codeptr->constants[REAL_LRA_SLOT];
 #ifdef reg_CODE
+    /*
+     * With the known-return convention, we definitely do NOT want to
+     * mangle the CODE register because it isn't pointing to the bogus
+     * LRA but to the actual routine.
+     */
     if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
 	SC_REG(scp, reg_CODE) = lra;
 #endif
@@ -213,7 +275,7 @@ void *handle_function_end_breakpoint(int signal, int subcode,
     sigsetmask(scp->sc_mask);
 #endif
     funcall3(SymbolFunction(HANDLE_BREAKPOINT),
-	     compute_offset(scp, code),
+	     compute_offset(scp, code, 1),
 	     code,
 	     scp_sap);
 
-- 
GitLab