From 201d5402cb4618408b42bc23de96a7de762b953b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Wed, 19 Aug 1992 02:53:18 +0000 Subject: [PATCH] Instead of doing after breakpoints ourselves, use the new C function breakpoint_do_displaced_inst to do all that noise. That way the C code can do different things on different machines (like use single stepping if available). --- code/debug-int.lisp | 211 +++++++++++--------------------------------- 1 file changed, 52 insertions(+), 159 deletions(-) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 960fde37a..0c5a2b5d9 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: completion; Log: code.log; Package: debug-internals -*- +;;; -*- Mode: completion; Log: code.log; Package: DI -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.51 1992/07/09 19:26:13 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.52 1992/08/19 02:53:18 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -594,15 +594,8 @@ ;; The original instruction replaced by the breakpoint. (instruction nil :type (or null (unsigned-byte 32))) ;; - ;; This saves the sigmask while we execute the instruction replaced by - ;; a user break. When we hit the after-breakpoint, we restore this mask. - (sigmask nil :type (or null (unsigned-byte 32))) - ;; ;; A list of user breakpoints at this location. - (breakpoints nil :type list) - ;; - ;; An after-breakpoint might be at this location too. - (after-breakpoint nil :type (or null after-breakpoint))) + (breakpoints nil :type list)) ;;; (defun print-breakpoint-data (obj str n) (declare (ignore n)) @@ -682,34 +675,6 @@ (setf (documentation 'breakpoint-kind 'function) "Returns the breakpoint's kind specification.") -;;; This is an internal structure. -;;; -(defstruct (after-breakpoint (:print-function print-after-breakpoint) - (:constructor - make-after-breakpoint - (previous-data internal-data &optional partner))) - ;; - ;; This is the data for the location which this after-breakpoint follows. - ;; When execution flows through this after-breakpoint, the breakpoint - ;; mechanism re-establishes the break instruction at this location, and - ;; replaces the after-breakpoint's break instruction with the instruction - ;; that should run as part of the original program. - (previous-data nil :type breakpoint-data) - ;; - ;; This is a backpointer to a breakpoint-data. - (internal-data nil :type (or null breakpoint-data)) - ;; - ;; When breakpoint is where a branching instruction used to be, partner is an - ;; after-breakpoint at the other code location at which execution could have - ;; gone. In addition to what is describe for the previous slot, the - ;; breakpoint mechanism has to remove partner as well as this - ;; after-breakpoint. - (partner nil :type (or null after-breakpoint))) - -(defun print-after-breakpoint (obj str n) - (declare (ignore obj n)) - (format str "#<After-Breakpoint ...>")) - ;;; ;;; Code-locations. ;;; @@ -3271,13 +3236,9 @@ (pc-offset c-call:int) (old-inst c-call:unsigned-long)) -;;; BREAKPOINT-AFTER-OFFSET -- Internal. -;;; -;;; This returns the offset of the next instruction following the break that -;;; generated the signal context we supply as an argument to this routine. -;;; -(alien:def-alien-routine "breakpoint_after_offset" c-call:int - (scp system:system-area-pointer)) +(alien:def-alien-routine "breakpoint_do_displaced_inst" c-call:void + (scp (* unix:sigcontext)) + (orig-inst c-call:unsigned-long)) ;;; ;;; Breakpoint handlers (layer between C and exported interface). @@ -3329,15 +3290,16 @@ ;;; handle breaks for internal errors. ;;; (defun handle-breakpoint (offset component signal-context) - (let ((data (breakpoint-data component offset))) + (let ((data (breakpoint-data component offset nil))) (unless data (error "Unknown breakpoint in ~S at offset ~S." (debug-function-name (debug-function-from-pc component offset)) offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) - (if (and breakpoints - (eq (breakpoint-kind (car breakpoints)) :function-end)) - (handle-function-end-breakpoint breakpoints data signal-context) + (unless breakpoints + (error "Breakpoint that nobody wants?")) + (if (eq (breakpoint-kind (car breakpoints)) :function-end) + (handle-function-end-breakpoint-aux breakpoints data signal-context) (handle-breakpoint-aux breakpoints data offset component signal-context))))) @@ -3354,69 +3316,26 @@ ;;; This handles code-location and debug-function :function-start breakpoints. ;;; (defun handle-breakpoint-aux (breakpoints data offset component signal-context) - (let ((after (breakpoint-data-after-breakpoint data))) - (when after - (handle-after-breakpoint after breakpoints data offset component))) - - (when breakpoints - (unless (member data *executing-breakpoint-hooks*) - (let ((*executing-breakpoint-hooks* (cons data - *executing-breakpoint-hooks*))) - (invoke-breakpoint-hooks breakpoints component offset))) - ;; At this point breakpoints may not hold the same list as - ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed a - ;; breakpoint deactivation. In fact, if all breakpoints were deactivated - ;; then data is invalid since it was deleted and so the correct one must be - ;; looked up if it is to be used. If there are no more breakpoints active - ;; at this location, then the normal instruction has been put back, and we - ;; do not need an after breakpoint to re-install a break instruction. - (setf data (breakpoint-data component offset nil)) - (when (and data - (breakpoint-data-breakpoints data)) - ;; Restore instruction. Do this before SET-AFTER-BREAKPOINTS which - ;; uses CALL-BREAKPOINT-AFTER-OFFSET. - (system:without-gcing - (breakpoint-remove (kernel:get-lisp-obj-address component) offset - (breakpoint-data-instruction data))) - (set-after-breakpoints component data signal-context) - ;; Set the sigmask, to keep the system running until we can - ;; remove the after breakpoints and re-install the user breakpoints. - (setf (breakpoint-data-sigmask data) - (unix:unix-sigblock (unix:sigmask :sigint :sigquit :sigtstp)))))) - -(defun handle-after-breakpoint (after breakpoints data offset component) - (let ((previous-data (after-breakpoint-previous-data after))) - (unless (breakpoint-data-breakpoints previous-data) - (error "After-breakpoint found with no user breakpoints. -- ~s" after)) - ;; If there are no user breakpoints at this after location, remove the - ;; break instruction. - (unless breakpoints - (system:without-gcing - (breakpoint-remove (kernel:get-lisp-obj-address component) offset - (breakpoint-data-instruction data))) - (setf (breakpoint-data-after-breakpoint data) nil) - (delete-breakpoint-data data)) - ;; Ditto for the partner of the after-breakpoint (if there were two). - (let ((partner (after-breakpoint-partner after))) - (when partner - (let ((partner-data (after-breakpoint-internal-data partner))) - (unless (breakpoint-data-breakpoints partner-data) - (system:without-gcing - (breakpoint-remove (kernel:get-lisp-obj-address - (breakpoint-data-component partner-data)) - (breakpoint-data-offset partner-data) - (breakpoint-data-instruction partner-data))) - (setf (breakpoint-data-after-breakpoint partner-data) nil) - (delete-breakpoint-data partner-data))))) - ;; Put back previous's break instruction. - ;; We don't need to store the replaced instruction in the data since we - ;; have it from installing the break instruction before. - (system:without-gcing - (breakpoint-install (kernel:get-lisp-obj-address - (breakpoint-data-component previous-data)) - (breakpoint-data-offset previous-data))) - ;; Restore sigmask that we saved before executing previous's inst. - (unix:unix-sigsetmask (breakpoint-data-sigmask previous-data)))) + (unless (member data *executing-breakpoint-hooks*) + (let ((*executing-breakpoint-hooks* (cons data + *executing-breakpoint-hooks*))) + (invoke-breakpoint-hooks breakpoints component offset))) + ;; At this point breakpoints may not hold the same list as + ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed a + ;; breakpoint deactivation. In fact, if all breakpoints were deactivated + ;; then data is invalid since it was deleted and so the correct one must be + ;; looked up if it is to be used. If there are no more breakpoints active + ;; at this location, then the normal instruction has been put back, and we + ;; do not need to do-displaced-inst. + (let ((data (breakpoint-data component offset nil))) + (when (and data (breakpoint-data-breakpoints data)) + ;; There breakpoint is still active, so we need to execute the displaced + ;; instruction and leave the breakpoint instruction behind. The best + ;; way to do this is different on each machine, so we just leave it up + ;; to the C code. + (breakpoint-do-displaced-inst signal-context + (breakpoint-data-instruction data)) + (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) (let* ((debug-fun (debug-function-from-pc component offset)) @@ -3433,35 +3352,26 @@ (breakpoint-unknown-return-partner bpt) bpt))))) -(defun set-after-breakpoints (component data signal-context) - (multiple-value-bind (after-1 after-2) - (call-breakpoint-after-offset signal-context) - (let* ((after-data-1 (breakpoint-data component after-1)) - (after-data-2 (if (not (zerop after-2)) - (breakpoint-data component after-2))) - (after-bpt-1 (make-after-breakpoint data after-data-1))) - (setf (breakpoint-data-after-breakpoint after-data-1) after-bpt-1) - (when after-data-2 - ;; Set after-bpt-1's partner to an after-breakpoint. - (setf (after-breakpoint-partner after-bpt-1) - ;; While making it, store it in the appropriate data obj. - (setf (breakpoint-data-after-breakpoint after-data-2) - (make-after-breakpoint data after-data-2 after-bpt-1)))) - (system:without-gcing - (unless (breakpoint-data-breakpoints after-data-1) - (setf (breakpoint-data-instruction after-data-1) - (breakpoint-install (kernel:get-lisp-obj-address component) - after-1))) - (when (and after-data-2 (not (breakpoint-data-breakpoints after-data-2))) - (setf (breakpoint-data-instruction after-data-2) - (breakpoint-install (kernel:get-lisp-obj-address component) - after-2))))))) - -;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal. -;;; -;;; HANDLE-BREAKPOINT calls this for :function-end breakpoints. -;;; -(defun handle-function-end-breakpoint (breakpoints data signal-context) +;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal Interface +;;; +(defun handle-function-end-breakpoint (offset component signal-context) + (let ((data (breakpoint-data component offset nil))) + (unless data + (error "Unknown breakpoint in ~S at offset ~S." + (debug-function-name (debug-function-from-pc component offset)) + offset)) + (let ((breakpoints (breakpoint-data-breakpoints data))) + (unless breakpoints + (error "Breakpoint that nobody wants?")) + (assert (eq (breakpoint-kind (car breakpoints)) :function-end)) + (handle-function-end-breakpoint-aux breakpoints data signal-context)))) + +;;; HANDLE-FUNCTION-END-BREAKPOINT-AUX -- Internal. +;;; +;;; Either HANDLE-BREAKPOINT calls this for :function-end breakpoints [old C +;;; code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly [new C code]. +;;; +(defun handle-function-end-breakpoint-aux (breakpoints data signal-context) (delete-breakpoint-data data) (let* ((scp (alien:sap-alien signal-context (* unix:sigcontext))) (frame (do ((cfp (vm:sigcontext-register scp vm::cfp-offset)) @@ -3481,7 +3391,7 @@ (let ((ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset))) (nargs (kernel:make-lisp-obj (vm:sigcontext-register scp vm::nargs-offset))) - (reg-arg-offsets vm::register-arg-offsets) + (reg-arg-offsets '#.vm::register-arg-offsets) (results nil)) (system:without-gcing (dotimes (arg-num nargs) @@ -3492,23 +3402,6 @@ results))) (nreverse results))) - -;;; CALL-BREAKPOINT-AFTER-OFFSET -- Internal. -;;; -;;; This calls the C routine and massages its return values. Originally the -;;; breakpoint code was designed for the C code to return multiple offsets when -;;; the break generating the argument signal-context had replaced a branch -;;; instruction. The Lisp code would then set after-breakpoints at each -;;; location, cleaning up both when one was hit after continuing execution. -;;; Later the C code decided it could determine which way the branch would go, -;;; so BREAKPOINT-AFTER-OFFSET could just return one offset. In case this -;;; won't be possible on all platforms, the Lisp code will stay with its -;;; support for multiple after-breakpoints. Then we only need to change this -;;; routine to return all values of BREAKPOINT-AFTER-OFFSET. -;;; -(defun call-breakpoint-after-offset (signal-context) - (values (breakpoint-after-offset signal-context) 0)) - ;;; ;;; MAKE-BOGUS-LRA (used for :function-end breakpoints) ;;; -- GitLab