common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.8.21.34.debugectomy.2

Browse source 
"This won't hurt a bit."

 * remove FRAME-%DOWN cache.
 * refactor GET-CONTEXT-VALUE and (SETF GET-CONTEXT-VALUE) to reduce
    duplication between x86 and non-x86.
 * merge DEBUG-FUN, COMPILED-DEBUG-FUN, and BOGUS-DEBUG-FUN.
 * rename breakpoint activation/deactivation functions to reflect this.
This commit is contained in:
Nikodemus Siivola 2005-04-13 11:18:21 +00:00
parent 9beabcfcb6
commit d05ee5e05b
3 changed files with 149 additions and 238 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
contrib/sb-sprof/sb-sprof.lisp
View file

@ -808,18 +808,18 @@
(%make-node :name (or (sb-disassem::find-assembler-routine start) (%make-node :name (or (sb-disassem::find-assembler-routine start)
(format nil "~a" info)) (format nil "~a" info))
:start-pc start :end-pc end))) :start-pc start :end-pc end)))
(sb-di::compiled-debug-fun (sb-di::debug-fun
(if (sb-di::debug-fun-bogus-name info)
(%make-node :name (sb-di::debug-fun-name info))
(let* ((name (sb-di::debug-fun-name info)) (let* ((name (sb-di::debug-fun-name info))
(cdf (sb-di::compiled-debug-fun-compiler-debug-fun info)) (cdf (sb-di::debug-fun-compiler-debug-fun info))
(start-offset (sb-c::compiler-debug-fun-start-pc cdf)) (start-offset (sb-c::compiler-debug-fun-start-pc cdf))
(end-offset (sb-c::compiler-debug-fun-elsewhere-pc cdf)) (end-offset (sb-c::compiler-debug-fun-elsewhere-pc cdf))
(component (sb-di::compiled-debug-fun-component info)) (component (sb-di::debug-fun-component info))
(start-pc (code-start component))) (start-pc (code-start component)))
(%make-node :name name (%make-node :name name
:start-pc (+ start-pc start-offset) :start-pc (+ start-pc start-offset)
:end-pc (+ start-pc end-offset)))) :end-pc (+ start-pc end-offset)))))
(sb-di::debug-fun
(%make-node :name (sb-di::debug-fun-name info)))
(t (t
(%make-node :name (coerce info 'string))))) (%make-node :name (coerce info 'string)))))
@ -848,11 +848,11 @@
code)))))) code))))))
;;; One function can have more than one COMPILED-DEBUG-FUNCTION with ;;; One function can have more than one DEBUG-FUNCTION with the same
;;; the same name. Reduce the number of calls to Debug-Info by first ;;; name. Reduce the number of calls to Debug-Info by first looking
;;; looking for a given PC in a red-black tree. If not found in the ;;; for a given PC in a red-black tree. If not found in the tree, get
;;; tree, get debug info, and look for a node in a hash-table by ;;; debug info, and look for a node in a hash-table by function name.
;;; function name. If not found in the hash-table, make a new node. ;;; If not found in the hash-table, make a new node.
(defvar *node-tree*) (defvar *node-tree*)
(defvar *name->node*) (defvar *name->node*)

332
src/code/debug-int.lisp
View file

