(def!method print-object ((debug-var debug-var) stream)
(print-unreadable-object (debug-var stream :type t :identity t)
(format stream
- "~S ~D"
+ "~S ~W"
(debug-var-symbol debug-var)
(debug-var-id debug-var))))
(breakpoint-data-offset obj))))
(defstruct (breakpoint (:constructor %make-breakpoint
- (hook-function what kind %info))
+ (hook-fun what kind %info))
(:copier nil))
;; This is the function invoked when execution encounters the
;; breakpoint. It takes a frame, the breakpoint, and optionally a
- ;; list of values. Values are supplied for :FUN-END breakpoints
- ;; as values to return for the function containing the breakpoint.
- ;; :FUN-END breakpoint hook-functions also take a cookie
- ;; argument. See COOKIE-FUN slot.
- (hook-function nil :type function)
+ ;; list of values. Values are supplied for :FUN-END breakpoints as
+ ;; values to return for the function containing the breakpoint.
+ ;; :FUN-END breakpoint hook functions also take a cookie argument.
+ ;; See the COOKIE-FUN slot.
+ (hook-fun (required-arg) :type function)
;; CODE-LOCATION or DEBUG-FUN
(what nil :type (or code-location debug-fun))
;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
;; for identifying :FUN-END breakpoint executions. That is, if
;; there is one :FUN-END breakpoint, but there may be multiple
;; pending calls of its function on the stack. This function takes
- ;; the cookie, and the hook-function takes the cookie too.
+ ;; the cookie, and the hook function takes the cookie too.
(cookie-fun nil :type (or null function))
;; This slot users can set with whatever information they find useful.
%info)
;; the DEBUG-FUN containing this CODE-LOCATION
(debug-fun nil :type debug-fun)
;; This is initially :UNSURE. Upon first trying to access an
- ;; :unparsed slot, if the data is unavailable, then this becomes t,
+ ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
;; and the code-location is unknown. If the data is available, this
- ;; becomes nil, a known location. We can't use a separate type
+ ;; becomes NIL, a known location. We can't use a separate type
;; code-location for this since we must return code-locations before
;; we can tell whether they're known or unknown. For example, when
;; parsing the stack, we don't want to unpack all the variables and
(zerop (logand (sap-int x) #b11))))
#!+x86
-(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
+(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
#!+x86
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
- (/show0 "entering TOP-FRAME")
+ (/noshow0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
(compute-calling-frame (descriptor-sap fp) pc nil)))
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
- (/show0 "entering FRAME-DOWN")
+ (/noshow0 "entering FRAME-DOWN")
;; We have to access the old-fp and return-pc out of frame and pass
;; them to COMPUTE-CALLING-FRAME.
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(let ((debug-fun (frame-debug-fun frame)))
- (/show0 "in DOWN :UNPARSED case")
+ (/noshow0 "in DOWN :UNPARSED case")
(setf (frame-%down frame)
(etypecase debug-fun
(compiled-debug-fun
#!+x86
(defun compute-calling-frame (caller ra up-frame)
(declare (type system-area-pointer caller ra))
- (/show0 "entering COMPUTE-CALLING-FRAME")
+ (/noshow0 "entering COMPUTE-CALLING-FRAME")
(when (cstack-pointer-valid-p caller)
- (/show0 "in WHEN")
+ (/noshow0 "in WHEN")
;; First check for an escaped frame.
(multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
- (/show0 "at COND")
+ (/noshow0 "at COND")
(cond (code
- (/show0 "in CODE clause")
+ (/noshow0 "in CODE clause")
;; If it's escaped it may be a function end breakpoint trap.
(when (and (code-component-p code)
(eq (%code-debug-info code) :bogus-lra))
(setq code (code-header-ref code real-lra-slot))
(aver code)))
(t
- (/show0 "in T clause")
+ (/noshow0 "in T clause")
;; not escaped
(multiple-value-setq (pc-offset code)
(compute-lra-data-from-pc ra))
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
- (/show0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+ (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
- (/show0 "entering FIND-ESCAPED-FRAME")
+ (/noshow0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(sb!alien:with-alien
((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
- (/show0 "at head of WITH-ALIEN")
+ (/noshow0 "at head of WITH-ALIEN")
(let ((context (sb!alien:deref lisp-interrupt-contexts index)))
- (/show0 "got CONTEXT")
+ (/noshow0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
(without-gcing
- (/show0 "in WITHOUT-GCING")
+ (/noshow0 "in WITHOUT-GCING")
(let* ((component-ptr (component-ptr-from-pc
(sb!vm:context-pc context)))
(code (unless (sap= component-ptr (int-sap #x0))
(component-from-component-ptr component-ptr))))
- (/show0 "got CODE")
+ (/noshow0 "got CODE")
(when (null code)
(return (values code 0 context)))
(let* ((code-header-len (* (get-header-data code)
(- (get-lisp-obj-address code)
sb!vm:other-pointer-lowtag)
code-header-len)))
- (/show "got PC-OFFSET")
+ (/noshow "got PC-OFFSET")
(unless (<= 0 pc-offset
(* (code-header-ref code sb!vm:code-code-size-slot)
sb!vm:n-word-bytes))
;; FIXME: Should this be WARN or ERROR or what?
(format t "** pc-offset ~S not in code obj ~S?~%"
pc-offset code))
- (/show0 "returning from FIND-ESCAPED-FRAME")
+ (/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))))))
\f
;;;; frame utilities
-;;; This returns a COMPILED-DEBUG-FUN for code and pc. We fetch the
+;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
-;;; SB!C::COMPILED-DEBUG-FUN from the pc. The result only needs to
-;;; reference the component, for function constants, and the
+;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
+;;; reference the COMPONENT, for function constants, and the
;;; SB!C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc)
(let ((info (%code-debug-info component)))
((eq info :bogus-lra)
(make-bogus-debug-fun "function end breakpoint"))
(t
- (let* ((fun-map (get-debug-info-fun-map info))
+ (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
(len (length fun-map)))
(declare (type simple-vector fun-map))
(if (= len 1)
;;; CODE-LOCATIONs at which execution would continue with frame as the
;;; top frame if someone threw to the corresponding tag.
(defun frame-catches (frame)
- (let ((catch (descriptor-sap *current-catch-block*))
- (res nil)
+ (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+ (reversed-result nil)
(fp (frame-pointer frame)))
- (loop
- (when (zerop (sap-int catch)) (return (nreverse res)))
- (when (sap= fp
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:n-word-bytes))
- #!+alpha
- (:int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:n-word-bytes))))
- (let* (#!-x86
- (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+x86
- (ra (sap-ref-sap
- catch (* sb!vm:catch-block-entry-pc-slot
- sb!vm:n-word-bytes)))
- #!-x86
- (component
- (stack-ref catch sb!vm:catch-block-current-code-slot))
- #!+x86
- (component (component-from-component-ptr
- (component-ptr-from-pc ra)))
- (offset
- #!-x86
- (* (- (1+ (get-header-data lra))
- (get-header-data component))
- sb!vm:n-word-bytes)
- #!+x86
- (- (sap-int ra)
- (- (get-lisp-obj-address component)
- sb!vm:other-pointer-lowtag)
- (* (get-header-data component) sb!vm:n-word-bytes))))
- (push (cons #!-x86
- (stack-ref catch sb!vm:catch-block-tag-slot)
- #!+x86
- (make-lisp-obj
- (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
- sb!vm:n-word-bytes)))
- (make-compiled-code-location
- offset (frame-debug-fun frame)))
- res)))
- (setf catch
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:n-word-bytes))
- #!+alpha
- (:int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:n-word-bytes)))))))
+ (loop until (zerop (sap-int catch))
+ finally (return (nreverse reversed-result))
+ do
+ (when (sap= fp
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))))
+ (let* (#!-x86
+ (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+ #!+x86
+ (ra (sap-ref-sap
+ catch (* sb!vm:catch-block-entry-pc-slot
+ sb!vm:n-word-bytes)))
+ #!-x86
+ (component
+ (stack-ref catch sb!vm:catch-block-current-code-slot))
+ #!+x86
+ (component (component-from-component-ptr
+ (component-ptr-from-pc ra)))
+ (offset
+ #!-x86
+ (* (- (1+ (get-header-data lra))
+ (get-header-data component))
+ sb!vm:n-word-bytes)
+ #!+x86
+ (- (sap-int ra)
+ (- (get-lisp-obj-address component)
+ sb!vm:other-pointer-lowtag)
+ (* (get-header-data component) sb!vm:n-word-bytes))))
+ (push (cons #!-x86
+ (stack-ref catch sb!vm:catch-block-tag-slot)
+ #!+x86
+ (make-lisp-obj
+ (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes)))
+ (make-compiled-code-location
+ offset (frame-debug-fun frame)))
+ reversed-result)))
+ (setf catch
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes)))))))
\f
;;;; operations on DEBUG-FUNs
;;; nil). This may iterate over only some of DEBUG-FUN's variables or
;;; none depending on debug policy; for example, possibly the
;;; compilation only preserved argument information.
-(defmacro do-debug-fun-variables ((var debug-fun &optional result)
- &body body)
+(defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body)
(let ((vars (gensym))
(i (gensym)))
`(let ((,vars (debug-fun-debug-vars ,debug-fun)))
;;; 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::compiled-debug-fun-name
(and (sb!c::compiled-debug-fun-p x)
(eq (sb!c::compiled-debug-fun-name x) name)
(eq (sb!c::compiled-debug-fun-kind x) nil)))
- (get-debug-info-fun-map
+ (sb!c::compiled-debug-info-fun-map
(%code-debug-info component)))))
(if res
(make-compiled-debug-fun res component)
;;; as symbol. The result of this function is limited to the
;;; availability of variable information in DEBUG-FUN; for
;;; example, possibly DEBUG-FUN only knows about its arguments.
-(defun debug-fun-symbol-variables (debug-fun symbol)
+(defun debug-fun-symbol-vars (debug-fun symbol)
(let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
(package (and (symbol-package symbol)
(package-name (symbol-package symbol)))))
(if variables
(let* ((len (length variables))
(prefix-len (length name-prefix-string))
- (pos (find-variable name-prefix-string variables len))
+ (pos (find-var name-prefix-string variables len))
(res nil))
(when pos
;; Find names from pos to variable's len that contain prefix.
(setq res (nreverse res)))
res))))
-;;; This returns a position in variables for one containing name as an
-;;; initial substring. End is the length of variables if supplied.
-(defun find-variable (name variables &optional end)
+;;; This returns a position in VARIABLES for one containing NAME as an
+;;; initial substring. END is the length of VARIABLES if supplied.
+(defun find-var (name variables &optional end)
(declare (simple-vector variables)
(simple-string name))
(let ((name-len (length name)))
(position name variables
- :test #'(lambda (x y)
- (let* ((y (debug-var-symbol-name y))
- (y-len (length y)))
- (declare (simple-string y))
- (and (>= y-len name-len)
- (string= x y :end1 name-len :end2 name-len))))
+ :test (lambda (x y)
+ (let* ((y (debug-var-symbol-name y))
+ (y-len (length y)))
+ (declare (simple-string y))
+ (and (>= y-len name-len)
+ (string= x y :end1 name-len :end2 name-len))))
:end (or end (length variables)))))
;;; Return a list representing the lambda-list for DEBUG-FUN. The
(defun assign-minimal-var-names (vars)
(declare (simple-vector vars))
(let* ((len (length vars))
- (width (length (format nil "~D" (1- len)))))
+ (width (length (format nil "~W" (1- len)))))
(dotimes (i len)
(setf (compiled-debug-var-symbol (svref vars i))
(intern (format nil "ARG-~V,'0D" width i)
(defun parse-compiled-debug-vars (debug-fun)
(let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
debug-fun))
- (packed-vars (sb!c::compiled-debug-fun-variables cdebug-fun))
+ (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
(args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
:minimal)))
(when packed-vars
save-sc-offset)
buffer)))))))
\f
-;;;; unpacking minimal debug functions
-
-;;; Return a FUN-MAP for a given COMPILED-DEBUG-INFO object.
-(defun get-debug-info-fun-map (info)
- (declare (type sb!c::compiled-debug-info info))
- (let ((map (sb!c::compiled-debug-info-fun-map info)))
- ;; The old CMU CL had various hairy possibilities here, but in
- ;; SBCL we only use this one, right?
- (aver (simple-vector-p map))
- ;; So it's easy..
- map))
-\f
;;;; CODE-LOCATIONs
;;; If we're sure of whether code-location is known, return T or NIL.
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(code-location-%tlf-offset code-location))
;; (There used to be more cases back before sbcl-0.7.0,,
;; when we did special tricks to debug the IR1
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(code-location-%form-number code-location))
;; (There used to be more cases back before sbcl-0.7.0,,
;; when we did special tricks to debug the IR1
((not (fill-in-code-location code-location))
;; This check should be unnecessary. We're missing
;; debug info the compiler should have dumped.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(t
(compiled-code-location-kind code-location)))))
;; (There used to be more cases back before sbcl-0.7.0,,
;;
;; FIXME: This error and comment happen over and over again.
;; Make them a shared function.
- (error "internal error: unknown code location"))
+ (bug "unknown code location"))
(compiled-code-location-%live-set code-location))
(t live-set)))))
;; interpreter.)
))
;; (There used to be more cases back before sbcl-0.7.0,,
- ;; when we did special tricks to debug the IR1
- ;; interpreter.)
+ ;; when we did special tricks to debug IR1-interpreted code.)
))
(defun sub-compiled-code-location= (obj1 obj2)
(= (compiled-code-location-pc obj1)
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
(defun make-valid-lisp-obj (val)
- (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
- #!+sb-show (/hexstr val)
(if (or
;; fixnum
(zerop (logand val 3))
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
- (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
- (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
(let ((,var (sb!vm:context-register
escaped
(sb!c:sc-offset-offset sc-offset))))
- (/show0 "in escaped case, ,VAR value=..")
- (/hexstr ,var)
,@forms)
:invalid-value-for-unescaped-register-storage))
(escaped-float-value (format)
:invalid-value-for-unescaped-register-storage)))
(ecase (sb!c:sc-offset-scn sc-offset)
((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
- (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
(without-gcing
(with-escaped-value (val)
- (/show0 "VAL=..")
- (/hexstr val)
(make-valid-lisp-obj val))))
(#.sb!vm:base-char-reg-sc-number
- (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
(with-escaped-value (val)
(code-char val)))
(#.sb!vm:sap-reg-sc-number
- (/show0 "case of SAP-REG-SC-NUMBER")
(with-escaped-value (val)
(int-sap val)))
(#.sb!vm:signed-reg-sc-number
- (/show0 "case of SIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
(if (logbitp (1- sb!vm:n-word-bits) val)
(logior val (ash -1 sb!vm:n-word-bits))
val)))
(#.sb!vm:unsigned-reg-sc-number
- (/show0 "case of UNSIGNED-REG-SC-NUMBER")
(with-escaped-value (val)
val))
(#.sb!vm:single-reg-sc-number
- (/show0 "case of SINGLE-REG-SC-NUMBER")
(escaped-float-value single-float))
(#.sb!vm:double-reg-sc-number
- (/show0 "case of DOUBLE-REG-SC-NUMBER")
(escaped-float-value double-float))
#!+long-float
(#.sb!vm:long-reg-sc-number
- (/show0 "case of LONG-REG-SC-NUMBER")
(escaped-float-value long-float))
(#.sb!vm:complex-single-reg-sc-number
- (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
(escaped-complex-float-value single-float))
(#.sb!vm:complex-double-reg-sc-number
- (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
(escaped-complex-float-value double-float))
#!+long-float
(#.sb!vm:complex-long-reg-sc-number
- (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
(escaped-complex-float-value long-float))
(#.sb!vm:single-stack-sc-number
- (/show0 "case of SINGLE-STACK-SC-NUMBER")
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes))))
(#.sb!vm:double-stack-sc-number
- (/show0 "case of DOUBLE-STACK-SC-NUMBER")
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:n-word-bytes))))
#!+long-float
(#.sb!vm:long-stack-sc-number
- (/show0 "case of LONG-STACK-SC-NUMBER")
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
sb!vm:n-word-bytes))))
(#.sb!vm:complex-single-stack-sc-number
- (/show0 "case of COMPLEX-STACK-SC-NUMBER")
(complex
(sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))
(sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:n-word-bytes)))))
(#.sb!vm:complex-double-stack-sc-number
- (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
(complex
(sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
sb!vm:n-word-bytes)))
sb!vm:n-word-bytes)))))
#!+long-float
(#.sb!vm:complex-long-stack-sc-number
- (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
(complex
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
sb!vm:n-word-bytes)))
(sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
sb!vm:n-word-bytes)))))
(#.sb!vm:control-stack-sc-number
- (/show0 "case of CONTROL-STACK-SC-NUMBER")
(stack-ref fp (sb!c:sc-offset-offset sc-offset)))
(#.sb!vm:base-char-stack-sc-number
- (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
(code-char
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))))
(#.sb!vm:unsigned-stack-sc-number
- (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
(sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes))))
(#.sb!vm:signed-stack-sc-number
- (/show0 "case of SIGNED-STACK-SC-NUMBER")
(signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes))))
(#.sb!vm:sap-stack-sc-number
- (/show0 "case of SAP-STACK-SC-NUMBER")
(sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
sb!vm:n-word-bytes)))))))
(debug-signal 'no-debug-vars :debug-fun fun))
(sb!int:collect ((binds)
(specs))
- (do-debug-fun-variables (var fun)
+ (do-debug-fun-vars (var fun)
(let ((validity (debug-var-validity var loc)))
(unless (eq validity :invalid)
(let* ((sym (debug-var-symbol var))
(declare (ignorable ,n-frame))
(symbol-macrolet ,(specs) ,form))
'function)))
- #'(lambda (frame)
- ;; This prevents these functions from being used in any
- ;; location other than a function return location, so
- ;; maybe this should only check whether frame's
- ;; DEBUG-FUN is the same as loc's.
- (unless (code-location= (frame-code-location frame) loc)
- (debug-signal 'frame-fun-mismatch
- :code-location loc :form form :frame frame))
- (funcall res frame))))))
+ (lambda (frame)
+ ;; This prevents these functions from being used in any
+ ;; location other than a function return location, so maybe
+ ;; this should only check whether FRAME's DEBUG-FUN is the
+ ;; same as LOC's.
+ (unless (code-location= (frame-code-location frame) loc)
+ (debug-signal 'frame-fun-mismatch
+ :code-location loc :form form :frame frame))
+ (funcall res frame))))))
\f
;;;; breakpoints
;;;; user-visible interface
;;; Create and return a breakpoint. When program execution encounters
-;;; the breakpoint, the system calls HOOK-FUNCTION. HOOK-FUNCTION takes the
-;;; current frame for the function in which the program is running and the
-;;; breakpoint object.
+;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
+;;; current frame for the function in which the program is running and
+;;; the breakpoint object.
;;;
;;; WHAT and KIND determine where in a function the system invokes
-;;; HOOK-FUNCTION. WHAT is either a code-location or a DEBUG-FUN.
-;;; KIND is one of :CODE-LOCATION, :FUN-START, or :FUN-END.
-;;; Since the starts and ends of functions may not have code-locations
-;;; representing them, designate these places by supplying WHAT as a
-;;; DEBUG-FUN and KIND indicating the :FUN-START or
-;;; :FUN-END. When WHAT is a DEBUG-FUN and kind is
-;;; :FUN-END, then hook-function must take two additional
-;;; arguments, a list of values returned by the function and a
-;;; FUN-END-COOKIE.
+;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
+;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
+;;; and ends of functions may not have code-locations representing
+;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
+;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
+;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
+;;; additional arguments, a list of values returned by the function
+;;; and a FUN-END-COOKIE.
;;;
;;; INFO is information supplied by and used by the user.
;;;
;;; function.
;;;
;;; Signal an error if WHAT is an unknown code-location.
-(defun make-breakpoint (hook-function what
+(defun make-breakpoint (hook-fun what
&key (kind :code-location) info fun-end-cookie)
(etypecase what
(code-location
(error "cannot make a breakpoint at an unknown code location: ~S"
what))
(aver (eq kind :code-location))
- (let ((bpt (%make-breakpoint hook-function what kind info)))
+ (let ((bpt (%make-breakpoint hook-fun what kind info)))
(etypecase what
(compiled-code-location
;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
(when (eq (compiled-code-location-kind what) :unknown-return)
- (let ((other-bpt (%make-breakpoint hook-function what
+ (let ((other-bpt (%make-breakpoint hook-fun what
:unknown-return-partner
info)))
(setf (breakpoint-unknown-return-partner bpt) other-bpt)
(compiled-debug-fun
(ecase kind
(:fun-start
- (%make-breakpoint hook-function what kind info))
+ (%make-breakpoint hook-fun what kind info))
(:fun-end
(unless (eq (sb!c::compiled-debug-fun-returns
(compiled-debug-fun-compiler-debug-fun what))
(error ":FUN-END breakpoints are currently unsupported ~
for the known return convention."))
- (let* ((bpt (%make-breakpoint hook-function what kind info))
+ (let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
(unless starter
(setf starter (%make-breakpoint #'list what :fun-start nil))
- (setf (breakpoint-hook-function starter)
+ (setf (breakpoint-hook-fun starter)
(fun-end-starter-hook starter what))
(setf (compiled-debug-fun-end-starter what) starter))
(setf (breakpoint-start-helper bpt) starter)
(defun fun-end-starter-hook (starter-bpt debug-fun)
(declare (type breakpoint starter-bpt)
(type compiled-debug-fun debug-fun))
- #'(lambda (frame breakpoint)
- (declare (ignore breakpoint)
- (type frame frame))
- (let ((lra-sc-offset
- (sb!c::compiled-debug-fun-return-pc
- (compiled-debug-fun-compiler-debug-fun debug-fun))))
- (multiple-value-bind (lra component offset)
- (make-bogus-lra
- (get-context-value frame
- lra-save-offset
- lra-sc-offset))
- (setf (get-context-value frame
- lra-save-offset
- lra-sc-offset)
- lra)
- (let ((end-bpts (breakpoint-%info starter-bpt)))
- (let ((data (breakpoint-data component offset)))
- (setf (breakpoint-data-breakpoints data) end-bpts)
- (dolist (bpt end-bpts)
- (setf (breakpoint-internal-data bpt) data)))
- (let ((cookie (make-fun-end-cookie lra debug-fun)))
- (setf (gethash component *fun-end-cookies*) cookie)
- (dolist (bpt end-bpts)
- (let ((fun (breakpoint-cookie-fun bpt)))
- (when fun (funcall fun frame cookie))))))))))
+ (lambda (frame breakpoint)
+ (declare (ignore breakpoint)
+ (type frame frame))
+ (let ((lra-sc-offset
+ (sb!c::compiled-debug-fun-return-pc
+ (compiled-debug-fun-compiler-debug-fun debug-fun))))
+ (multiple-value-bind (lra component offset)
+ (make-bogus-lra
+ (get-context-value frame
+ lra-save-offset
+ lra-sc-offset))
+ (setf (get-context-value frame
+ lra-save-offset
+ lra-sc-offset)
+ lra)
+ (let ((end-bpts (breakpoint-%info starter-bpt)))
+ (let ((data (breakpoint-data component offset)))
+ (setf (breakpoint-data-breakpoints data) end-bpts)
+ (dolist (bpt end-bpts)
+ (setf (breakpoint-internal-data bpt) data)))
+ (let ((cookie (make-fun-end-cookie lra debug-fun)))
+ (setf (gethash component *fun-end-cookies*) cookie)
+ (dolist (bpt end-bpts)
+ (let ((fun (breakpoint-cookie-fun bpt)))
+ (when fun (funcall fun frame cookie))))))))))
;;; This takes a FUN-END-COOKIE and a frame, and it returns
;;; whether the cookie is still valid. A cookie becomes invalid when
\f
;;;; ACTIVATE-BREAKPOINT
-;;; Cause the system to invoke the breakpoint's hook-function until
+;;; Cause the system to invoke the breakpoint's hook function until
;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
;;; system invokes breakpoint hook functions in the opposite order
;;; that you activate them.
\f
;;;; DEACTIVATE-BREAKPOINT
-;;; Stop the system from invoking the breakpoint's hook-function.
+;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
(when (eq (breakpoint-status breakpoint) :active)
(without-interrupts
(defun deactivate-compiled-breakpoint (breakpoint)
(if (eq (breakpoint-kind breakpoint) :fun-end)
(let ((starter (breakpoint-start-helper breakpoint)))
- (unless (find-if #'(lambda (bpt)
- (and (not (eq bpt breakpoint))
- (eq (breakpoint-status bpt) :active)))
+ (unless (find-if (lambda (bpt)
+ (and (not (eq bpt breakpoint))
+ (eq (breakpoint-status bpt) :active)))
(breakpoint-%info starter))
(deactivate-compiled-breakpoint starter)))
(let* ((data (breakpoint-internal-data breakpoint))
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
-(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
- (code-obj sb!c-call:unsigned-long)
- (pc-offset sb!c-call:int))
+(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long
+ (code-obj sb!alien:unsigned-long)
+ (pc-offset sb!alien:int))
;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
-(sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
- (code-obj sb!c-call:unsigned-long)
- (pc-offset sb!c-call:int)
- (old-inst sb!c-call:unsigned-long))
+(sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
+ (code-obj sb!alien:unsigned-long)
+ (pc-offset sb!alien:int)
+ (old-inst sb!alien:unsigned-long))
-(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
+(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
(scp (* os-context-t))
- (orig-inst sb!c-call:unsigned-long))
+ (orig-inst sb!alien:unsigned-long))
;;;; breakpoint handlers (layer between C and exported interface)
-;;; This maps components to a mapping of offsets to breakpoint-datas.
+;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
-;;; This returns the breakpoint-data associated with component cross
+;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
(flet ((install-breakpoint-data ()
(install-breakpoint-data)))))
;;; We use this when there are no longer any active breakpoints
-;;; corresponding to data.
+;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
(let* ((component (breakpoint-data-component data))
(offsets (delete (breakpoint-data-offset data)
(values))
;;; The C handler for interrupts calls this when it has a
-;;; debugging-tool break instruction. This does NOT handle all breaks;
-;;; for example, it does not handle breaks for internal errors.
+;;; debugging-tool break instruction. This does *not* handle all
+;;; breaks; for example, it does not handle breaks for internal
+;;; errors.
(defun handle-breakpoint (offset component signal-context)
- (/show0 "entering HANDLE-BREAKPOINT")
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
;;; This handles code-location and DEBUG-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
- (/show0 "entering HANDLE-BREAKPOINT-AUX")
(unless breakpoints
- (error "internal error: breakpoint that nobody wants"))
+ (bug "breakpoint that nobody wants"))
(unless (member data *executing-breakpoint-hooks*)
(let ((*executing-breakpoint-hooks* (cons data
*executing-breakpoint-hooks*)))
(frame (do ((f (top-frame) (frame-down f)))
((eq debug-fun (frame-debug-fun f)) f))))
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame
;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
;; hook function the original breakpoint, so that users
bpt)))))
(defun handle-fun-end-breakpoint (offset component context)
- (/show0 "entering HANDLE-FUN-END-BREAKPOINT")
(let ((data (breakpoint-data component offset nil)))
(unless data
(error "unknown breakpoint in ~S at offset ~S"
;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
;;; [new C code].
(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
- (/show0 "entering HANDLE-FUN-END-BREAKPOINT-AUX")
(delete-breakpoint-data data)
(let* ((scp
(locally
(cookie (gethash component *fun-end-cookies*)))
(remhash component *fun-end-cookies*)
(dolist (bpt breakpoints)
- (funcall (breakpoint-hook-function bpt)
+ (funcall (breakpoint-hook-fun bpt)
frame bpt
(get-fun-end-breakpoint-values scp)
cookie))))
(do-debug-fun-blocks (block debug-fun)
(do-debug-block-locations (loc block)
(fill-in-code-location loc)
- (format t "~S code location at ~D"
+ (format t "~S code location at ~W"
(compiled-code-location-kind loc)
(compiled-code-location-pc loc))
(sb!debug::print-code-location-source-form loc 0)
projects / sbcl.git / blobdiff