X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=4b6be6d4d3c74e3ad3142fa3919d933eda48f4e0;hb=1dc38285834db2d374a156a4f68b19096341deb3;hp=532963e3c5f6d9fd60e454a1f5094ac026afd75a;hpb=90a83478829f33b91f6300c183b374a968bc13c6;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 532963e..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)) @@ -526,15 +526,21 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (zerop (logand (sap-int x) #b11))) + (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (zerop (logand (sap-int x) #b11))))) + (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask))))) +(declaim (inline component-ptr-from-pc)) (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)) (make-lisp-obj (logior (sap-int component-ptr) @@ -585,74 +591,64 @@ ;;; ;;; 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) - (cond - ((not (control-stack-pointer-valid-p fp)) - #+nil (format t "debug invalid fp ~S~%" fp) - nil) - (t - ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) - sb!vm::n-word-bytes)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) - sb!vm::n-word-bytes)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) - #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra) - (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~%" - 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 (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 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) - (values lisp-ra lisp-ocfp)) - (c-path-fp - ;; The C convention is looking good. - #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) - (values c-ra c-ocfp)) - (t - ;; Neither seems right? - #+nil (format t "debug: no valid2 fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))) - ((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) (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) - (values c-ra c-ocfp)) - (t - #+nil (format t "debug: no valid fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))))) +(declaim (maybe-inline x86-call-context)) +(defun x86-call-context (fp) + (declare (type system-area-pointer fp)) + (labels ((fail () + (values nil + (int-sap 0) + (int-sap 0))) + (handle (fp) + (cond + ((not (control-stack-pointer-valid-p fp)) + (fail)) + (t + ;; Check the two possible frame pointers. + (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) + sb!vm::n-word-bytes)))) + (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) + sb!vm::n-word-bytes)))) + (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) + (control-stack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra) + (sap> c-ocfp fp) + (control-stack-pointer-valid-p c-ocfp) + (ra-pointer-valid-p c-ra)) + ;; Look forward another step to check their validity. + (let ((lisp-ok (handle lisp-ocfp)) + (c-ok (handle c-ocfp))) + (cond ((and lisp-ok c-ok) + ;; Both still seem valid - choose the lisp frame. + #!+freebsd + (if (sap> lisp-ocfp c-ocfp) + (values t lisp-ra lisp-ocfp) + (values t c-ra c-ocfp)) + #!-freebsd + (values t lisp-ra lisp-ocfp)) + (lisp-ok + ;; The lisp convention is looking good. + (values t lisp-ra lisp-ocfp)) + (c-ok + ;; The C convention is looking good. + (values t c-ra c-ocfp)) + (t + ;; Neither seems right? + (fail))))) + ((and (sap> lisp-ocfp fp) + (control-stack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra)) + ;; The lisp convention is looking good. + (values t lisp-ra lisp-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. + (values t c-ra c-ocfp)) + (t + (fail)))))))) + (handle fp))) ) ; #+x86 PROGN @@ -678,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) @@ -706,8 +707,10 @@ (let ((fp (frame-pointer frame))) (when (control-stack-pointer-valid-p fp) #!+(or x86 x86-64) - (multiple-value-bind (ra ofp) (x86-call-context fp) - (and ra (compute-calling-frame ofp ra frame))) + (multiple-value-bind (ok ra ofp) (x86-call-context fp) + (if ok + (compute-calling-frame ofp ra frame) + (find-saved-frame-down fp frame))) #!-(or x86 x86-64) (compute-calling-frame #!-alpha @@ -783,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) @@ -819,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) @@ -918,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) @@ -961,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 @@ -989,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) @@ -1121,6 +1133,48 @@ register." (sap-ref-32 catch (* sb!vm:catch-block-previous-catch-slot sb!vm:n-word-bytes))))))) + +;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG +(defun replace-frame-catch-tag (frame old-tag new-tag) + (let ((catch (descriptor-sap sb!vm:*current-catch-block*)) + (fp (frame-pointer frame))) + (loop until (zerop (sap-int catch)) + 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 ((current-tag + #!-(or x86 x86-64) + (stack-ref catch sb!vm:catch-block-tag-slot) + #!+(or x86 x86-64) + (make-lisp-obj + (sap-ref-word catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes))))) + (when (eq current-tag old-tag) + #!-(or x86 x86-64) + (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag) + #!+(or x86 x86-64) + (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes)) + (get-lisp-obj-address new-tag))))) + do (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))))))) + + ;;;; operations on DEBUG-FUNs @@ -1955,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)) @@ -1973,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)) @@ -1985,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) @@ -2022,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))) @@ -2158,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))) @@ -2588,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. @@ -2603,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 @@ -2817,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 @@ -3069,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. @@ -3091,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*) @@ -3194,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 @@ -3316,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) @@ -3332,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 @@ -3361,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