@ -219,11 +219,6 @@
(:copier nil)) (:copier nil))
;; the next frame up, or NIL when top frame ;; the next frame up, or NIL when top frame
(up nil :type (or frame null)) (up nil :type (or frame null))
;; the previous frame down, or NIL when the bottom frame. Before
;; computing the next frame down, this slot holds the frame pointer
;; to the control stack for the given frame. This lets us get the
;; next frame down and the return-pc for that frame.
(%down :unparsed :type (or frame (member nil :unparsed)))
;; the DEBUG-FUN for the function whose call this frame represents ;; the DEBUG-FUN for the function whose call this frame represents
(debug-fun nil :type debug-fun) (debug-fun nil :type debug-fun)
;; the CODE-LOCATION where the frame's DEBUG-FUN will continue ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
@ -252,31 +247,56 @@
;;;; DEBUG-FUNs ;;;; DEBUG-FUNs
(defstruct (debug-fun (:constructor nil) (defstruct (debug-fun
(:copier nil))) (:constructor make-debug-fun (compiler-debug-fun component))
(:constructor make-bogus-debug-fun (bogus-name))
(def!method print-object ((obj debug-fun) stream)
(print-unreadable-object (obj stream :type t)
(prin1 (debug-fun-name obj) stream)))
(defstruct (compiled-debug-fun
(:include debug-fun)
(:constructor make-compiled-debug-fun
(compiler-debug-fun component))
(:copier nil)) (:copier nil))
;; marks an bogus debug fun and represent the fake name
bogus-name
;; compiler's dumped DEBUG-FUN information (unexported) ;; compiler's dumped DEBUG-FUN information (unexported)
(compiler-debug-fun nil :type sb!c::compiler-debug-fun) (compiler-debug-fun nil :type (or sb!c::compiler-debug-fun null))
;; code object (unexported). ;; code object (unexported).
component component
;; the :FUN-START breakpoint (if any) used to facilitate ;; the :FUN-START breakpoint (if any) used to facilitate
;; function end breakpoints ;; function end breakpoints
(end-starter nil :type (or null breakpoint))) (end-starter nil :type (or null breakpoint)))
(defstruct (bogus-debug-fun (def!method print-object ((obj debug-fun) stream)
(:include debug-fun) (print-unreadable-object (obj stream :type t)
(:constructor make-bogus-debug-fun (%name)) (prin1 (debug-fun-name obj) stream)))
(:copier nil))
%name) ;;; Return the name of the function represented by DEBUG-FUN. This may
;;; be a string or a cons; do not assume it is a symbol.
(defun debug-fun-name (debug-fun)
(declare (type debug-fun debug-fun))
(or (debug-fun-bogus-name debug-fun)
(sb!c::compiler-debug-fun-name
(debug-fun-compiler-debug-fun debug-fun))))
(defun debug-fun-start-pc (debug-fun)
(sb!c::compiler-debug-fun-start-pc (debug-fun-compiler-debug-fun debug-fun)))
;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
;;; or NIL if the function is unavailable or is non-existent as a user
;;; callable function object.
(defun debug-fun-fun (debug-fun)
(unless (debug-fun-bogus-name debug-fun)
(let ((component (debug-fun-component debug-fun))
(start-pc (debug-fun-start-pc debug-fun)))
(do ((entry (%code-entry-points component)
(%simple-fun-next entry)))
((null entry) nil)
(when (= start-pc (debug-fun-start-pc (fun-debug-fun entry)))
(return entry))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(defun debug-fun-kind (debug-fun)
;; FIXME: This "is one of" information should become part of the function
;; declamation, not just a doc string
(unless (debug-fun-bogus-name debug-fun)
(sb!c::compiler-debug-fun-kind
(debug-fun-compiler-debug-fun debug-fun))))
;;;; DEBUG-BLOCKs ;;;; DEBUG-BLOCKs
@ -619,11 +639,9 @@
;;; Flush all of the frames above FRAME, and renumber all the frames ;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME. ;;; below FRAME.
(defun flush-frames-above (frame) (defun flush-frames-above (frame)
(setf (frame-up frame) nil) (setf (frame-up frame) nil
(do ((number 0 (1+ number)) (frame-number frame) 0)
(frame frame (frame-%down frame))) nil)
((not (frame-p frame)))
(setf (frame-number frame) number)))
;;; Return the frame immediately below FRAME on the stack; or when ;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL. ;;; FRAME is the bottom of the stack, return NIL.
@ -631,25 +649,8 @@
(/noshow0 "entering FRAME-DOWN") (/noshow0 "entering FRAME-DOWN")
;; We have to access the old-fp and return-pc out of frame and pass ;; We have to access the old-fp and return-pc out of frame and pass
;; them to COMPUTE-CALLING-FRAME. ;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(let ((debug-fun (frame-debug-fun frame))) (let ((debug-fun (frame-debug-fun frame)))
(/noshow0 "in DOWN :UNPARSED case") (if (debug-fun-bogus-name debug-fun)
(setf (frame-%down frame)
(etypecase debug-fun
(compiled-debug-fun
(let ((c-d-f (compiled-debug-fun-compiler-debug-fun
debug-fun)))
(compute-calling-frame
(descriptor-sap
(get-context-value
frame ocfp-save-offset
(sb!c::compiler-debug-fun-old-fp c-d-f)))
(get-context-value
frame lra-save-offset
(sb!c::compiler-debug-fun-return-pc c-d-f))
frame)))
(bogus-debug-fun
(let ((fp (frame-pointer frame))) (let ((fp (frame-pointer frame)))
(when (control-stack-pointer-valid-p fp) (when (control-stack-pointer-valid-p fp)
#!+(or x86 x86-64) #!+(or x86 x86-64)
@ -658,38 +659,34 @@
#!-(or x86 x86-64) #!-(or x86 x86-64)
(compute-calling-frame (compute-calling-frame
#!-alpha #!-alpha
(sap-ref-sap fp (* ocfp-save-offset (sap-ref-sap fp (* ocfp-save-offset sb!vm:n-word-bytes))
sb!vm:n-word-bytes))
#!+alpha #!+alpha
(int-sap (int-sap
(sap-ref-32 fp (* ocfp-save-offset (sap-ref-32 fp (* ocfp-save-offset sb!vm:n-word-bytes)))
sb!vm:n-word-bytes)))
(stack-ref fp lra-save-offset) (stack-ref fp lra-save-offset)
frame)))
frame))))))) (let ((c-d-f (debug-fun-compiler-debug-fun debug-fun)))
down))) (compute-calling-frame
(descriptor-sap
(get-context-value frame ocfp-save-offset
(sb!c::compiler-debug-fun-old-fp c-d-f)))
(get-context-value frame lra-save-offset
(sb!c::compiler-debug-fun-return-pc c-d-f))
frame)))))
;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
;;; standard save location offset on the stack. LOC is the saved ;;; standard save location offset on the stack. LOC is the saved
;;; SC-OFFSET describing the main location. ;;; SC-OFFSET describing the main location.
(defun get-context-value (frame stack-slot loc)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
#!-(or x86 x86-64) #!-(or x86 x86-64)
(defun get-context-value (frame stack-slot loc) (stack-ref pointer stack-slot)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
(stack-ref pointer stack-slot))))
#!+(or x86 x86-64) #!+(or x86 x86-64)
(defun get-context-value (frame stack-slot loc)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-access-debug-var-slot pointer loc escaped)
(ecase stack-slot (ecase stack-slot
(#.ocfp-save-offset (#.ocfp-save-offset
(stack-ref pointer stack-slot)) (stack-ref pointer stack-slot))
@ -697,24 +694,16 @@
(sap-ref-sap pointer (- (* (1+ stack-slot) (sap-ref-sap pointer (- (* (1+ stack-slot)
sb!vm::n-word-bytes)))))))) sb!vm::n-word-bytes))))))))
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot pointer loc value escaped)
#!-(or x86 x86-64) #!-(or x86 x86-64)
(defun (setf get-context-value) (value frame stack-slot loc) (setf (stack-ref pointer stack-slot) value)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot pointer loc value escaped)
(setf (stack-ref pointer stack-slot) value))))
#!+(or x86 x86-64) #!+(or x86 x86-64)
(defun (setf get-context-value) (value frame stack-slot loc)
(declare (type frame frame) (type unsigned-byte stack-slot)
(type sb!c:sc-offset loc))
(let ((pointer (frame-pointer frame))
(escaped (frame-escaped frame)))
(if escaped
(sub-set-debug-var-slot pointer loc value escaped)
(ecase stack-slot (ecase stack-slot
(#.ocfp-save-offset (#.ocfp-save-offset
(setf (stack-ref pointer stack-slot) value)) (setf (stack-ref pointer stack-slot) value))
@ -770,15 +759,13 @@
(compute-calling-frame caller real-lra up-frame)) (compute-calling-frame caller real-lra up-frame))
(let ((d-fun (case code (let ((d-fun (case code
(:undefined-function (:undefined-function
(make-bogus-debug-fun (make-bogus-debug-fun "undefined function"))
"undefined function"))
(:foreign-function (:foreign-function
(make-bogus-debug-fun (make-bogus-debug-fun
(foreign-function-backtrace-name (foreign-function-backtrace-name
(int-sap (get-lisp-obj-address lra))))) (int-sap (get-lisp-obj-address lra)))))
((nil) ((nil)
(make-bogus-debug-fun (make-bogus-debug-fun "bogus stack frame"))
"bogus stack frame"))
(t (t
(debug-fun-from-pc code pc-offset))))) (debug-fun-from-pc code pc-offset)))))
(make-frame caller up-frame d-fun (make-frame caller up-frame d-fun
@ -812,14 +799,12 @@
pc-offset 0)))) pc-offset 0))))
(let ((d-fun (case code (let ((d-fun (case code
(:undefined-function (:undefined-function
(make-bogus-debug-fun (make-bogus-debug-fun "undefined function"))
"undefined function"))
(:foreign-function (:foreign-function
(make-bogus-debug-fun (make-bogus-debug-fun
(foreign-function-backtrace-name ra))) (foreign-function-backtrace-name ra)))
((nil) ((nil)
(make-bogus-debug-fun (make-bogus-debug-fun "bogus stack frame"))
"bogus stack frame"))
(t (t
(debug-fun-from-pc code pc-offset))))) (debug-fun-from-pc code pc-offset)))))
(/noshow0 "returning MAKE-FRAME from COMPUTE-CALLING-FRAME") (/noshow0 "returning MAKE-FRAME from COMPUTE-CALLING-FRAME")
@ -970,7 +955,7 @@ register."
;;;; frame utilities ;;;; frame utilities
;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the ;;; This returns a DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a ;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
;;; SB!C::COMPILER-DEBUG-FUN from the PC. The result only needs to ;;; SB!C::COMPILER-DEBUG-FUN from the PC. The result only needs to
;;; reference the COMPONENT, for function constants, and the ;;; reference the COMPONENT, for function constants, and the
@ -990,7 +975,7 @@ register."
(len (length fun-map))) (len (length fun-map)))
(declare (type simple-vector fun-map)) (declare (type simple-vector fun-map))
(if (= len 1) (if (= len 1)
(make-compiled-debug-fun (svref fun-map 0) component) (make-debug-fun (svref fun-map 0) component)
(let ((i 1) (let ((i 1)
(elsewhere-p (elsewhere-p
(>= pc (sb!c::compiler-debug-fun-elsewhere-pc (>= pc (sb!c::compiler-debug-fun-elsewhere-pc
@ -1002,21 +987,18 @@ register."
(sb!c::compiler-debug-fun-elsewhere-pc (sb!c::compiler-debug-fun-elsewhere-pc
(svref fun-map (1+ i))) (svref fun-map (1+ i)))
(svref fun-map i)))) (svref fun-map i))))
(return (make-compiled-debug-fun (return (make-debug-fun (svref fun-map (1- i)) component)))
(svref fun-map (1- i))
component)))
(incf i 2))))))))) (incf i 2)))))))))
;;; This returns a code-location for the COMPILED-DEBUG-FUN, ;;; This returns a code-location for the DEBUG-FUN, and the pc into
;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a ;;; its code vector. If we stopped at a breakpoint, find the
;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise, ;;; CODE-LOCATION for that breakpoint. Otherwise, make an :UNSURE code
;;; make an :UNSURE code location, so it can be filled in when we ;;; location, so it can be filled in when we figure out what is going
;;; figure out what is going on. ;;; on.
(defun code-location-from-pc (debug-fun pc escaped) (defun code-location-from-pc (debug-fun pc escaped)
(or (and (compiled-debug-fun-p debug-fun) (or (and (not (debug-fun-bogus-name debug-fun))
escaped escaped
(let ((data (breakpoint-data (let ((data (breakpoint-data (debug-fun-component debug-fun)
(compiled-debug-fun-component debug-fun)
pc nil))) pc nil)))
(when (and data (breakpoint-data-breakpoints data)) (when (and data (breakpoint-data-breakpoints data))
(let ((what (breakpoint-what (let ((what (breakpoint-what
@ -1121,38 +1103,6 @@ register."
,@body)) ,@body))
,result)))) ,result))))
;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
;;; or NIL if the function is unavailable or is non-existent as a user
;;; callable function object.
(defun debug-fun-fun (debug-fun)
(etypecase debug-fun
(compiled-debug-fun
(let ((component
(compiled-debug-fun-component debug-fun))
(start-pc
(sb!c::compiler-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun debug-fun))))
(do ((entry (%code-entry-points component)
(%simple-fun-next entry)))
((null entry) nil)
(when (= start-pc
(sb!c::compiler-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun
(fun-debug-fun entry))))
(return entry)))))
(bogus-debug-fun nil)))
;;; Return the name of the function represented by DEBUG-FUN. This may
;;; be a string or a cons; do not assume it is a symbol.
(defun debug-fun-name (debug-fun)
(declare (type debug-fun debug-fun))
(etypecase debug-fun
(compiled-debug-fun
(sb!c::compiler-debug-fun-name
(compiled-debug-fun-compiler-debug-fun debug-fun)))
(bogus-debug-fun
(bogus-debug-fun-%name debug-fun))))
;;; Return a DEBUG-FUN that represents debug information for FUN. ;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun) (defun fun-debug-fun (fun)
(declare (type function fun)) (declare (type function fun))
@ -1172,7 +1122,7 @@ register."
(sb!c::compiler-debug-info-fun-map (sb!c::compiler-debug-info-fun-map
(%code-debug-info component))))) (%code-debug-info component)))))
(if res (if res
(make-compiled-debug-fun res component) (make-debug-fun res component)
;; KLUDGE: comment from CMU CL: ;; KLUDGE: comment from CMU CL:
;; This used to be the non-interpreted branch, but ;; This used to be the non-interpreted branch, but
;; William wrote it to return the debug-fun of fun's XEP ;; William wrote it to return the debug-fun of fun's XEP
@ -1186,18 +1136,6 @@ register."
(get-header-data component)) (get-header-data component))
sb!vm:n-word-bytes))))))) sb!vm:n-word-bytes)))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(defun debug-fun-kind (debug-fun)
;; FIXME: This "is one of" information should become part of the function
;; declamation, not just a doc string
(etypecase debug-fun
(compiled-debug-fun
(sb!c::compiler-debug-fun-kind
(compiled-debug-fun-compiler-debug-fun debug-fun)))
(bogus-debug-fun
nil)))
;;; Is there any variable information for DEBUG-FUN? ;;; Is there any variable information for DEBUG-FUN?
(defun debug-var-info-available (debug-fun) (defun debug-var-info-available (debug-fun)
(not (not (debug-fun-debug-vars debug-fun)))) (not (not (debug-fun-debug-vars debug-fun))))
@ -1282,9 +1220,9 @@ register."
;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list ;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
;;; information. ;;; information.
(defun debug-fun-lambda-list (debug-fun) (defun debug-fun-lambda-list (debug-fun)
(unless (bogus-debug-fun-p debug-fun) (unless (debug-fun-bogus-name debug-fun)
(let ((args (sb!c::compiler-debug-fun-arguments (let ((args (sb!c::compiler-debug-fun-arguments
(compiled-debug-fun-compiler-debug-fun debug-fun))) (debug-fun-compiler-debug-fun debug-fun)))
(vars (debug-fun-debug-vars debug-fun))) (vars (debug-fun-debug-vars debug-fun)))
(cond ((not args) (cond ((not args)
(debug-signal 'lambda-list-unavailable :debug-fun debug-fun)) (debug-signal 'lambda-list-unavailable :debug-fun debug-fun))
@ -1320,8 +1258,8 @@ register."
(incf i)) (incf i))
(nreverse res)))))))) (nreverse res))))))))
(defun compiled-debug-fun-debug-info (debug-fun) (defun debug-fun-debug-info (debug-fun)
(%code-debug-info (compiled-debug-fun-component debug-fun))) (%code-debug-info (debug-fun-component debug-fun)))
;;;; unpacking variable and basic block data ;;;; unpacking variable and basic block data
@ -1372,10 +1310,10 @@ register."
;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't ;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
;;; return the blocks. ;;; return the blocks.
(defun debug-fun-debug-blocks (debug-fun) (defun debug-fun-debug-blocks (debug-fun)
(when (bogus-debug-fun-p debug-fun) (when (debug-fun-bogus-name debug-fun)
(debug-signal 'no-debug-blocks :debug-fun debug-fun)) (debug-signal 'no-debug-blocks :debug-fun debug-fun))
(let* ((var-count (length (debug-fun-debug-vars debug-fun))) (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
(compiler-debug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)) (compiler-debug-fun (debug-fun-compiler-debug-fun debug-fun))
(blocks (sb!c::compiler-debug-fun-blocks compiler-debug-fun)) (blocks (sb!c::compiler-debug-fun-blocks compiler-debug-fun))
;; KLUDGE: 8 is a hard-wired constant in the compiler for the ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
;; element size of the packed binary representation of the ;; element size of the packed binary representation of the
@ -1440,8 +1378,8 @@ register."
;;; it returns a SIMPLE-VECTOR of DEBUG-VARs, parsing it from ;;; it returns a SIMPLE-VECTOR of DEBUG-VARs, parsing it from
;;; the SB!C::COMPILER-DEBUG-FUN. ;;; the SB!C::COMPILER-DEBUG-FUN.
(defun debug-fun-debug-vars (debug-fun) (defun debug-fun-debug-vars (debug-fun)
(unless (bogus-debug-fun-p debug-fun) (unless (debug-fun-bogus-name debug-fun)
(let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)) (let* ((cdebug-fun (debug-fun-compiler-debug-fun debug-fun))
(packed-vars (sb!c::compiler-debug-fun-vars cdebug-fun)) (packed-vars (sb!c::compiler-debug-fun-vars cdebug-fun))
(args-minimal (eq (sb!c::compiler-debug-fun-arguments cdebug-fun) (args-minimal (eq (sb!c::compiler-debug-fun-arguments cdebug-fun)
:minimal))) :minimal)))
@ -1560,8 +1498,7 @@ register."
((debug-block-elsewhere-p last) ((debug-block-elsewhere-p last)
(if (< pc (if (< pc
(sb!c::compiler-debug-fun-elsewhere-pc (sb!c::compiler-debug-fun-elsewhere-pc
(compiled-debug-fun-compiler-debug-fun (debug-fun-compiler-debug-fun debug-fun)))
debug-fun)))
(svref blocks (1- end)) (svref blocks (1- end))
last)) last))
((< pc ((< pc
@ -1580,8 +1517,7 @@ register."
;;; Return the CODE-LOCATION's DEBUG-SOURCE. ;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location) (defun code-location-debug-source (code-location)
(let* ((info (compiled-debug-fun-debug-info (let* ((info (debug-fun-debug-info (code-location-debug-fun code-location)))
(code-location-debug-fun code-location)))
(sources (sb!c::compiler-debug-info-source info)) (sources (sb!c::compiler-debug-info-source info))
(len (length sources))) (len (length sources)))
(declare (list sources)) (declare (list sources))
@ -2348,8 +2284,7 @@ register."
(cond ((debug-var-alive-p debug-var) (cond ((debug-var-alive-p debug-var)
(let ((debug-fun (code-location-debug-fun basic-code-location))) (let ((debug-fun (code-location-debug-fun basic-code-location)))
(if (>= (code-location-pc basic-code-location) (if (>= (code-location-pc basic-code-location)
(sb!c::compiler-debug-fun-start-pc (debug-fun-start-pc debug-fun))
(compiled-debug-fun-compiler-debug-fun debug-fun)))
:valid :valid
:invalid))) :invalid)))
((code-location-unknown-p basic-code-location) :unknown) ((code-location-unknown-p basic-code-location) :unknown)
@ -2571,24 +2506,26 @@ register."
(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))
(compiled-debug-fun (debug-fun
(when (debug-fun-bogus-name what)
(error "Tried to set a breakpoint on a bogus debug-fun."))
(ecase kind (ecase kind
(:fun-start (:fun-start
(%make-breakpoint hook-fun what kind info)) (%make-breakpoint hook-fun what kind info))
(:fun-end (:fun-end
(unless (eq (sb!c::compiler-debug-fun-returns (unless (eq (sb!c::compiler-debug-fun-returns
(compiled-debug-fun-compiler-debug-fun what)) (debug-fun-compiler-debug-fun what))
:standard) :standard)
(error ":FUN-END breakpoints are currently unsupported ~ (error ":FUN-END breakpoints are currently unsupported ~
for the known return convention.")) for the known return convention."))
(let* ((bpt (%make-breakpoint hook-fun what kind info)) (let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what))) (starter (debug-fun-end-starter what)))
(unless starter (unless starter
(setf starter (%make-breakpoint #'list what :fun-start nil)) (setf starter (%make-breakpoint #'list what :fun-start nil))
(setf (breakpoint-hook-fun starter) (setf (breakpoint-hook-fun starter)
(fun-end-starter-hook starter what)) (fun-end-starter-hook starter what))
(setf (compiled-debug-fun-end-starter what) starter)) (setf (debug-fun-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) fun-end-cookie) (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
@ -2623,13 +2560,13 @@ register."
;;; function, we must establish breakpoint-data about FUN-END-BPT. ;;; function, we must establish breakpoint-data about FUN-END-BPT.
(defun fun-end-starter-hook (starter-bpt debug-fun) (defun fun-end-starter-hook (starter-bpt debug-fun)
(declare (type breakpoint starter-bpt) (declare (type breakpoint starter-bpt)
(type compiled-debug-fun debug-fun)) (type debug-fun debug-fun))
(lambda (frame breakpoint) (lambda (frame breakpoint)
(declare (ignore breakpoint) (declare (ignore breakpoint)
(type frame frame)) (type frame frame))
(let ((lra-sc-offset (let ((lra-sc-offset
(sb!c::compiler-debug-fun-return-pc (sb!c::compiler-debug-fun-return-pc
(compiled-debug-fun-compiler-debug-fun debug-fun)))) (debug-fun-compiler-debug-fun debug-fun))))
(multiple-value-bind (lra component offset) (multiple-value-bind (lra component offset)
(make-bogus-lra (make-bogus-lra
(get-context-value frame (get-context-value frame
@ -2663,7 +2600,7 @@ register."
(defun fun-end-cookie-valid-p (frame cookie) (defun fun-end-cookie-valid-p (frame cookie)
(let ((lra (fun-end-cookie-bogus-lra cookie)) (let ((lra (fun-end-cookie-bogus-lra cookie))
(lra-sc-offset (sb!c::compiler-debug-fun-return-pc (lra-sc-offset (sb!c::compiler-debug-fun-return-pc
(compiled-debug-fun-compiler-debug-fun (debug-fun-compiler-debug-fun
(fun-end-cookie-debug-fun cookie))))) (fun-end-cookie-debug-fun cookie)))))
(do ((frame frame (frame-down frame))) (do ((frame frame (frame-down frame)))
((not frame) nil) ((not frame) nil)
@ -2690,23 +2627,13 @@ register."
(when other (when other
(activate-code-location-breakpoint other)))) (activate-code-location-breakpoint other))))
(:fun-start (:fun-start
(etypecase (breakpoint-what breakpoint) (activate-fun-start-breakpoint breakpoint))
(compiled-debug-fun
(activate-compiled-fun-start-breakpoint breakpoint))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))
(:fun-end (:fun-end
(etypecase (breakpoint-what breakpoint)
(compiled-debug-fun
(let ((starter (breakpoint-start-helper breakpoint))) (let ((starter (breakpoint-start-helper breakpoint)))
(unless (eq (breakpoint-status starter) :active) (unless (eq (breakpoint-status starter) :active)
;; may already be active by some other :FUN-END breakpoint ;; may already be active by some other :FUN-END breakpoint
(activate-compiled-fun-start-breakpoint starter))) (activate-fun-start-breakpoint starter)))
(setf (breakpoint-status breakpoint) :active)) (setf (breakpoint-status breakpoint) :active))))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))))
breakpoint) breakpoint)
(defun activate-code-location-breakpoint (breakpoint) (defun activate-code-location-breakpoint (breakpoint)
@ -2715,8 +2642,7 @@ register."
(declare (type code-location loc)) (declare (type code-location loc))
(sub-activate-breakpoint (sub-activate-breakpoint
breakpoint breakpoint
(breakpoint-data (compiled-debug-fun-component (breakpoint-data (debug-fun-component (code-location-debug-fun loc))
(code-location-debug-fun loc))
(+ (code-location-pc loc) (+ (code-location-pc loc)
(if (or (eq (breakpoint-kind breakpoint) (if (or (eq (breakpoint-kind breakpoint)
:unknown-return-partner) :unknown-return-partner)
@ -2725,15 +2651,13 @@ register."
sb!vm:single-value-return-byte-offset sb!vm:single-value-return-byte-offset
0)))))) 0))))))
(defun activate-compiled-fun-start-breakpoint (breakpoint) (defun activate-fun-start-breakpoint (breakpoint)
(declare (type breakpoint breakpoint)) (declare (type breakpoint breakpoint))
(let ((debug-fun (breakpoint-what breakpoint))) (let ((debug-fun (breakpoint-what breakpoint)))
(sub-activate-breakpoint (sub-activate-breakpoint
breakpoint breakpoint
(breakpoint-data (compiled-debug-fun-component debug-fun) (breakpoint-data (debug-fun-component debug-fun)
(sb!c::compiler-debug-fun-start-pc (debug-fun-start-pc debug-fun)))))
(compiled-debug-fun-compiler-debug-fun
debug-fun))))))
(defun sub-activate-breakpoint (breakpoint data) (defun sub-activate-breakpoint (breakpoint data)
(declare (type breakpoint breakpoint) (declare (type breakpoint breakpoint)
@ -2756,26 +2680,20 @@ register."
(defun deactivate-breakpoint (breakpoint) (defun deactivate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :active) (when (eq (breakpoint-status breakpoint) :active)
(without-interrupts (without-interrupts
(let ((loc (breakpoint-what breakpoint))) (sub-deactivate-breakpoint breakpoint)
(etypecase loc
((or code-location compiled-debug-fun)
(deactivate-compiled-breakpoint breakpoint)
(let ((other (breakpoint-unknown-return-partner breakpoint))) (let ((other (breakpoint-unknown-return-partner breakpoint)))
(when other (when other
(deactivate-compiled-breakpoint other)))) (sub-deactivate-breakpoint other)))))
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))))
breakpoint) breakpoint)
(defun deactivate-compiled-breakpoint (breakpoint) (defun sub-deactivate-breakpoint (breakpoint)
(if (eq (breakpoint-kind breakpoint) :fun-end) (if (eq (breakpoint-kind breakpoint) :fun-end)
(let ((starter (breakpoint-start-helper breakpoint))) (let ((starter (breakpoint-start-helper breakpoint)))
(unless (find-if (lambda (bpt) (unless (find-if (lambda (bpt)
(and (not (eq bpt breakpoint)) (and (not (eq bpt breakpoint))
(eq (breakpoint-status bpt) :active))) (eq (breakpoint-status bpt) :active)))
(breakpoint-%info starter)) (breakpoint-%info starter))
(deactivate-compiled-breakpoint starter))) (sub-deactivate-breakpoint starter)))
(let* ((data (breakpoint-internal-data breakpoint)) (let* ((data (breakpoint-internal-data breakpoint))
(bpts (delete breakpoint (breakpoint-data-breakpoints data)))) (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
(setf (breakpoint-internal-data breakpoint) nil) (setf (breakpoint-internal-data breakpoint) nil)
@ -2828,11 +2746,9 @@ register."
(setf (breakpoint-info starter) breakpoints) (setf (breakpoint-info starter) breakpoints)
(unless breakpoints (unless breakpoints
(delete-breakpoint starter) (delete-breakpoint starter)
(setf (compiled-debug-fun-end-starter (setf (debug-fun-end-starter (breakpoint-what breakpoint)) nil))))))
(breakpoint-what breakpoint))
nil))))))
breakpoint) breakpoint)
;;;; C call out stubs ;;;; C call out stubs
;;; This actually installs the break instruction in the component. It ;;; This actually installs the break instruction in the component. It
@ -3073,9 +2989,5 @@ register."
;;; the arguments are in place; or if that location can't be ;;; the arguments are in place; or if that location can't be
;;; determined due to a lack of debug information, return NIL. ;;; determined due to a lack of debug information, return NIL.
(defun debug-fun-start-location (debug-fun) (defun debug-fun-start-location (debug-fun)
(code-location-from-pc debug-fun (code-location-from-pc debug-fun (debug-fun-start-pc debug-fun) nil))
(sb!c::compiler-debug-fun-start-pc
(compiled-debug-fun-compiler-debug-fun
debug-fun))
nil))

5
src/compiler/target-disassem.lisp
View file

@ -1331,7 +1331,7 @@
(when first-block-seen-p (when first-block-seen-p
(setf nil-block-seen-p t)))) (setf nil-block-seen-p t))))
(setf last-debug-fun (setf last-debug-fun
(sb!di::make-compiled-debug-fun fmap-entry code))))))) (sb!di::make-debug-fun fmap-entry code)))))))
(let ((max-offset (code-inst-area-length code))) (let ((max-offset (code-inst-area-length code)))
(when (and first-block-seen-p last-debug-fun) (when (and first-block-seen-p last-debug-fun)
(add-seg last-offset (add-seg last-offset
@ -1384,8 +1384,7 @@
(setf last-offset fun-map-entry)) (setf last-offset fun-map-entry))
(sb!c::compiler-debug-fun (sb!c::compiler-debug-fun
(setf last-debug-fun (setf last-debug-fun
(sb!di::make-compiled-debug-fun fun-map-entry (sb!di::make-debug-fun fun-map-entry code))))))
code))))))
(when last-debug-fun (when last-debug-fun
(add-seg last-offset (add-seg last-offset
(- (code-inst-area-length code) last-offset) (- (code-inst-area-length code) last-offset)