X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=4052fdce917e4242e21daabda901bb5c26046183;hb=5423b2e0f7e7643001ed3ef2f66681c0114a72a6;hp=a7ee64154001d28a77308b5c436fc5e039a7c375;hpb=3c901eea59aeb4716a7288c943f30c4282af41de;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a7ee641..4052fdc 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)) @@ -658,23 +662,8 @@ ;;; this function. (defun top-frame () (/noshow0 "entering TOP-FRAME") - ;; if we have a stored context in *internal-error-context*, use it - ;; to compute the fp and pc (and rebind this variable to nil in case - ;; we signal another error), otherwise use the (%caller-frame-and-pc - ;; vop). - - (if sb!kernel::*internal-error-context* - (let* ((context sb!kernel::*internal-error-context*) - (sb!kernel::*internal-error-context* nil) - (alien-context (locally - (declare (optimize (inhibit-warnings 3))) - (sb!alien:sap-alien context (* os-context-t))))) - (compute-calling-frame - (int-sap (sb!vm:context-register alien-context - sb!vm::cfp-offset)) - (context-pc alien-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. @@ -791,7 +780,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) @@ -827,6 +818,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) @@ -926,13 +918,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) @@ -969,6 +966,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 @@ -997,7 +995,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) @@ -2005,12 +2003,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)) @@ -2023,10 +2021,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)) @@ -2035,8 +2036,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) @@ -2072,8 +2077,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))) @@ -2208,7 +2213,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))) @@ -2638,13 +2643,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. @@ -2653,32 +2651,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 @@ -2867,7 +2865,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 @@ -3119,7 +3117,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. @@ -3141,6 +3139,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*) @@ -3244,6 +3244,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 @@ -3366,8 +3368,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) @@ -3411,7 +3413,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