Skip to content
Snippets Groups Projects
Commit 8dbaed74 authored by wlott's avatar wlott
Browse files

Instead of using a hash table to map from compiled-debug-functions to the

corresponding :function-end breakpoint start-helper, use a slot in the
c-d-f structure.

Added a :unknown-return-partner kind of breakpoint, which is used
internally to mark the partner breakpoint for :unknown-return
code-locations.

Changed MAKE-COMPILED-CODE-LOCATION to be called MAKE-KNOWN-CODE-LOCATION
because that is what it was doing.  Also, made the optional args required,
because they really are.

Changed MAKE-UNKNOWN-CODE-LOCATION to be called MAKE-COMPILED-CODE-LOCATION,
because it is not known to be unknown (i.e. :unsure).

Changed CODE-LOCATION-FROM-PC to check to see if there is a breakpoint
installed at that pc.  If so, use the code-location from that breakpoint.
Otherwise, make an :unsure unknown-p code-location so it can be filled in
if needed.

Fixed FRAME-CATCHES to take into account the code components header length
when computing the pc offset for the :nlx-entry code location.

Fixed code-location breakpoints to correctly handle :unknown-return and
:single-value-return code-locations.
parent eb6fbbcc
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.44 1992/05/18 19:57:03 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.45 1992/05/24 01:52:22 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -431,7 +431,11 @@ ...@@ -431,7 +431,11 @@
(compiler-debug-fun nil :type c::compiled-debug-function) (compiler-debug-fun nil :type c::compiled-debug-function)
;; ;;
;; Code object. (unexported). ;; Code object. (unexported).
component) component
;;
;; The :function-start breakpoint (if any) used to facilitate function
;; end breakpoints.
(end-starter nil :type (or null breakpoint)))
;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we ;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we
;;; can get at cached stuff and not duplicate compiled-debug-function ;;; can get at cached stuff and not duplicate compiled-debug-function
...@@ -622,8 +626,11 @@ ...@@ -622,8 +626,11 @@
;; Code-location or debug-function. ;; Code-location or debug-function.
(what nil :type (or code-location debug-function)) (what nil :type (or code-location debug-function))
;; ;;
;; :code-location, :function-start, or :function-end. ;; :code-location, :function-start, or :function-end for that kind of
(kind nil :type (member :code-location :function-start :function-end)) ;; breakpoint. :unknown-return-partner if this is the partner of a
;; :code-location breakpoint at an :unknown-return code-location.
(kind nil :type (member :code-location :function-start :function-end
:unknown-return-partner))
;; ;;
;; Status helps the user and the implementation. ;; Status helps the user and the implementation.
(status :inactive :type (member :active :inactive :deleted)) (status :inactive :type (member :active :inactive :deleted))
...@@ -631,11 +638,10 @@ ...@@ -631,11 +638,10 @@
;; This is a backpointer to a breakpoint-data. ;; This is a backpointer to a breakpoint-data.
(internal-data nil :type (or null breakpoint-data)) (internal-data nil :type (or null breakpoint-data))
;; ;;
;; With code-locations whose type is :unknown-return, execution flows through ;; With code-locations whose type is :unknown-return, there are really
;; starting at one of two instructions. In this situation, we make two ;; two breakpoints: one at the multiple-value entry point, and one at
;; breakpoints, giving the user one, and link them together through this ;; the single-value entry point. This slot holds the breakpoint for the
;; slot. If execution goes from one instruction to the other, we must make ;; other one, or NIL if this isn't at an :unknown-return code location.
;; sure we only invoke the hook-functions once.
(unknown-return-partner nil :type (or null breakpoint)) (unknown-return-partner nil :type (or null breakpoint))
;; ;;
;; :function-end breakpoints use a breakpoint at the :function-start to ;; :function-end breakpoints use a breakpoint at the :function-start to
...@@ -753,13 +759,10 @@ ...@@ -753,13 +759,10 @@
(defstruct (compiled-code-location (defstruct (compiled-code-location
(:include code-location) (:include code-location)
(:constructor make-compiled-code-location (:constructor make-known-code-location
(pc debug-function &optional (pc debug-function %tlf-offset %form-number
%tlf-offset %form-number %live-set kind %live-set kind &aux (%unknown-p nil)))
;; Any optional means it's known. (:constructor make-compiled-code-location (pc debug-function)))
(%unknown-p (not kind))))
(:constructor make-unknown-code-location
(pc debug-function &aux (%unknown-p :unsure))))
;; ;;
;; This is an index into debug-function's component slot. ;; This is an index into debug-function's component slot.
(pc nil :type c::index) (pc nil :type c::index)
...@@ -1165,19 +1168,22 @@ ...@@ -1165,19 +1168,22 @@
;;; CODE-LOCATION-FROM-PC -- Internal. ;;; CODE-LOCATION-FROM-PC -- Internal.
;;; ;;;
;;; This returns a code-location for the compiled-debug-function, debug-fun, ;;; This returns a code-location for the compiled-debug-function, debug-fun,
;;; and the pc into its code vector. If there is debug-block info, we assume ;;; and the pc into its code vector. If we stopped at a breakpoint, find
;;; the code-location is known by making a default one. It may later prove ;;; the code-location for that breakpoint. Otherwise, make an :unsure code
;;; to be unknown as :unparsed slots are accessed. Code locations in bogus ;;; location, so it can be filled in when we figure out what is going on.
;;; debug funs are always unknown.
;;; ;;;
(defun code-location-from-pc (debug-fun pc escaped) (defun code-location-from-pc (debug-fun pc escaped)
(if (and (compiled-debug-function-p debug-fun) (or (and (compiled-debug-function-p debug-fun)
(c::compiled-debug-function-blocks escaped
(compiled-debug-function-compiler-debug-fun debug-fun)) (let ((data (breakpoint-data
(not escaped)) (compiled-debug-function-component debug-fun)
(make-compiled-code-location pc debug-fun) pc nil)))
(make-unknown-code-location pc debug-fun))) (when (and data (breakpoint-data-breakpoints data))
(let ((what (breakpoint-what
(first (breakpoint-data-breakpoints data)))))
(when (compiled-code-location-p what)
what)))))
(make-compiled-code-location pc debug-fun)))
;;; FRAME-CATCHES -- Public. ;;; FRAME-CATCHES -- Public.
;;; ;;;
...@@ -1195,17 +1201,19 @@ ...@@ -1195,17 +1201,19 @@
(* (kernel:stack-ref catch vm:catch-block-current-cont-slot) (* (kernel:stack-ref catch vm:catch-block-current-cont-slot)
vm:word-bytes))) vm:word-bytes)))
(let* ((lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot)) (let* ((lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot))
(word-offset (kernel:get-header-data lra))) (component
(kernel:stack-ref catch vm:catch-block-current-code-slot))
(word-offset (- (1+ (kernel:get-header-data lra))
(kernel:get-header-data component))))
(push (cons (kernel:stack-ref catch vm:catch-block-tag-slot) (push (cons (kernel:stack-ref catch vm:catch-block-tag-slot)
(make-compiled-code-location (make-compiled-code-location
(* word-offset vm:word-bytes) (* word-offset vm:word-bytes)
(frame-debug-function frame))) (frame-debug-function frame)))
res))) res)))
(setf catch (setf catch
(system:int-sap (system:sap-ref-sap catch
(* (kernel:stack-ref catch (* vm:catch-block-previous-catch-slot
vm:catch-block-previous-catch-slot) vm:word-bytes))))))
vm:word-bytes))))))
;;; FRAME-REAL-FRAME -- Internal. ;;; FRAME-REAL-FRAME -- Internal.
;;; ;;;
...@@ -1755,7 +1763,7 @@ ...@@ -1755,7 +1763,7 @@
(form-number (c::read-var-integer blocks i)) (form-number (c::read-var-integer blocks i))
(live-set (c::read-packed-bit-vector (live-set (c::read-packed-bit-vector
live-set-len blocks i))) live-set-len blocks i)))
(vector-push-extend (make-compiled-code-location (vector-push-extend (make-known-code-location
pc debug-function tlf-offset pc debug-function tlf-offset
form-number live-set kind) form-number live-set kind)
locations-buffer) locations-buffer)
...@@ -2253,7 +2261,8 @@ ...@@ -2253,7 +2261,8 @@
(interpreted-code-location-ir1-node obj2))))))) (interpreted-code-location-ir1-node obj2)))))))
;;; ;;;
(defun sub-compiled-code-location= (obj1 obj2) (defun sub-compiled-code-location= (obj1 obj2)
(= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) (= (compiled-code-location-pc obj1)
(compiled-code-location-pc obj2)))
;;; FILL-IN-CODE-LOCATION -- Internal. ;;; FILL-IN-CODE-LOCATION -- Internal.
;;; ;;;
...@@ -2264,6 +2273,7 @@ ...@@ -2264,6 +2273,7 @@
;;; set or going to be set. ;;; set or going to be set.
;;; ;;;
(defun fill-in-code-location (code-location) (defun fill-in-code-location (code-location)
(declare (type compiled-code-location code-location))
(let* ((debug-function (code-location-debug-function code-location)) (let* ((debug-function (code-location-debug-function code-location))
(blocks (debug-function-debug-blocks debug-function))) (blocks (debug-function-debug-blocks debug-function)))
(declare (simple-vector blocks)) (declare (simple-vector blocks))
...@@ -2869,17 +2879,6 @@ ...@@ -2869,17 +2879,6 @@
;;; User visible interface. ;;; User visible interface.
;;; ;;;
;;; This maps debug-functions, for which there are :function-end breakpoints,
;;; to internal starter breakpoints that actually establish the :function-end
;;; breakpoint upon entry to the routine. We want these starter breakpoints to
;;; be unique for every routine regardless of how many :function-end
;;; breakpoints exist. Otherwise, we can't support multiple :function-end
;;; breakpoints. These starter breakpoints' info slot points to a list of
;;; :function-end breakpoints that use them, and upon deletion of the last such
;;; breakpoint, we remove the starter from this table.
;;;
(defvar *function-end-debug-funs* (make-hash-table :test #'eq))
(defun make-breakpoint (hook-function what (defun make-breakpoint (hook-function what
&key (kind :code-location) info function-end-cookie) &key (kind :code-location) info function-end-cookie)
"This creates and returns a breakpoint. When program execution encounters "This creates and returns a breakpoint. When program execution encounters
...@@ -2918,7 +2917,9 @@ ...@@ -2918,7 +2917,9 @@
(compiled-code-location (compiled-code-location
;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
(when (eq (compiled-code-location-kind what) :unknown-return) (when (eq (compiled-code-location-kind what) :unknown-return)
(let ((other-bpt (%make-breakpoint hook-function what kind info))) (let ((other-bpt (%make-breakpoint hook-function what
:unknown-return-partner
info)))
(setf (breakpoint-unknown-return-partner bpt) other-bpt) (setf (breakpoint-unknown-return-partner bpt) other-bpt)
(setf (breakpoint-unknown-return-partner other-bpt) bpt))))) (setf (breakpoint-unknown-return-partner other-bpt) bpt)))))
bpt)) bpt))
...@@ -2928,12 +2929,12 @@ ...@@ -2928,12 +2929,12 @@
(%make-breakpoint hook-function what kind info)) (%make-breakpoint hook-function what kind info))
(:function-end (:function-end
(let* ((bpt (%make-breakpoint hook-function what kind info)) (let* ((bpt (%make-breakpoint hook-function what kind info))
(starter (gethash what *function-end-debug-funs*))) (starter (compiled-debug-function-end-starter what)))
(unless starter (unless starter
(setf starter (%make-breakpoint #'list what :function-start nil)) (setf starter (%make-breakpoint #'list what :function-start nil))
(setf (breakpoint-hook-function starter) (setf (breakpoint-hook-function starter)
(function-end-starter-hook starter what)) (function-end-starter-hook starter what))
(setf (gethash what *function-end-debug-funs*) starter)) (setf (compiled-debug-function-end-starter what) starter))
(setf (breakpoint-start-helper bpt) starter) (setf (breakpoint-start-helper bpt) starter)
(push bpt (breakpoint-%info starter)) (push bpt (breakpoint-%info starter))
(setf (breakpoint-cookie-fun bpt) function-end-cookie) (setf (breakpoint-cookie-fun bpt) function-end-cookie)
...@@ -3072,11 +3073,18 @@ ...@@ -3072,11 +3073,18 @@
(defun activate-compiled-code-location-breakpoint (breakpoint) (defun activate-compiled-code-location-breakpoint (breakpoint)
(declare (type breakpoint breakpoint)) (declare (type breakpoint breakpoint))
(let ((loc (breakpoint-what breakpoint))) (let ((loc (breakpoint-what breakpoint)))
(declare (type compiled-code-location loc))
(sub-activate-breakpoint (sub-activate-breakpoint
breakpoint breakpoint
(breakpoint-data (compiled-debug-function-component (breakpoint-data (compiled-debug-function-component
(code-location-debug-function loc)) (code-location-debug-function loc))
(compiled-code-location-pc loc))))) (+ (compiled-code-location-pc loc)
(if (or (eq (breakpoint-kind breakpoint)
:unknown-return-partner)
(eq (compiled-code-location-kind loc)
:single-value-return))
vm:single-value-return-byte-offset
0))))))
;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal. ;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal.
;;; ;;;
...@@ -3114,79 +3122,41 @@ ...@@ -3114,79 +3122,41 @@
;;; ;;;
(defun deactivate-breakpoint (breakpoint) (defun deactivate-breakpoint (breakpoint)
"This stops the system from invoking the breakpoint's hook-function." "This stops the system from invoking the breakpoint's hook-function."
(unless (eq (breakpoint-status breakpoint) :inactive) (when (eq (breakpoint-status breakpoint) :active)
(system:without-interrupts (system:without-interrupts
(ecase (breakpoint-kind breakpoint) (let ((loc (breakpoint-what breakpoint)))
(:code-location (etypecase loc
(let ((loc (breakpoint-what breakpoint))) ((or interpreted-code-location interpreted-debug-function)
(etypecase loc (error
(interpreted-code-location "Breakpoints in interpreted code are currently unsupported."))
(error ((or compiled-code-location compiled-debug-function)
"Breakpoints in interpreted code are currently unsupported.")) (deactivate-compiled-breakpoint breakpoint)
(compiled-code-location (let ((other (breakpoint-unknown-return-partner breakpoint)))
(deactivate-compiled-code-location-breakpoint breakpoint) (when other
(let ((other (breakpoint-unknown-return-partner breakpoint))) (deactivate-compiled-breakpoint other))))))))
(when other
(deactivate-compiled-code-location-breakpoint other)))))))
(:function-start
(etypecase (breakpoint-what breakpoint)
(compiled-debug-function
(deactivate-compiled-function-start-breakpoint breakpoint))
(interpreted-debug-function
(error ":function-start breakpoints for interpreted-debug-functions ~
are unsupported currently -- ~S."
breakpoint))))
(:function-end
(etypecase (breakpoint-what breakpoint)
(compiled-debug-function
(let ((starter (breakpoint-start-helper breakpoint)))
(unless (find-if #'(lambda (bpt)
(and (not (eq bpt breakpoint))
(eq (breakpoint-status bpt) :active)))
(breakpoint-%info starter))
(deactivate-compiled-function-start-breakpoint starter)))
(setf (breakpoint-status breakpoint) :inactive))
(interpreted-debug-function
(error ":function-end breakpoints for interpreted-debug-functions ~
are unsupported currently -- ~S."
breakpoint)))))))
breakpoint) breakpoint)
;;; DEACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal. (defun deactivate-compiled-breakpoint (breakpoint)
;;; (if (eq (breakpoint-kind breakpoint) :function-end)
(defun deactivate-compiled-code-location-breakpoint (breakpoint) (let ((starter (breakpoint-start-helper breakpoint)))
(declare (type breakpoint breakpoint)) (unless (find-if #'(lambda (bpt)
(let* ((loc (breakpoint-what breakpoint)) (and (not (eq bpt breakpoint))
(component (compiled-debug-function-component (eq (breakpoint-status bpt) :active)))
(code-location-debug-function loc))) (breakpoint-%info starter))
(offset (compiled-code-location-pc loc))) (deactivate-compiled-breakpoint starter)))
(sub-deactivate-breakpoint breakpoint (breakpoint-data component offset) (let* ((data (breakpoint-internal-data breakpoint))
component offset))) (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
(setf (breakpoint-internal-data breakpoint) nil)
;;; DEACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal. (setf (breakpoint-data-breakpoints data) bpts)
;;; (unless bpts
(defun deactivate-compiled-function-start-breakpoint (breakpoint) (system:without-gcing
(declare (type breakpoint breakpoint)) (breakpoint-remove (kernel:get-lisp-obj-address
(let* ((debug-fun (breakpoint-what breakpoint)) (breakpoint-data-component data))
(component (compiled-debug-function-component debug-fun)) (breakpoint-data-offset data)
(offset (c::compiled-debug-function-start-pc (breakpoint-data-instruction data)))
(compiled-debug-function-compiler-debug-fun debug-fun)))) (delete-breakpoint-data data))))
(sub-deactivate-breakpoint breakpoint (breakpoint-data component offset) (setf (breakpoint-status breakpoint) :inactive)
component offset))) breakpoint)
;;; SUB-DEACTIVATE-BREAKPOINT -- Internal.
;;;
(defun sub-deactivate-breakpoint (breakpoint data component offset)
(declare (type breakpoint breakpoint)
(type breakpoint-data data)
(type c::index offset))
(let ((bpts (delete breakpoint (breakpoint-data-breakpoints data))))
(unless bpts
(system:without-gcing
(breakpoint-remove (kernel:get-lisp-obj-address component)
offset (breakpoint-data-instruction data))))
(setf (breakpoint-data-breakpoints data) bpts))
(setf (breakpoint-status breakpoint) :inactive))
;;; ;;;
;;; BREAKPOINT-INFO. ;;; BREAKPOINT-INFO.
...@@ -3227,25 +3197,22 @@ ...@@ -3227,25 +3197,22 @@
never become active again." never become active again."
(let ((status (breakpoint-status breakpoint))) (let ((status (breakpoint-status breakpoint)))
(unless (eq status :deleted) (unless (eq status :deleted)
(ecase status (when (eq status :active)
(:active (deactivate-breakpoint breakpoint))
(setf (breakpoint-status breakpoint) :deleted) (setf (breakpoint-status breakpoint) :deleted)
(deactivate-breakpoint breakpoint) (let ((other (breakpoint-unknown-return-partner breakpoint)))
(let ((other (breakpoint-unknown-return-partner breakpoint))) (when other
(when other (setf (breakpoint-status other) :deleted)))
(setf (breakpoint-status other) :deleted))))
(:inactive
(setf (breakpoint-status breakpoint) :deleted)
(let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other
(setf (breakpoint-status other) :deleted)))))
(when (eq (breakpoint-kind breakpoint) :function-end) (when (eq (breakpoint-kind breakpoint) :function-end)
(let* ((debug-fun (breakpoint-what breakpoint)) (let* ((starter (breakpoint-start-helper breakpoint))
(starter (gethash debug-fun *function-end-debug-funs*))) (breakpoints (delete breakpoint
(setf (breakpoint-info starter) (the list (breakpoint-info starter)))))
(delete breakpoint (the list (breakpoint-info starter)))) (setf (breakpoint-info starter) breakpoints)
(when (zerop (length (the list (breakpoint-%info starter)))) (unless breakpoints
(remhash debug-fun *function-end-debug-funs*)))))) (delete-breakpoint starter)
(setf (compiled-debug-function-end-starter
(breakpoint-what breakpoint))
nil))))))
breakpoint) breakpoint)
;;; ;;;
...@@ -3294,12 +3261,13 @@ ...@@ -3294,12 +3261,13 @@
;;; This returns the breakpoint-data associated with component cross offset. ;;; This returns the breakpoint-data associated with component cross offset.
;;; If none exists, this makes one, installs it, and returns it. ;;; If none exists, this makes one, installs it, and returns it.
;;; ;;;
(defun breakpoint-data (component offset) (defun breakpoint-data (component offset &optional (create t))
(flet ((install-breakpoint-data () (flet ((install-breakpoint-data ()
(let ((data (make-breakpoint-data component offset))) (when create
(push (cons offset data) (let ((data (make-breakpoint-data component offset)))
(gethash component *component-breakpoint-offsets*)) (push (cons offset data)
data))) (gethash component *component-breakpoint-offsets*))
data))))
(let ((offsets (gethash component *component-breakpoint-offsets*))) (let ((offsets (gethash component *component-breakpoint-offsets*)))
(if offsets (if offsets
(let ((data (assoc offset offsets))) (let ((data (assoc offset offsets)))
...@@ -3310,13 +3278,18 @@ ...@@ -3310,13 +3278,18 @@
;;; DELETE-BREAKPOINT-DATA -- Internal. ;;; DELETE-BREAKPOINT-DATA -- Internal.
;;; ;;;
;;; We use this for :function-end breakpoints which use fake components that ;;; We use this when there are no longer any active breakpoints corresponding
;;; exist only from the start of the function until we hit the end breakpoint. ;;; to data.
;;; ;;;
(defun delete-breakpoint-data (data) (defun delete-breakpoint-data (data)
(setf (gethash (breakpoint-data-component data) (let* ((component (breakpoint-data-component data))
*component-breakpoint-offsets*) (offsets (delete (breakpoint-data-offset data)
nil)) (gethash component *component-breakpoint-offsets*)
:key #'car)))
(if offsets
(setf (gethash component *component-breakpoint-offsets*) offsets)
(remhash component *component-breakpoint-offsets*)))
(ext:undefined-value))
;;; HANDLE-BREAKPOINT -- Internal Interface. ;;; HANDLE-BREAKPOINT -- Internal Interface.
;;; ;;;
...@@ -3352,28 +3325,28 @@ ...@@ -3352,28 +3325,28 @@
(defun handle-breakpoint-aux (breakpoints data offset component signal-context) (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
(let ((after (breakpoint-data-after-breakpoint data))) (let ((after (breakpoint-data-after-breakpoint data)))
(when after (when after
(handle-after-breakpoint after breakpoints data offset component)) (handle-after-breakpoint after breakpoints data offset component)))
(when breakpoints (when breakpoints
(unless (member data *executing-breakpoint-hooks*) (unless (member data *executing-breakpoint-hooks*)
(let ((*executing-breakpoint-hooks* (cons data (let ((*executing-breakpoint-hooks* (cons data
*executing-breakpoint-hooks*))) *executing-breakpoint-hooks*)))
(invoke-breakpoint-hooks breakpoints component offset after))) (invoke-breakpoint-hooks breakpoints component offset)))
;; At this point breakpoints may not hold the same list as ;; At this point breakpoints may not hold the same list as
;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
;; a breakpoint deactivation. If there are no more active at this ;; a breakpoint deactivation. If there are no more active at this
;; location, then the normal instruction has been put back, and we do ;; location, then the normal instruction has been put back, and we do
;; no need an after breakpoint to re-install a break instruction. ;; no need an after breakpoint to re-install a break instruction.
(when (breakpoint-data-breakpoints data) (when (breakpoint-data-breakpoints data)
;; Restore instruction. Do this before SET-AFTER-BREAKPOINTS which ;; Restore instruction. Do this before SET-AFTER-BREAKPOINTS which
;; uses CALL-BREAKPOINT-AFTER-OFFSET. ;; uses CALL-BREAKPOINT-AFTER-OFFSET.
(system:without-gcing (system:without-gcing
(breakpoint-remove (kernel:get-lisp-obj-address component) offset (breakpoint-remove (kernel:get-lisp-obj-address component) offset
(breakpoint-data-instruction data))) (breakpoint-data-instruction data)))
(set-after-breakpoints component data signal-context)) (set-after-breakpoints component data signal-context))
;; Set the sigmask, to keep the system running until we can ;; Set the sigmask, to keep the system running until we can
;; remove the after breakpoints and re-install the user breakpoints. ;; remove the after breakpoints and re-install the user breakpoints.
(setf (breakpoint-data-sigmask data) (setf (breakpoint-data-sigmask data)
(unix:unix-sigblock (unix:sigmask :sigint :sigquit :sigtstp)))))) (unix:unix-sigblock (unix:sigmask :sigint :sigquit :sigtstp)))))
(defun handle-after-breakpoint (after breakpoints data offset component) (defun handle-after-breakpoint (after breakpoints data offset component)
(let ((previous-data (after-breakpoint-previous-data after))) (let ((previous-data (after-breakpoint-previous-data after)))
...@@ -3385,7 +3358,8 @@ ...@@ -3385,7 +3358,8 @@
(system:without-gcing (system:without-gcing
(breakpoint-remove (kernel:get-lisp-obj-address component) offset (breakpoint-remove (kernel:get-lisp-obj-address component) offset
(breakpoint-data-instruction data))) (breakpoint-data-instruction data)))
(setf (breakpoint-data-after-breakpoint data) nil)) (setf (breakpoint-data-after-breakpoint data) nil)
(delete-breakpoint-data data))
;; Ditto for the partner of the after-breakpoint (if there were two). ;; Ditto for the partner of the after-breakpoint (if there were two).
(let ((partner (after-breakpoint-partner after))) (let ((partner (after-breakpoint-partner after)))
(when partner (when partner
...@@ -3396,7 +3370,8 @@ ...@@ -3396,7 +3370,8 @@
(breakpoint-data-component partner-data)) (breakpoint-data-component partner-data))
(breakpoint-data-offset partner-data) (breakpoint-data-offset partner-data)
(breakpoint-data-instruction partner-data))) (breakpoint-data-instruction partner-data)))
(setf (breakpoint-data-after-breakpoint partner-data) nil))))) (setf (breakpoint-data-after-breakpoint partner-data) nil)
(delete-breakpoint-data partner-data)))))
;; Put back previous's break instruction. ;; Put back previous's break instruction.
;; We don't need to store the replaced instruction in the data since we ;; We don't need to store the replaced instruction in the data since we
;; have it from installing the break instruction before. ;; have it from installing the break instruction before.
...@@ -3407,24 +3382,20 @@ ...@@ -3407,24 +3382,20 @@
;; Restore sigmask that we saved before executing previous's inst. ;; Restore sigmask that we saved before executing previous's inst.
(unix:unix-sigsetmask (breakpoint-data-sigmask previous-data)))) (unix:unix-sigsetmask (breakpoint-data-sigmask previous-data))))
(defun invoke-breakpoint-hooks (breakpoints component offset after) (defun invoke-breakpoint-hooks (breakpoints component offset)
(let* ((debug-fun (debug-function-from-pc component offset)) (let* ((debug-fun (debug-function-from-pc component offset))
(frame (do ((f (top-frame) (frame-down f))) (frame (do ((f (top-frame) (frame-down f)))
((eq debug-fun (frame-debug-function f)) f)))) ((eq debug-fun (frame-debug-function f)) f))))
(if after (dolist (bpt breakpoints)
;; If there's an after-bpt here, and any breakpoint whose hook we (funcall (breakpoint-hook-function bpt)
;; may invoke has an unknown-return-partner, then the after-bpt may frame
;; be for the unknown-return-partner. This means we already ran ;; If this is an :unknown-return-partner, then pass the
;; this breakpoint's hook when we hit its partner one instruction ;; hook function the original breakpoint, so that users
;; previous. Don't invoke it twice for one virtual break. ;; arn't forced to confront the fact that some breakpoints
(let ((previous-data (after-breakpoint-previous-data after))) ;; really are two.
(dolist (bpt breakpoints) (if (eq (breakpoint-kind bpt) :unknown-return-partner)
(let ((partner (breakpoint-unknown-return-partner bpt))) (breakpoint-unknown-return-partner bpt)
(unless (and partner bpt)))))
(eq (breakpoint-internal-data partner) previous-data))
(funcall (breakpoint-hook-function bpt) frame bpt)))))
(dolist (bpt breakpoints)
(funcall (breakpoint-hook-function bpt) frame bpt)))))
(defun set-after-breakpoints (component data signal-context) (defun set-after-breakpoints (component data signal-context)
(multiple-value-bind (after-1 after-2) (multiple-value-bind (after-1 after-2)
...@@ -3514,8 +3485,8 @@ ...@@ -3514,8 +3485,8 @@
(defun make-bogus-lra (real-lra &optional known-return-p) (defun make-bogus-lra (real-lra &optional known-return-p)
"Make a bogus LRA object that signals a breakpoint trap when returned to. If "Make a bogus LRA object that signals a breakpoint trap when returned to. If
the breakpoint trap handler returns, REAL-LRA is returned to. Three values the breakpoint trap handler returns, REAL-LRA is returned to. Three values
are returned: the bogus LRA object, the code component it is part of, and the are returned: the bogus LRA object, the code component it is part of, and
PC offset for the trap instruction." the PC offset for the trap instruction."
(system:without-gcing (system:without-gcing
(let* ((src-start (system:foreign-symbol-address (let* ((src-start (system:foreign-symbol-address
"function_end_breakpoint_guts")) "function_end_breakpoint_guts"))
...@@ -3877,3 +3848,16 @@ ...@@ -3877,3 +3848,16 @@
(no-debug-blocks (condx) (no-debug-blocks (condx)
(declare (ignore condx)) (declare (ignore condx))
nil))))) nil)))))
(defun print-code-locations (function)
(let ((debug-fun (function-debug-function function)))
(do-debug-function-blocks (block debug-fun)
(do-debug-block-locations (loc block)
(fill-in-code-location loc)
(format t "~S code location at ~D"
(compiled-code-location-kind loc)
(compiled-code-location-pc loc))
(debug::print-code-location-source-form loc 0)
(terpri)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment