X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=11c74df7145671b9cecd711a2ad16a81d32b3f49;hb=3b96e3dcd35802e14cd86dc193debcc53a223c03;hp=9d1097f23252f40c5991e519ca50491580b2b3b1;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 9d1097f..11c74df 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -320,8 +320,6 @@ (%function nil))) (:copier nil)) %name) - -(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) ;;;; DEBUG-BLOCKs @@ -356,8 +354,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 @@ -466,12 +462,12 @@ str))) (defstruct (compiled-code-location - (:include code-location) - (:constructor make-known-code-location - (pc debug-fun %tlf-offset %form-number - %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-fun)) - (:copier nil)) + (:include code-location) + (:constructor make-known-code-location + (pc debug-fun %tlf-offset %form-number + %live-set kind step-info &aux (%unknown-p nil))) + (:constructor make-compiled-code-location (pc debug-fun)) + (:copier nil)) ;; an index into DEBUG-FUN's component slot (pc nil :type index) ;; a bit-vector indexed by a variable's position in @@ -480,7 +476,8 @@ (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (unexported) To see SB!C::LOCATION-KIND, do ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). - (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))) + (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)) + (step-info :unparsed :type (or (member :unparsed :foo) simple-string))) ;;;; DEBUG-SOURCEs @@ -509,7 +506,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)) @@ -525,15 +522,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) @@ -541,9 +544,6 @@ ;;;; (OR X86 X86-64) support -#!+(or x86 x86-64) -(progn - (defun compute-lra-data-from-pc (pc) (declare (type system-area-pointer pc)) (let ((component-ptr (component-ptr-from-pc pc))) @@ -557,6 +557,9 @@ ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) +#!+(or x86 x86-64) +(progn + (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset) ;;; Check for a valid return address - it could be any valid C/Lisp @@ -584,74 +587,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 @@ -705,9 +698,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))) - #!-(or x86 x86-64) + (multiple-value-bind (ok ra ofp) (x86-call-context fp) + (and ok + (compute-calling-frame ofp ra frame))) + #!-(or x86 x86-64) (compute-calling-frame #!-alpha (sap-ref-sap fp (* ocfp-save-offset @@ -725,16 +719,6 @@ ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; standard save location offset on the stack. LOC is the saved ;;; SC-OFFSET describing the main location. -#!-(or x86 x86-64) -(defun get-context-value (frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-access-debug-var-slot pointer loc escaped) - (stack-ref pointer stack-slot)))) -#!+(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -742,6 +726,9 @@ (escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot pointer loc escaped) + #!-(or x86 x86-64) + (stack-ref pointer stack-slot) + #!+(or x86 x86-64) (ecase stack-slot (#.ocfp-save-offset (stack-ref pointer stack-slot)) @@ -749,17 +736,6 @@ (sap-ref-sap pointer (- (* (1+ stack-slot) sb!vm::n-word-bytes)))))))) -#!-(or x86 x86-64) -(defun (setf get-context-value) (value frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-set-debug-var-slot pointer loc value escaped) - (setf (stack-ref pointer stack-slot) value)))) - -#!+(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -767,6 +743,9 @@ (escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot pointer loc value escaped) + #!-(or x86 x86-64) + (setf (stack-ref pointer stack-slot) value) + #!+(or x86 x86-64) (ecase stack-slot (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) @@ -797,7 +776,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) @@ -833,11 +814,13 @@ "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) (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) + #!+(or x86 x86-64) (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) @@ -931,13 +914,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) @@ -947,11 +935,6 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - ;; Check to see whether we were executing in a branch - ;; delay slot. - #!+(or pmax sgi) ; pmax only (and broken anyway) - (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) - (incf pc-offset sb!vm:n-word-bytes)) (let ((code-size (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:n-word-bytes))) @@ -979,6 +962,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 @@ -1004,21 +988,22 @@ register." ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the ;;; undefined-function. +#!-(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) (let ((lowtag (lowtag-of object))) - (if (= lowtag sb!vm:other-pointer-lowtag) - (let ((widetag (widetag-of object))) - (cond ((= widetag sb!vm:code-header-widetag) - object) - ((= widetag sb!vm:return-pc-header-widetag) - (lra-code-header object)) - (t - nil)))))))) + (when (= lowtag sb!vm:other-pointer-lowtag) + (let ((widetag (widetag-of object))) + (cond ((= widetag sb!vm:code-header-widetag) + object) + ((= widetag sb!vm:return-pc-header-widetag) + (lra-code-header object)) + (t + nil)))))))) ;;;; frame utilities @@ -1138,6 +1123,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 @@ -1563,10 +1590,12 @@ register." (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))) + live-set-len blocks i)) + (step-info (sb!c:read-var-string blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset - form-number live-set kind) + form-number live-set kind + step-info) locations-buffer) (setf last-pc pc)))) (block (make-compiled-debug-block @@ -1884,6 +1913,8 @@ register." (compiled-code-location-%live-set loc)) (setf (compiled-code-location-kind code-location) (compiled-code-location-kind loc)) + (setf (compiled-code-location-step-info code-location) + (compiled-code-location-step-info loc)) (return-from fill-in-code-location t)))))))) ;;;; operations on DEBUG-BLOCKs @@ -1968,12 +1999,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)) @@ -1986,20 +2017,27 @@ register." ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer - (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)) - (< sb!vm:static-space-start val - (* sb!vm:*static-space-free-pointer* - sb!vm:n-word-bytes)) - (< (current-dynamic-space-start) val - (sap-int (dynamic-space-free-pointer)))))) - (make-lisp-obj val) - :invalid-object)) + #!+(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) + (or (< sb!vm:read-only-space-start val + (* sb!vm:*read-only-space-free-pointer* + sb!vm:n-word-bytes)) + (< sb!vm:static-space-start val + (* sb!vm:*static-space-free-pointer* + sb!vm:n-word-bytes)) + (< (current-dynamic-space-start) val + (sap-int (dynamic-space-free-pointer)))))) + (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) @@ -2035,8 +2073,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))) @@ -2171,7 +2209,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))) @@ -2601,13 +2639,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. @@ -2616,32 +2647,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 @@ -3063,7 +3094,7 @@ register." ;;; 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!alien:unsigned-long +(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int (code-obj sb!alien:unsigned-long) (pc-offset sb!alien:int)) @@ -3073,11 +3104,11 @@ register." (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)) + (old-inst sb!alien:unsigned-int)) (sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void (scp (* os-context-t)) - (orig-inst sb!alien:unsigned-long)) + (orig-inst sb!alien:unsigned-int)) ;;;; breakpoint handlers (layer between C and exported interface) @@ -3146,7 +3177,7 @@ register." (unless (member data *executing-breakpoint-hooks*) (let ((*executing-breakpoint-hooks* (cons data *executing-breakpoint-hooks*))) - (invoke-breakpoint-hooks breakpoints component offset))) + (invoke-breakpoint-hooks breakpoints signal-context))) ;; At this point breakpoints may not hold the same list as ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed ;; a breakpoint deactivation. In fact, if all breakpoints were @@ -3155,24 +3186,22 @@ register." ;; no more breakpoints active at this location, then the normal ;; instruction has been put back, and we do not need to ;; DO-DISPLACED-INST. - (let ((data (breakpoint-data component offset nil))) - (when (and data (breakpoint-data-breakpoints data)) - ;; The breakpoint is still active, so we need to execute the - ;; displaced instruction and leave the breakpoint instruction - ;; behind. The best way to do this is different on each machine, - ;; so we just leave it up to the C code. - (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() _does_ sigreturn(), - ;; it's polite to warn here - #!+(and sparc solaris) - (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) - -(defun invoke-breakpoint-hooks (breakpoints component offset) - (let* ((debug-fun (debug-fun-from-pc component offset)) - (frame (do ((f (top-frame) (frame-down f))) - ((eq debug-fun (frame-debug-fun f)) f)))) + (setf data (breakpoint-data component offset nil)) + (when (and data (breakpoint-data-breakpoints data)) + ;; The breakpoint is still active, so we need to execute the + ;; displaced instruction and leave the breakpoint instruction + ;; behind. The best way to do this is different on each machine, + ;; so we just leave it up to the C code. + (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() _does_ sigreturn(), + ;; it's polite to warn here + #!+(and sparc solaris) + (error "BREAKPOINT-DO-DISPLACED-INST returned?"))) + +(defun invoke-breakpoint-hooks (breakpoints signal-context) + (let* ((frame (signal-context-frame signal-context))) (dolist (bpt breakpoints) (funcall (breakpoint-hook-fun bpt) frame @@ -3184,6 +3213,16 @@ register." (breakpoint-unknown-return-partner bpt) bpt))))) +(defun signal-context-frame (signal-context) + (let* ((scp + (locally + (declare (optimize (inhibit-warnings 3))) + (sb!alien:sap-alien signal-context (* os-context-t)))) + (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset)))) + (compute-calling-frame cfp + (sb!vm:context-pc scp) + nil))) + (defun handle-fun-end-breakpoint (offset component context) (let ((data (breakpoint-data component offset nil))) (unless data @@ -3204,10 +3243,7 @@ register." (locally (declare (optimize (inhibit-warnings 3))) (sb!alien:sap-alien signal-context (* os-context-t)))) - (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset)) - (f (top-frame) (frame-down f))) - ((= cfp (sap-int (frame-pointer f))) f) - (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp)))) + (frame (signal-context-frame signal-context)) (component (breakpoint-data-component data)) (cookie (gethash component *fun-end-cookies*))) (remhash component *fun-end-cookies*) @@ -3307,3 +3343,137 @@ register." ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) + + +;;;; Single-stepping + +;;; The single-stepper works by inserting conditional trap instructions +;;; into the generated code (see src/compiler/*/call.lisp), currently: +;;; +;;; 1) Before the code generated for a function call that was +;;; translated to a VOP +;;; 2) Just before the call instruction for a full call +;;; +;;; In both cases, the trap will only be executed if stepping has been +;;; enabled, in which case it'll ultimately be handled by +;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition, +;;; or replace the function that's about to be called with a wrapper +;;; which will signal the condition. + +(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) + (handle-single-step-before-trap context) + (handle-single-step-around-trap context callee-register-offset)))) + +(defvar *step-frame* nil) + +(defun handle-single-step-before-trap (context) + (let ((step-info (single-step-info-from-context context))) + ;; If there was not enough debug information available, there's no + ;; sense in signaling the condition. + (when step-info + (let ((*step-frame* + #+(or x86 x86-64) + (signal-context-frame (sb!alien::alien-sap context)) + #-(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 + ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all + ;; on non-x86. + (loop with frame = (frame-down (top-frame)) + while frame + for dfun = (frame-debug-fun frame) + do (when (typep dfun 'compiled-debug-fun) + (return frame)) + do (setf frame (frame-down frame))))) + (sb!impl::step-form step-info + ;; We could theoretically store information in + ;; the debug-info about to determine the + ;; arguments here, but for now let's just pass + ;; on it. + :unknown))))) + +;;; This function will replace the fdefn / function that was in the +;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To +;;; ensure that the full call will use the wrapper instead of the +;;; original, conditional trap must be emitted before the fdefn / +;;; function is converted into a raw address. +(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 (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 + ;; sense in signaling the condition. + (unless step-info + (return-from handle-single-step-around-trap)) + (let* ((fun (lambda (&rest args) + (flet ((call () + (apply (typecase callee + (fdefn (fdefn-fun callee)) + (function callee)) + args))) + ;; Signal a step condition + (let* ((step-in + (let ((*step-frame* (frame-down (top-frame)))) + (sb!impl::step-form step-info args)))) + ;; And proceed based on its return value. + (if step-in + ;; STEP-INTO was selected. Use *STEP-OUT* to + ;; let the stepper know that selecting the + ;; STEP-OUT restart is valid inside this + (let ((sb!impl::*step-out* :maybe)) + ;; Pass the return values of the call to + ;; STEP-VALUES, which will signal a + ;; condition with them in the VALUES slot. + (unwind-protect + (multiple-value-call #'sb!impl::step-values + step-info + (call)) + ;; If the user selected the STEP-OUT + ;; restart during the call, resume + ;; stepping + (when (eq sb!impl::*step-out* t) + (sb!impl::enable-stepping)))) + ;; STEP-NEXT / CONTINUE / OUT selected: + ;; Disable the stepper for the duration of + ;; the call. + (sb!impl::with-stepping-disabled + (call))))))) + (new-callee (etypecase callee + (fdefn + (let ((fdefn (make-fdefn (gensym)))) + (setf (fdefn-fun fdefn) fun) + fdefn)) + (function fun)))) + ;; And then store the wrapper in the same place. + (setf (context-register context callee-register-offset) + (get-lisp-obj-address new-callee))))) + +;;; Given a signal context, fetch the step-info that's been stored in +;;; the debug info at the trap point. +(defun single-step-info-from-context (context) + (multiple-value-bind (pc-offset code) + (compute-lra-data-from-pc (context-pc context)) + (let* ((debug-fun (debug-fun-from-pc code pc-offset)) + (location (code-location-from-pc debug-fun + pc-offset + nil))) + (handler-case + (progn + (fill-in-code-location location) + (code-location-debug-source location) + (compiled-code-location-step-info location)) + (debug-condition () + nil))))) + +;;; Return the frame that triggered a single-step condition. Used to +;;; provide a *STACK-TOP-HINT*. +(defun find-stepped-frame () + (or *step-frame* + (top-frame)))