X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=13e80e8ea1963f9a4f81679b1ca12b9acded1c53;hb=4f64f131a7bca59d0dc8be9e74d05a7645f27e67;hp=a7856e97bb7e116e0aa34515c6cdf00aa1ab3b8e;hpb=943f38e6232a69ab1bbcfb2c86801eea391f8ae1;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a7856e9..13e80e8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -736,9 +736,9 @@ ;;; XXX Should probably check whether it has reached the bottom of the ;;; stack. ;;; -;;; XXX Should handle interrupted frames, both Lisp and C. At present it -;;; manages to find a fp trail, see linux hack below. -(defun x86-call-context (fp &key (depth 8)) +;;; XXX Should handle interrupted frames, both Lisp and C. At present +;;; it manages to find a fp trail, see linux hack below. +(defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) ;;(format t "*CC ~S ~S~%" fp depth) @@ -762,15 +762,19 @@ lisp-ocfp lisp-ra c-ocfp c-ra) ;; Look forward another step to check their validity. (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (- depth 1))) - (c-path-fp (x86-call-context c-ocfp :depth (- depth 1)))) + :depth (1+ depth))) + (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) (cond ((and lisp-path-fp c-path-fp) - ;; Both still seem valid - choose the smallest. - #+nil (format t "debug: both still valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (if (sap< lisp-ocfp c-ocfp) - (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp))) + ;; Both still seem valid - choose the lisp frame. + #+nil (when (zerop depth) + (format t "debug: both still valid ~S ~S ~S ~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra)) + #+freebsd + (if (sap> lisp-ocfp c-ocfp) + (values lisp-ra lisp-ocfp) + (values c-ra c-ocfp)) + #-freebsd + (values lisp-ra lisp-ocfp)) (lisp-path-fp ;; The lisp convention is looking good. #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) @@ -2067,14 +2071,14 @@ (coerce (cdr (res)) 'simple-vector)))) -;;; This variable maps minimal debug-info function maps to an unpacked -;;; version thereof. +;;; a map from minimal DEBUG-INFO function maps to unpacked +;;; versions thereof (defvar *uncompacted-function-maps* (make-hash-table :test 'eq)) -;;; Return a function-map for a given compiled-debug-info object. If +;;; Return a FUNCTION-MAP for a given COMPILED-DEBUG-info object. If ;;; the info is minimal, and has not been parsed, then parse it. ;;; -;;; FIXME: Now that we no longer use the minimal-debug-function +;;; FIXME: Now that we no longer use the MINIMAL-DEBUG-FUNCTION ;;; representation, calls to this function can be replaced by calls to ;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function, ;;; and this function and everything it calls become dead code which @@ -2090,17 +2094,14 @@ ;;;; CODE-LOCATIONs -;;; If we're sure of whether code-location is known, return t or nil. -;;; If we're :unsure, then try to fill in the code-location's slots. +;;; If we're sure of whether code-location is known, return T or NIL. +;;; If we're :UNSURE, then try to fill in the code-location's slots. ;;; This determines whether there is any debug-block information, and ;;; if code-location is known. ;;; ;;; ??? IF this conses closures every time it's called, then break off the -;;; :unsure part to get the HANDLER-CASE into another function. +;;; :UNSURE part to get the HANDLER-CASE into another function. (defun code-location-unknown-p (basic-code-location) - #!+sb-doc - "Returns whether basic-code-location is unknown. It returns nil when the - code-location is known." (ecase (code-location-%unknown-p basic-code-location) ((t) t) ((nil) nil) @@ -2109,11 +2110,10 @@ (handler-case (not (fill-in-code-location basic-code-location)) (no-debug-blocks () t)))))) +;;; Return the DEBUG-BLOCK containing code-location if it is available. +;;; Some debug policies inhibit debug-block information, and if none +;;; is available, then this signals a NO-DEBUG-BLOCKS condition. (defun code-location-debug-block (basic-code-location) - #!+sb-doc - "Returns the debug-block containing code-location if it is available. Some - debug policies inhibit debug-block information, and if none is available, - then this signals a no-debug-blocks condition." (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) (etypecase basic-code-location @@ -2126,10 +2126,10 @@ (interpreted-code-location-ir1-node basic-code-location)))))) block))) -;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It -;;; determines the correct one using the code-location's pc. This uses +;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines +;;; the correct one using the code-location's pc. We use ;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information -;;; or signal a 'no-debug-blocks condition. The blocks are sorted by +;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by ;;; their first code-location's pc, in ascending order. Therefore, as ;;; soon as we find a block that starts with a pc greater than ;;; basic-code-location's pc, we know the previous block contains the @@ -2280,8 +2280,8 @@ (let ((live-set (compiled-code-location-%live-set code-location))) (cond ((eq live-set :unparsed) (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing debug info - ;; the compiler should have dumped. + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. ;; ;; FIXME: This error and comment happen over and over again. ;; Make them a shared function. @@ -2289,9 +2289,8 @@ (compiled-code-location-%live-set code-location)) (t live-set))))) +;;; true if OBJ1 and OBJ2 are the same place in the code (defun code-location= (obj1 obj2) - #!+sb-doc - "Returns whether obj1 and obj2 are the same place in the code." (etypecase obj1 (compiled-code-location (etypecase obj2 @@ -2312,7 +2311,7 @@ (= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2))) -;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil +;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL ;;; depending on whether the code-location was known in its ;;; debug-function's debug-block information. This may signal a ;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and @@ -3121,43 +3120,47 @@ :code-location loc :form form :frame frame)) (funcall res frame)))))) +;;; Evaluate FORM in the lexical context of FRAME's current code +;;; location, returning the results of the evaluation. (defun eval-in-frame (frame form) (declare (type frame frame)) - #!+sb-doc - "Evaluate Form in the lexical context of Frame's current code location, - returning the results of the evaluation." (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; 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. +;;; +;;; WHAT and KIND determine where in a function the system invokes +;;; HOOK-FUNCTION. WHAT is either a code-location or a debug-function. +;;; KIND is one of :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END. +;;; Since the starts and ends of functions may not have code-locations +;;; representing them, designate these places by supplying WHAT as a +;;; debug-function and KIND indicating the :FUNCTION-START or +;;; :FUNCTION-END. When WHAT is a debug-function and kind is +;;; :FUNCTION-END, then hook-function must take two additional +;;; arguments, a list of values returned by the function and a +;;; FUNCTION-END-COOKIE. +;;; +;;; INFO is information supplied by and used by the user. +;;; +;;; FUNCTION-END-COOKIE is a function. To implement :FUNCTION-END +;;; breakpoints, the system uses starter breakpoints to establish the +;;; :FUNCTION-END breakpoint for each invocation of the function. Upon +;;; each entry, the system creates a unique cookie to identify the +;;; invocation, and when the user supplies a function for this +;;; argument, the system invokes it on the frame and the cookie. The +;;; system later invokes the :FUNCTION-END breakpoint hook on the same +;;; cookie. The user may save the cookie for comparison in the hook +;;; function. +;;; +;;; Signal an error if WHAT is an unknown code-location. (defun make-breakpoint (hook-function what &key (kind :code-location) info function-end-cookie) - #!+sb-doc - "This creates and returns 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. - What and kind determine where in a function the system invokes - hook-function. What is either a code-location or a debug-function. Kind is - one of :code-location, :function-start, or :function-end. Since the starts - and ends of functions may not have code-locations representing them, - designate these places by supplying what as a debug-function and kind - indicating the :function-start or :function-end. When what is a - debug-function and kind is :function-end, then hook-function must take two - additional arguments, a list of values returned by the function and a - function-end-cookie. - Info is information supplied by and used by the user. - Function-end-cookie is a function. To implement :function-end breakpoints, - the system uses starter breakpoints to establish the :function-end breakpoint - for each invocation of the function. Upon each entry, the system creates a - unique cookie to identify the invocation, and when the user supplies a - function for this argument, the system invokes it on the frame and the - cookie. The system later invokes the :function-end breakpoint hook on the - same cookie. The user may save the cookie for comparison in the hook - function. - This signals an error if what is an unknown code-location." (etypecase what (code-location (when (code-location-unknown-p what) @@ -3217,7 +3220,7 @@ ;; This is the debug-function associated with the cookie. debug-fun) -;;; This maps bogus-lra-components to cookies, so +;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. (defvar *function-end-cookies* (make-hash-table :test 'eq)) @@ -3260,16 +3263,17 @@ (let ((fun (breakpoint-cookie-fun bpt))) (when fun (funcall fun frame cookie)))))))))) +;;; This takes a FUNCTION-END-COOKIE and a frame, and it returns +;;; whether the cookie is still valid. A cookie becomes invalid when +;;; the frame that established the cookie has exited. Sometimes cookie +;;; holders are unaware of cookie invalidation because their +;;; :FUNCTION-END breakpoint hooks didn't run due to THROW'ing. +;;; +;;; This takes a frame as an efficiency hack since the user probably +;;; has a frame object in hand when using this routine, and it saves +;;; repeated parsing of the stack and consing when asking whether a +;;; series of cookies is valid. (defun function-end-cookie-valid-p (frame cookie) - #!+sb-doc - "This takes a function-end-cookie and a frame, and it returns whether the - cookie is still valid. A cookie becomes invalid when the frame that - established the cookie has exited. Sometimes cookie holders are unaware - of cookie invalidation because their :function-end breakpoint hooks didn't - run due to THROW'ing. This takes a frame as an efficiency hack since the - user probably has a frame object in hand when using this routine, and it - saves repeated parsing of the stack and consing when asking whether a - series of cookies is valid." (let ((lra (function-end-cookie-bogus-lra cookie)) (lra-sc-offset (sb!c::compiled-debug-function-return-pc (compiled-debug-function-compiler-debug-fun @@ -3283,14 +3287,14 @@ #!+gengc sb!vm::ra-save-offset lra-sc-offset))) (return t))))) - + ;;;; ACTIVATE-BREAKPOINT +;;; 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. (defun activate-breakpoint (breakpoint) - #!+sb-doc - "This causes 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." (when (eq (breakpoint-status breakpoint) :deleted) (error "cannot activate a deleted breakpoint: ~S" breakpoint)) (unless (eq (breakpoint-status breakpoint) :active) @@ -3317,7 +3321,7 @@ (compiled-debug-function (let ((starter (breakpoint-start-helper breakpoint))) (unless (eq (breakpoint-status starter) :active) - ;; May already be active by some other :function-end breakpoint. + ;; may already be active by some other :FUNCTION-END breakpoint (activate-compiled-function-start-breakpoint starter))) (setf (breakpoint-status breakpoint) :active)) (interpreted-debug-function @@ -3365,7 +3369,7 @@ (setf (breakpoint-data-breakpoints data) (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) - + ;;;; DEACTIVATE-BREAKPOINT (defun deactivate-breakpoint (breakpoint) @@ -3406,7 +3410,7 @@ (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) - + ;;;; BREAKPOINT-INFO (defun breakpoint-info (breakpoint) @@ -3419,7 +3423,7 @@ (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other (setf (breakpoint-%info other) value)))) - + ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT (defun breakpoint-active-p (breakpoint) @@ -3453,7 +3457,7 @@ (breakpoint-what breakpoint)) nil)))))) breakpoint) - + ;;;; C call out stubs ;;; This actually installs the break instruction in the component. It @@ -3632,7 +3636,7 @@ (stack-ref ocfp arg-num)) results))) (nreverse results))) - + ;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints) (defconstant