X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=fb1af04595d4cfd2a4f4168e9fd29d1ab48fb358;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=69182e8775c8be40844194d955fc7a006208ff48;hpb=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 69182e8..fb1af04 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -394,15 +394,15 @@ (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 @@ -431,7 +431,7 @@ ;; 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) @@ -524,15 +524,15 @@ (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing)) (defun fun-word-offset (fun) (fun-word-offset fun)) -#!-sb-fluid (declaim (inline cstack-pointer-valid-p)) -(defun cstack-pointer-valid-p (x) +#!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) +(defun control-stack-pointer-valid-p (x) (declare (type system-area-pointer x)) - #!-x86 ; stack grows toward high address values + #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= (int-sap control-stack-start) x) (zerop (logand (sap-int x) #b11))) - #!+x86 ; stack grows toward low address values + #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> (int-sap control-stack-end) x) (zerop (logand (sap-int x) #b11)))) @@ -575,10 +575,13 @@ (defun ra-pointer-valid-p (ra) (declare (type system-area-pointer ra)) (and - ;; Not the first page which is unmapped. + ;; not the first page (which is unmapped) + ;; + ;; FIXME: Where is this documented? Is it really true of every CPU + ;; architecture? Is it even necessarily true in current SBCL? (>= (sap-int ra) 4096) - ;; Not a Lisp stack pointer. - (not (cstack-pointer-valid-p ra)))) + ;; not a Lisp stack pointer + (not (control-stack-pointer-valid-p ra)))) ;;; Try to find a valid previous stack. This is complex on the x86 as ;;; it can jump between C and Lisp frames. To help find a valid frame @@ -594,7 +597,7 @@ (fixnum depth)) ;;(format t "*CC ~S ~S~%" fp depth) (cond - ((not (cstack-pointer-valid-p fp)) + ((not (control-stack-pointer-valid-p fp)) #+nil (format t "debug invalid fp ~S~%" fp) nil) (t @@ -604,9 +607,9 @@ 4)))) (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) - (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) + (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) + (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) (ra-pointer-valid-p c-ra)) #+nil (format t "*C Both valid ~S ~S ~S ~S~%" @@ -621,11 +624,11 @@ (format t "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) - #+freebsd + #!+freebsd (if (sap> lisp-ocfp c-ocfp) (values lisp-ra lisp-ocfp) (values c-ra c-ocfp)) - #-freebsd + #!-freebsd (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. @@ -640,12 +643,12 @@ #+nil (format t "debug: no valid2 fp found ~S ~S~%" lisp-ocfp c-ocfp) nil)))) - ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) + ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) (ra-pointer-valid-p lisp-ra)) ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) (values lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) + ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) #!-linux (ra-pointer-valid-p c-ra)) ;; The C convention is looking good. #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) @@ -705,7 +708,7 @@ frame))) (bogus-debug-fun (let ((fp (frame-pointer frame))) - (when (cstack-pointer-valid-p fp) + (when (control-stack-pointer-valid-p fp) #!+x86 (multiple-value-bind (ra ofp) (x86-call-context fp) (compute-calling-frame ofp ra frame)) @@ -791,7 +794,7 @@ #!-x86 (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) - (when (cstack-pointer-valid-p caller) + (when (control-stack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind (word-offset code) @@ -835,7 +838,7 @@ (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") - (when (cstack-pointer-valid-p caller) + (when (control-stack-pointer-valid-p caller) (/noshow0 "in WHEN") ;; First check for an escaped frame. (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) @@ -1123,8 +1126,7 @@ ;;; 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))) @@ -1227,7 +1229,7 @@ ;;; 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))))) @@ -1252,7 +1254,7 @@ (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. @@ -1271,9 +1273,9 @@ (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))) @@ -1511,19 +1513,18 @@ (list successors)) (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte succ-and-flags)) - (push (sb!c::read-var-integer blocks i) successors)) + (push (sb!c:read-var-integer blocks i) successors)) (let* ((locations - (dotimes (k (sb!c::read-var-integer blocks i) + (dotimes (k (sb!c:read-var-integer blocks i) (result locations-buffer)) (let ((kind (svref sb!c::*compiled-code-location-kinds* (aref+ blocks i))) (pc (+ last-pc - (sb!c::read-var-integer blocks i))) + (sb!c:read-var-integer blocks i))) (tlf-offset (or tlf-number - (sb!c::read-var-integer blocks - i))) - (form-number (sb!c::read-var-integer blocks i)) - (live-set (sb!c::read-packed-bit-vector + (sb!c:read-var-integer blocks i))) + (form-number (sb!c:read-var-integer blocks i)) + (live-set (sb!c:read-packed-bit-vector live-set-len blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset @@ -1596,7 +1597,7 @@ (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 @@ -1746,7 +1747,7 @@ (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 @@ -1767,7 +1768,7 @@ (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 @@ -1789,7 +1790,7 @@ ((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,, @@ -1810,7 +1811,7 @@ ;; ;; 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))))) @@ -2049,7 +2050,7 @@ (sb!vm:context-float-register escaped (sb!c:sc-offset-offset sc-offset) 'double-float) (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1) + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) 'double-float)) :invalid-value-for-unescaped-register-storage)) #!+long-float @@ -2671,7 +2672,7 @@ (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)) @@ -2712,20 +2713,19 @@ ;;;; 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. ;;; @@ -2740,7 +2740,7 @@ ;;; 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 @@ -2748,12 +2748,12 @@ (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) @@ -2766,7 +2766,7 @@ (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)) @@ -2774,11 +2774,11 @@ (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) @@ -2860,14 +2860,14 @@ (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (#-x86 eq #+x86 sap= + (#!-x86 eq #!+x86 sap= lra (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) ;;;; 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. @@ -2950,7 +2950,7 @@ ;;;; 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 @@ -3037,21 +3037,21 @@ ;;; 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:define-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:define-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:define-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) @@ -3116,7 +3116,7 @@ ;;; breakpoints. (defun handle-breakpoint-aux (breakpoints data offset component signal-context) (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*))) @@ -3138,9 +3138,9 @@ (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ;; Some platforms have no usable sigreturn() call. If your - ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), - ;; add it to this list. - #!-(or hpux irix x86 alpha) + ;; implementation of arch_do_displaced_inst() _does_ sigreturn(), + ;; it's polite to warn here + #!+(and sparc solaris) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -3148,7 +3148,7 @@ (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 @@ -3186,7 +3186,7 @@ (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))))