X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=4b6be6d4d3c74e3ad3142fa3919d933eda48f4e0;hb=1dc38285834db2d374a156a4f68b19096341deb3;hp=3d375e86dd74b530c32ab7e8ee40f123c6dd83a8;hpb=17532463fa19f2fc2aba53b65c32e200a27ccd6a;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 3d375e8..4b6be6d 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -300,15 +300,19 @@ ;;; duplicate COMPILED-DEBUG-FUN structures. (defvar *compiled-debug-funs* (make-hash-table :test 'eq)) -;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN -;;; and its component. This maps the latter to the former in -;;; *COMPILED-DEBUG-FUNS*. If there already is a -;;; COMPILED-DEBUG-FUN, then this returns it from -;;; *COMPILED-DEBUG-FUNS*. +;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its +;;; component. This maps the latter to the former in +;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN, +;;; then this returns it from *COMPILED-DEBUG-FUNS*. +;;; +;;; FIXME: It seems this table can potentially grow without bounds, +;;; and retains roots to functions that might otherwise be collected. (defun make-compiled-debug-fun (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-funs*) - (setf (gethash compiler-debug-fun *compiled-debug-funs*) - (%make-compiled-debug-fun compiler-debug-fun component)))) + (let ((table *compiled-debug-funs*)) + (with-locked-hash-table (table) + (or (gethash compiler-debug-fun table) + (setf (gethash compiler-debug-fun table) + (%make-compiled-debug-fun compiler-debug-fun component)))))) (defstruct (bogus-debug-fun (:include debug-fun) @@ -320,8 +324,6 @@ (%function nil))) (:copier nil)) %name) - -(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) ;;;; DEBUG-BLOCKs @@ -356,8 +358,6 @@ (:copier nil)) ;; code-location information for the block (code-locations nil :type simple-vector)) - -(defvar *ir1-block-debug-block* (make-hash-table :test 'eq)) ;;;; breakpoints @@ -510,7 +510,7 @@ (defun %set-stack-ref (s n value) (%set-stack-ref s n value)) (defun fun-code-header (fun) (fun-code-header fun)) (defun lra-code-header (lra) (lra-code-header lra)) -(defun make-lisp-obj (value) (make-lisp-obj value)) +(defun %make-lisp-obj (value) (%make-lisp-obj value)) (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing)) (defun fun-word-offset (fun) (fun-word-offset fun)) @@ -536,6 +536,10 @@ (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) +#!+(or x86 x86-64) +(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int + (pointer system-area-pointer)) + (declaim (inline component-from-component-ptr)) (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) @@ -654,28 +658,12 @@ (defun descriptor-sap (x) (int-sap (get-lisp-obj-address x))) -(defun nth-interrupt-context (n) - (declare (type (unsigned-byte 32) n) - (optimize (speed 3) (safety 0))) - (sb!alien:sap-alien (sb!vm::current-thread-offset-sap - (+ sb!vm::thread-interrupt-contexts-offset n)) - (* os-context-t))) - ;;; Return the top frame of the control stack as it was before calling ;;; this function. (defun top-frame () (/noshow0 "entering TOP-FRAME") - ;; check to see if we can get the context by calling - ;; nth-interrupt-context, otherwise use the (%caller-frame-and-pc - ;; vop). - (let ((context (nth-interrupt-context 0))) - (if context - (compute-calling-frame - (int-sap (sb!vm:context-register context - sb!vm::cfp-offset)) - (context-pc context) nil) - (multiple-value-bind (fp pc) (%caller-frame-and-pc) - (compute-calling-frame (descriptor-sap fp) pc nil))))) + (multiple-value-bind (fp pc) (%caller-frame-and-pc) + (compute-calling-frame (descriptor-sap fp) pc nil))) ;;; Flush all of the frames above FRAME, and renumber all the frames ;;; below FRAME. @@ -686,6 +674,11 @@ ((not (frame-p frame))) (setf (frame-number frame) number))) +(defun find-saved-frame-down (fp up-frame) + (multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp) + (when saved-fp + (compute-calling-frame (descriptor-sap saved-fp) saved-pc up-frame)))) + ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. (defun frame-down (frame) @@ -715,8 +708,9 @@ (when (control-stack-pointer-valid-p fp) #!+(or x86 x86-64) (multiple-value-bind (ok ra ofp) (x86-call-context fp) - (and ok - (compute-calling-frame ofp ra frame))) + (if ok + (compute-calling-frame ofp ra frame) + (find-saved-frame-down fp frame))) #!-(or x86 x86-64) (compute-calling-frame #!-alpha @@ -792,7 +786,9 @@ #!-(or x86 x86-64) (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) + (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (control-stack-pointer-valid-p caller) + (/noshow0 "in WHEN") (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind (word-offset code) @@ -828,6 +824,7 @@ "bogus stack frame")) (t (debug-fun-from-pc code pc-offset))))) + (/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) @@ -877,6 +874,13 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) +(defun nth-interrupt-context (n) + (declare (type (unsigned-byte 32) n) + (optimize (speed 3) (safety 0))) + (sb!alien:sap-alien (sb!vm::current-thread-offset-sap + (+ sb!vm::thread-interrupt-contexts-offset n)) + (* os-context-t))) + #!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) @@ -920,13 +924,18 @@ #!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) + (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) + (/noshow0 "at head of WITH-ALIEN") (let ((scp (nth-interrupt-context index))) + (/noshow0 "got SCP") (when (= (sap-int frame-pointer) (sb!vm:context-register scp sb!vm::cfp-offset)) (without-gcing + (/noshow0 "in WITHOUT-GCING") (let ((code (code-object-from-bits (sb!vm:context-register scp sb!vm::code-offset)))) + (/noshow0 "got CODE") (when (symbolp code) (return (values code 0 scp))) (let* ((code-header-len (* (get-header-data code) @@ -963,6 +972,7 @@ ;; pc-offset to 0 to keep the backtrace from ;; exploding. (setf pc-offset 0))))) + (/noshow0 "returning from FIND-ESCAPED-FRAME") (return (if (eq (%code-debug-info code) :bogus-lra) (let ((real-lra (code-header-ref code @@ -991,7 +1001,7 @@ register." #!-(or x86 x86-64) (defun code-object-from-bits (bits) (declare (type (unsigned-byte 32) bits)) - (let ((object (make-lisp-obj bits))) + (let ((object (make-lisp-obj bits nil))) (if (functionp object) (or (fun-code-header object) :undefined-function) @@ -1999,12 +2009,12 @@ register." (compiled-debug-var-sc-offset debug-var)))))) ;;; a helper function for working with possibly-invalid values: -;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid. +;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid. ;;; ;;; (Such values can arise in registers on machines with conservative ;;; GC, and might also arise in debug variable locations when ;;; those variables are invalid.) -(defun make-valid-lisp-obj (val) +(defun make-lisp-obj (val &optional (errorp t)) (if (or ;; fixnum (zerop (logand val sb!vm:fixnum-tag-mask)) @@ -2017,10 +2027,13 @@ register." ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer + #!+(or x86 x86-64) + (not (zerop (valid-lisp-pointer-p (int-sap val)))) + ;; FIXME: There is no fundamental reason not to use the above + ;; function on other platforms as well, but I didn't have + ;; others available while doing this. --NS 2007-06-21 + #!-(or x86 x86-64) (and (logbitp 0 val) - ;; Check that the pointer is valid. XXX Could do a better - ;; job. FIXME: e.g. by calling out to an is_valid_pointer - ;; routine in the C runtime support code (or (< sb!vm:read-only-space-start val (* sb!vm:*read-only-space-free-pointer* sb!vm:n-word-bytes)) @@ -2029,8 +2042,12 @@ register." sb!vm:n-word-bytes)) (< (current-dynamic-space-start) val (sap-int (dynamic-space-free-pointer)))))) - (make-lisp-obj val) - :invalid-object)) + (values (%make-lisp-obj val) t) + (if errorp + (error "~S is not a valid argument to ~S" + val 'make-lisp-obj) + (values (make-unprintable-object (format nil "invalid object #x~X" val)) + nil)))) #!-(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) @@ -2066,8 +2083,8 @@ register." #.sb!vm:descriptor-reg-sc-number #!+rt #.sb!vm:word-pointer-reg-sc-number) (sb!sys:without-gcing - (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - + (with-escaped-value (val) + (make-lisp-obj val nil)))) (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) @@ -2202,7 +2219,7 @@ register." ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) (without-gcing (with-escaped-value (val) - (make-valid-lisp-obj val)))) + (make-lisp-obj val nil)))) (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) @@ -2632,13 +2649,6 @@ register." ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 ;;; gets the first binding, and 1 gets the AREF form. -;;; temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS -(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - -;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS -(defvar *form-number-circularity-table* (make-hash-table :test 'eq)) - ;;; This returns a table mapping form numbers to source-paths. A ;;; source-path indicates a descent into the TOPLEVEL-FORM form, ;;; going directly to the subform corressponding to the form number. @@ -2647,32 +2657,32 @@ register." ;;; NODE-SOURCE-PATH; that is, the first element is the form number and ;;; the last is the TOPLEVEL-FORM number. (defun form-number-translations (form tlf-number) - (clrhash *form-number-circularity-table*) - (setf (fill-pointer *form-number-temp*) 0) - (sub-translate-form-numbers form (list tlf-number)) - (coerce *form-number-temp* 'simple-vector)) -(defun sub-translate-form-numbers (form path) - (unless (gethash form *form-number-circularity-table*) - (setf (gethash form *form-number-circularity-table*) t) - (vector-push-extend (cons (fill-pointer *form-number-temp*) path) - *form-number-temp*) - (let ((pos 0) - (subform form) - (trail form)) - (declare (fixnum pos)) - (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-translate-form-numbers fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) + (let ((seen nil) + (translations (make-array 12 :fill-pointer 0 :adjustable t))) + (labels ((translate1 (form path) + (unless (member form seen) + (push form seen) + (vector-push-extend (cons (fill-pointer translations) path) + translations) + (let ((pos 0) + (subform form) + (trail form)) + (declare (fixnum pos)) + (macrolet ((frob () + '(progn + (when (atom subform) (return)) + (let ((fm (car subform))) + (when (consp fm) + (translate1 fm (cons pos path))) + (incf pos)) + (setq subform (cdr subform)) + (when (eq subform trail) (return))))) + (loop + (frob) + (frob) + (setq trail (cdr trail)))))))) + (translate1 form (list tlf-number))) + (coerce translations 'simple-vector))) ;;; FORM is a top level form, and path is a source-path into it. This ;;; returns the form indicated by the source-path. Context is the @@ -2861,7 +2871,7 @@ register." ;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. -(defvar *fun-end-cookies* (make-hash-table :test 'eq)) +(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t)) ;;; This returns a hook function for the start helper breakpoint ;;; associated with a :FUN-END breakpoint. The returned function @@ -3113,7 +3123,7 @@ register." ;;;; breakpoint handlers (layer between C and exported interface) ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. -(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) +(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t)) ;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. @@ -3135,6 +3145,8 @@ register." ;;; We use this when there are no longer any active breakpoints ;;; corresponding to DATA. (defun delete-breakpoint-data (data) + ;; Again, this looks brittle. Is there no danger of being interrupted + ;; here? (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) (gethash component *component-breakpoint-offsets*) @@ -3238,6 +3250,8 @@ register." ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) + ;; FIXME: This looks brittle: what if we are interrupted somewhere + ;; here? ...or do we have interrupts disabled here? (delete-breakpoint-data data) (let* ((scp (locally @@ -3360,8 +3374,8 @@ register." ;;; or replace the function that's about to be called with a wrapper ;;; which will signal the condition. -(defun handle-single-step-trap (context-sap kind callee-register-offset) - (let ((context (sb!alien:sap-alien context-sap (* os-context-t)))) +(defun handle-single-step-trap (kind callee-register-offset) + (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*)))) ;; The following calls must get tail-call eliminated for ;; *STEP-FRAME* to get set correctly on non-x86. (if (= kind single-step-before-trap) @@ -3376,9 +3390,9 @@ register." ;; sense in signaling the condition. (when step-info (let ((*step-frame* - #+(or x86 x86-64) + #!+(or x86 x86-64) (signal-context-frame (sb!alien::alien-sap context)) - #-(or x86 x86-64) + #!-(or x86 x86-64) ;; KLUDGE: Use the first non-foreign frame as the ;; *STACK-TOP-HINT*. Getting the frame from the signal ;; context as on x86 would be cleaner, but @@ -3405,7 +3419,7 @@ register." (defun handle-single-step-around-trap (context callee-register-offset) ;; Fetch the function / fdefn we're about to call from the ;; appropriate register. - (let* ((callee (sb!kernel::make-lisp-obj + (let* ((callee (make-lisp-obj (context-register context callee-register-offset))) (step-info (single-step-info-from-context context))) ;; If there was not enough debug information available, there's no