diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 2f56f9a6a848a1e973824ed29e4dcc09b1ca33a7..fd6be906283077f9c4da664b0baf0778e3dedadb 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 21aedc42aca470c9add63abf5dd9397ee065431e..e3468d36bf27079a51515d2cb0a59dbb4594f42a 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);