X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=c61ab787849464e83eed6122436de0d38a1b114e;hb=3b45a7b66afe95080562d266dd447b1286abece0;hp=5e35ad2ab56460898f3224be3ba789520fd31fe4;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 5e35ad2..c61ab78 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -47,7 +47,6 @@ #!+sb-doc (:documentation "There is no usable debugging information available.") (:report (lambda (condition stream) - (declare (ignore condition)) (fresh-line stream) (format stream "no debug information available for ~S~%" @@ -187,7 +186,7 @@ ;;;; data structures created by the compiler. Whenever comments ;;;; preface an object or type with "compiler", they refer to the ;;;; internal compiler thing, not to the object or type with the same -;;;; name in the "DI" package. +;;;; name in the "SB-DI" package. ;;;; DEBUG-VARs @@ -968,6 +967,7 @@ ;;; to replace FRAME. The interpreted frame points to FRAME. (defun possibly-an-interpreted-frame (frame up-frame) (if (or (not frame) + #!+sb-interpreter (not (eq (debug-function-name (frame-debug-function frame)) 'sb!eval::internal-apply-loop)) *debugging-interpreter* @@ -1107,24 +1107,10 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped))))) -#!-(or gengc x86) -;;; FIXME: The original CMU CL code had support for this case, but it -;;; must have been fairly stale even in CMU CL, since it had -;;; references to the MIPS package, and there have been enough -;;; relevant changes in SBCL (particularly using -;;; POSIX/SIGACTION0-style signal context instead of BSD-style -;;; sigcontext) that this code is unmaintainable (since as of -;;; sbcl-0.6.7, and for the foreseeable future, we can't test it, -;;; since we only support X86 and its gencgc). -;;; -;;; If we restore this case, the best approach would be to go back to -;;; the original CMU CL code and start from there. -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) - (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil)) + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) @@ -1157,6 +1143,50 @@ (return (values code pc-offset context)))))))))) +#!-x86 +(defun find-escaped-frame (frame-pointer) + (declare (type system-area-pointer frame-pointer)) + (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) + (sb!alien:with-alien + ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) + (let ((scp (sb!alien:deref lisp-interrupt-contexts index))) + (when (= (sap-int frame-pointer) + (sb!vm:context-register scp sb!vm::cfp-offset)) + (without-gcing + (let ((code (code-object-from-bits + (sb!vm:context-register scp sb!vm::code-offset)))) + (when (symbolp code) + (return (values code 0 scp))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:word-bytes)) + (pc-offset + (- (sap-int (sb!vm:context-pc scp)) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-type) + 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:word-bytes)) + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + (setf pc-offset + (- (sb!vm:context-register scp sb!vm::lra-offset) + (get-lisp-obj-address code) + code-header-len))) + (return + (if (eq (%code-debug-info code) :bogus-lra) + (let ((real-lra (code-header-ref code + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + nil)) + (values code pc-offset scp))))))))))) + ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the ;;; undefined-function. @@ -1263,7 +1293,7 @@ code-locations at which execution would continue with frame as the top frame if someone threw to the corresponding tag." (let ((catch - #!-gengc (descriptor-sap sb!impl::*current-catch-block*) + #!-gengc (descriptor-sap *current-catch-block*) #!+gengc (mutator-current-catch-block)) (res nil) (fp (frame-pointer (frame-real-frame frame)))) @@ -1420,7 +1450,8 @@ (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) (#.sb!vm:funcallable-instance-header-type - (cond ((sb!eval:interpreted-function-p fun) + (cond #!+sb-interpreter + ((sb!eval:interpreted-function-p fun) (make-interpreted-debug-function (or (sb!eval::interpreted-function-definition fun) (sb!eval::convert-interpreted-fun fun)))) @@ -2442,6 +2473,7 @@ (if (indirect-value-cell-p res) (sb!c:value-cell-ref res) res))) + #!+sb-interpreter (interpreted-debug-var (aver (typep frame 'interpreted-frame)) (sb!eval::leaf-value-lambda-var @@ -2454,16 +2486,17 @@ ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value ;;; cell if the variable is both closed over and set. (defun access-compiled-debug-var-slot (debug-var frame) + (declare (optimize (speed 1))) (let ((escaped (compiled-frame-escaped frame))) (if escaped - (sub-access-debug-var-slot - (frame-pointer frame) - (compiled-debug-var-sc-offset debug-var) - escaped) - (sub-access-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-var-save-sc-offset debug-var) - (compiled-debug-var-sc-offset debug-var)))))) + (sub-access-debug-var-slot + (frame-pointer frame) + (compiled-debug-var-sc-offset debug-var) + escaped) + (sub-access-debug-var-slot + (frame-pointer frame) + (or (compiled-debug-var-save-sc-offset debug-var) + (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. @@ -2498,12 +2531,148 @@ (make-lisp-obj val) :invalid-object)) -;;; CMU CL had -;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..) -;;; code for this case. #!-x86 -(eval-when (:compile-toplevel :load-toplevel :execute) - (error "hopelessly stale")) +(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + (macrolet ((with-escaped-value ((var) &body forms) + `(if escaped + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) + (escaped-float-value (format) + `(if escaped + (sb!vm:context-float-register + escaped + (sb!c:sc-offset-offset sc-offset) + ',format) + :invalid-value-for-unescaped-register-storage)) + (with-nfp ((var) &body body) + `(let ((,var (if escaped + (sb!sys:int-sap + (sb!vm:context-register escaped + sb!vm::nfp-offset)) + #!-alpha + (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) + #!+alpha + (sb!vm::make-number-stack-pointer + (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) + ,@body))) + (ecase (sb!c:sc-offset-scn sc-offset) + ((#.sb!vm:any-reg-sc-number + #.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)))) + + (#.sb!vm:base-char-reg-sc-number + (with-escaped-value (val) + (code-char val))) + (#.sb!vm:sap-reg-sc-number + (with-escaped-value (val) + (sb!sys:int-sap val))) + (#.sb!vm:signed-reg-sc-number + (with-escaped-value (val) + (if (logbitp (1- sb!vm:word-bits) val) + (logior val (ash -1 sb!vm:word-bits)) + val))) + (#.sb!vm:unsigned-reg-sc-number + (with-escaped-value (val) + val)) + (#.sb!vm:non-descriptor-reg-sc-number + (error "Local non-descriptor register access?")) + (#.sb!vm:interior-reg-sc-number + (error "Local interior register access?")) + (#.sb!vm:single-reg-sc-number + (escaped-float-value single-float)) + (#.sb!vm:double-reg-sc-number + (escaped-float-value double-float)) + #!+long-float + (#.sb!vm:long-reg-sc-number + (escaped-float-value long-float)) + (#.sb!vm:complex-single-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'single-float) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:complex-double-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'double-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1) + 'double-float)) + :invalid-value-for-unescaped-register-storage)) + #!+long-float + (#.sb!vm:complex-long-reg-sc-number + (if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'long-float) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) + 'long-float)) + :invalid-value-for-unescaped-register-storage)) + (#.sb!vm:single-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:double-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + #!+long-float + (#.sb!vm:long-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:complex-single-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:word-bytes))))) + (#.sb!vm:complex-double-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:word-bytes))))) + #!+long-float + (#.sb!vm:complex-long-stack-sc-number + (with-nfp (nfp) + (complex + (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)) + (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) + #!+sparc 4) + sb!vm:word-bytes))))) + (#.sb!vm:control-stack-sc-number + (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) + (#.sb!vm:base-char-stack-sc-number + (with-nfp (nfp) + (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))) + (#.sb!vm:unsigned-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:signed-stack-sc-number + (with-nfp (nfp) + (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes)))) + (#.sb!vm:sap-stack-sc-number + (with-nfp (nfp) + (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:word-bytes))))))) #!+x86 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) @@ -2648,6 +2817,7 @@ (if (indirect-value-cell-p current-value) (sb!c:value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) + #!+sb-interpreter (interpreted-debug-var (aver (typep frame 'interpreted-frame)) (sb!eval::set-leaf-value-lambda-var @@ -2698,13 +2868,13 @@ sb!vm::nfp-offset)) #!-alpha (sap-ref-sap fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)) #!+alpha - (%alpha::make-number-stack-pointer + (sb!vm::make-number-stack-pointer (sap-ref-32 fp - (* sb!vm::nfp-save-offset - sb!vm:word-bytes)))))) + (* sb!vm::nfp-save-offset + sb!vm:word-bytes)))))) ,@body))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number @@ -3582,8 +3752,10 @@ ;; so we just leave it up to the C code. (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) - ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. - #!-(or hpux irix x86) + ;; Some platforms have no usable sigreturn() call. If your + ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), + ;; add it to this list. + #!-(or hpux irix x86 alpha) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset)