X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=9964063c1915c3314192dbe9b38bd45230033c7e;hb=77d94d36bcfd3d5eea73ad51e6ee621a8938f995;hp=320c7c3f5b15d971a8f19d36791c0995b467a4ab;hpb=78689792e8f8d20b3b931f508f3a9eca81b64f1f;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 320c7c3..9964063 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -41,17 +41,6 @@ "All DEBUG-CONDITIONs inherit from this type. These are serious conditions that must be handled, but they are not programmer errors.")) -(define-condition no-debug-info (debug-condition) - ((code-component :reader no-debug-info-code-component - :initarg :code-component)) - #!+sb-doc - (:documentation "There is no usable debugging information available.") - (:report (lambda (condition stream) - (fresh-line stream) - (format stream - "no debug information available for ~S~%" - (no-debug-info-code-component condition))))) - (define-condition no-debug-fun-returns (debug-condition) ((debug-fun :reader no-debug-fun-returns-debug-fun :initarg :debug-fun)) @@ -64,8 +53,8 @@ (no-debug-fun-returns-debug-fun condition)))) (format stream "~&Cannot return values from ~:[frame~;~:*~S~] since ~ - the debug information lacks details about returning ~ - values here." + the debug information lacks details about returning ~ + values here." fun))))) (define-condition no-debug-blocks (debug-condition) @@ -780,10 +769,10 @@ (#.lra-save-offset (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) -(defun foreign-function-debug-name (sap) - (multiple-value-bind (name file base offset) (foreign-symbol-in-address sap) +(defun foreign-function-backtrace-name (sap) + (let ((name (foreign-symbol-in-address sap))) (if name - (format nil "foreign function: ~A [~A: #x~X + #x~X]" name file base offset) + (format nil "foreign function: ~A" name) (format nil "foreign function: #x~X" (sap-int sap))))) ;;; This returns a frame for the one existing in time immediately @@ -832,7 +821,8 @@ "undefined function")) (:foreign-function (make-bogus-debug-fun - (foreign-function-debug-name (int-sap (get-lisp-obj-address lra))))) + (foreign-function-backtrace-name + (int-sap (get-lisp-obj-address lra))))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -853,7 +843,6 @@ (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) (/noshow0 "at COND") (cond (code - (/noshow0 "in CODE clause") ;; If it's escaped it may be a function end breakpoint trap. (when (and (code-component-p code) (eq (%code-debug-info code) :bogus-lra)) @@ -862,22 +851,19 @@ code (1+ real-lra-slot))) (setq code (code-header-ref code real-lra-slot)) (aver code))) - (t - (/noshow0 "in T clause") - ;; not escaped + ((not escaped) (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra)) (unless code (setf code :foreign-function - pc-offset 0 - escaped nil)))) - + pc-offset 0)))) (let ((d-fun (case code (:undefined-function (make-bogus-debug-fun "undefined function")) (:foreign-function - (make-bogus-debug-fun (foreign-function-debug-name ra))) + (make-bogus-debug-fun + (foreign-function-backtrace-name ra))) ((nil) (make-bogus-debug-fun "bogus stack frame")) @@ -1039,8 +1025,11 @@ register." (defun debug-fun-from-pc (component pc) (let ((info (%code-debug-info component))) (cond - ((not info) - (debug-signal 'no-debug-info :code-component component)) + ((not info) + ;; FIXME: It seems that most of these (at least on x86) are + ;; actually assembler routines, and could be named by looking + ;; at the sb-fasl:*assembler-routines*. + (make-bogus-debug-fun "no debug information for frame")) ((eq info :bogus-lra) (make-bogus-debug-fun "function end breakpoint")) (t @@ -1998,7 +1987,7 @@ register." (zerop (logand val 3)) ;; character (and (zerop (logand val #xffff0000)) ; Top bits zero - (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag + (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer @@ -2053,7 +2042,7 @@ register." (sb!sys:without-gcing (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number @@ -2143,7 +2132,7 @@ register." sb!vm:n-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 + (#.sb!vm:character-stack-sc-number (with-nfp (nfp) (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))))) @@ -2188,7 +2177,7 @@ register." (without-gcing (with-escaped-value (val) (make-valid-lisp-obj val)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) (#.sb!vm:sap-reg-sc-number @@ -2247,7 +2236,7 @@ register." sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number (stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (code-char (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))))) @@ -2328,7 +2317,7 @@ register." (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2427,7 +2416,7 @@ register." (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (with-nfp (nfp) (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) @@ -2462,7 +2451,7 @@ register." (without-gcing (set-escaped-value (get-lisp-obj-address value)))) - (#.sb!vm:base-char-reg-sc-number + (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number (set-escaped-value (sap-int value))) @@ -2526,7 +2515,7 @@ register." (imagpart (the (complex long-float) value)))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) - (#.sb!vm:base-char-stack-sc-number + (#.sb!vm:character-stack-sc-number (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))) (char-code (the character value)))) @@ -2814,7 +2803,7 @@ register." (compiled-debug-fun-compiler-debug-fun what)) :standard) (error ":FUN-END breakpoints are currently unsupported ~ - for the known return convention.")) + for the known return convention.")) (let* ((bpt (%make-breakpoint hook-fun what kind info)) (starter (compiled-debug-fun-end-starter what))) @@ -3265,6 +3254,8 @@ register." ;;; instruction. (defun make-bogus-lra (real-lra &optional known-return-p) (without-gcing + ;; These are really code labels, not variables: but this way we get + ;; their addresses. (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts")) (src-end (foreign-symbol-address "fun_end_breakpoint_end")) (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))