Micro-optimize calling assembly routines on x86oids.
[sbcl.git] / src / code / debug.lisp
index 76a87d8..1f63348 100644 (file)
@@ -152,6 +152,11 @@ Other commands:
     useful when the debugger was invoked to handle an error in
     deeply nested input syntax, and now the reader is confused.)")
 \f
     useful when the debugger was invoked to handle an error in
     deeply nested input syntax, and now the reader is confused.)")
 \f
+(defmacro with-debug-io-syntax (() &body body)
+  (let ((thunk (gensym "THUNK")))
+    `(dx-flet ((,thunk ()
+                       ,@body))
+       (funcall-with-debug-io-syntax #',thunk))))
 
 ;;; If LOC is an unknown location, then try to find the block start
 ;;; location. Used by source printing to some information instead of
 
 ;;; If LOC is an unknown location, then try to find the block start
 ;;; location. Used by source printing to some information instead of
@@ -328,15 +333,16 @@ METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
 corresponding to method functions are printed. Possible values
 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
 information."
 corresponding to method functions are printed. Possible values
 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
 information."
-  (fresh-line stream)
-  (when print-thread
-    (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
-  (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
-                                     *suppress-print-errors*
-                                     'serious-condition))
-        (*print-circle* t)
-        (n start))
-    (handler-bind ((print-not-readable #'print-unreadably))
+  (with-debug-io-syntax ()
+    (fresh-line stream)
+    (when print-thread
+      (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*))
+    (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
+                                       *suppress-print-errors*
+                                       'serious-condition))
+          (*print-circle* t)
+          (n start))
+      (handler-bind ((print-not-readable #'print-unreadably))
         (map-backtrace (lambda (frame)
                          (print-frame-call frame stream
                                            :number n
         (map-backtrace (lambda (frame)
                          (print-frame-call frame stream
                                            :number n
@@ -346,8 +352,8 @@ information."
                        :from (backtrace-start-frame from)
                        :start start
                        :count count)))
                        :from (backtrace-start-frame from)
                        :start start
                        :count count)))
-  (fresh-line stream)
-  (values))
+    (fresh-line stream)
+    (values)))
 
 (defun list-backtrace (&key
                        (count *backtrace-frame-count*)
 
 (defun list-backtrace (&key
                        (count *backtrace-frame-count*)
@@ -512,12 +518,22 @@ thread, NIL otherwise."
     (sb!di:lambda-list-unavailable ()
       (make-unprintable-object "unavailable lambda list"))))
 
     (sb!di:lambda-list-unavailable ()
       (make-unprintable-object "unavailable lambda list"))))
 
-(defun clean-xep (name args info)
+(defun interrupted-frame-error (frame)
+  (when (and (sb!di::compiled-frame-p frame)
+             (sb!di::compiled-frame-escaped frame))
+    (let ((error-number (sb!vm:internal-error-args
+                         (sb!di::compiled-frame-escaped frame))))
+      (when (array-in-bounds-p sb!c:*backend-internal-errors* error-number)
+        (car (svref sb!c:*backend-internal-errors* error-number))))))
+
+(defun clean-xep (frame name args info)
   (values (second name)
           (if (consp args)
               (let* ((count (first args))
                      (real-args (rest args)))
   (values (second name)
           (if (consp args)
               (let* ((count (first args))
                      (real-args (rest args)))
-                (if (fixnump count)
+                (if (and (integerp count)
+                         (eq (interrupted-frame-error frame)
+                             'invalid-arg-count-error))
                     ;; So, this is a cheap trick -- but makes backtraces for
                     ;; too-many-arguments-errors much, much easier to to
                     ;; understand. FIXME: For :EXTERNAL frames at least we
                     ;; So, this is a cheap trick -- but makes backtraces for
                     ;; too-many-arguments-errors much, much easier to to
                     ;; understand. FIXME: For :EXTERNAL frames at least we
@@ -568,21 +584,22 @@ thread, NIL otherwise."
          (values name args)))
     (values cname cargs (cons :fast-method info))))
 
          (values name args)))
     (values cname cargs (cons :fast-method info))))
 
-(defun clean-frame-call (name args method-frame-style info)
-  (if (consp name)
-      (case (first name)
-        ((sb!c::xep sb!c::tl-xep)
-         (clean-xep name args info))
-        ((sb!c::&more-processor)
-         (clean-&more-processor name args info))
-        ((sb!c::&optional-processor)
-         (clean-frame-call (second name) args method-frame-style
-                           info))
-        ((sb!pcl::fast-method)
-         (clean-fast-method name args method-frame-style info))
-        (t
-         (values name args info)))
-      (values name args info)))
+(defun clean-frame-call (frame name method-frame-style info)
+  (let ((args (frame-args-as-list frame)))
+    (if (consp name)
+        (case (first name)
+          ((sb!c::xep sb!c::tl-xep)
+           (clean-xep frame name args info))
+          ((sb!c::&more-processor)
+           (clean-&more-processor name args info))
+          ((sb!c::&optional-processor)
+           (clean-frame-call frame (second name) method-frame-style
+                             info))
+          ((sb!pcl::fast-method)
+           (clean-fast-method name args method-frame-style info))
+          (t
+           (values name args info)))
+        (values name args info))))
 
 (defun frame-call (frame &key (method-frame-style *method-frame-style*)
                               replace-dynamic-extent-objects)
 
 (defun frame-call (frame &key (method-frame-style *method-frame-style*)
                               replace-dynamic-extent-objects)
@@ -603,8 +620,8 @@ the current thread are replaced with dummy objects which can safely escape."
   (let* ((debug-fun (sb!di:frame-debug-fun frame))
          (kind (sb!di:debug-fun-kind debug-fun)))
     (multiple-value-bind (name args info)
   (let* ((debug-fun (sb!di:frame-debug-fun frame))
          (kind (sb!di:debug-fun-kind debug-fun)))
     (multiple-value-bind (name args info)
-        (clean-frame-call (sb!di:debug-fun-name debug-fun)
-                          (frame-args-as-list frame)
+        (clean-frame-call frame
+                          (sb!di:debug-fun-name debug-fun)
                           method-frame-style
                           (when kind (list kind)))
       (let ((args (if (and (consp args) replace-dynamic-extent-objects)
                           method-frame-style
                           (when kind (list kind)))
       (let ((args (if (and (consp args) replace-dynamic-extent-objects)
@@ -818,8 +835,8 @@ the current thread are replaced with dummy objects which can safely escape."
                  (package-name *package*))
       (setf *package* (find-package :cl-user))
       (format *error-output*
                  (package-name *package*))
       (setf *package* (find-package :cl-user))
       (format *error-output*
-              "The value of ~S was not an undeleted PACKAGE. It has been
-reset to ~S."
+              "The value of ~S was not an undeleted PACKAGE. It has been ~
+               reset to ~S."
               '*package* *package*))
 
     ;; Before we start our own output, finish any pending output.
               '*package* *package*))
 
     ;; Before we start our own output, finish any pending output.
@@ -912,64 +929,94 @@ reset to ~S."
 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
 ;;; command-line option
 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
 ;;; command-line option
-(defun debugger-disabled-hook (condition me)
-  (declare (ignore me))
+(defun debugger-disabled-hook (condition previous-hook)
+  (declare (ignore previous-hook))
   ;; There is no one there to interact with, so report the
   ;; condition and terminate the program.
   ;; There is no one there to interact with, so report the
   ;; condition and terminate the program.
-  (flet ((failure-quit (&key abort)
+  (let ((*suppress-print-errors* t)
+        (condition-error-message
+         #.(format nil "A nested error within --disable-debugger error ~
+            handling prevents displaying the original error. Attempting ~
+            to print a backtrace."))
+        (backtrace-error-message
+         #.(format nil "A nested error within --disable-debugger error ~
+            handling prevents printing the backtrace. Sorry, exiting.")))
+    (labels
+        ((failure-quit (&key abort)
            (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
            (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
-           (exit :code 1 :abort abort)))
-    ;; This HANDLER-CASE is here mostly to stop output immediately
-    ;; (and fall through to QUIT) when there's an I/O error. Thus,
-    ;; when we're run under a shell script or something, we can die
-    ;; cleanly when the script dies (and our pipes are cut), instead
-    ;; of falling into ldb or something messy like that. Similarly, we
-    ;; can terminate cleanly even if BACKTRACE dies because of bugs in
-    ;; user PRINT-OBJECT methods.
-    (handler-case
-        (progn
-          (format *error-output*
-                  "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
-                  (type-of condition)
-                  #!+sb-thread sb!thread:*current-thread*
-                  #!-sb-thread nil
-                  condition)
-          ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
-          ;; even if we hit an error within BACKTRACE (e.g. a bug in
-          ;; the debugger's own frame-walking code, or a bug in a user
-          ;; PRINT-OBJECT method) we'll at least have the CONDITION
-          ;; printed out before we die.
-          (finish-output *error-output*)
-          ;; (Where to truncate the BACKTRACE is of course arbitrary, but
-          ;; it seems as though we should at least truncate it somewhere.)
-          (print-backtrace :count 128 :stream *error-output*
-                           :from :interrupted-frame)
-          (format
-           *error-output*
-           "~%unhandled condition in --disable-debugger mode, quitting~%")
-          (finish-output *error-output*)
-          (failure-quit))
-      (condition ()
-        ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
-        ;; fail when our output streams are blown away, as e.g. when
-        ;; we're running under a Unix shell script and it dies somehow
-        ;; (e.g. because of a SIGINT). In that case, we might as well
-        ;; just give it up for a bad job, and stop trying to notify
-        ;; the user of anything.
-        ;;
-        ;; Actually, the only way I've run across to exercise the
-        ;; problem is to have more than one layer of shell script.
-        ;; I have a shell script which does
-        ;;   time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
-        ;; and the problem occurs when I interrupt this with Ctrl-C
-        ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
-        ;; I haven't figured out whether it's bash, time, tee, Linux, or
-        ;; what that is responsible, but that it's possible at all
-        ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
-        (ignore-errors
-         (%primitive print
-                     "Argh! error within --disable-debugger error handling"))
-        (failure-quit :abort t)))))
+           (exit :code 1 :abort abort))
+         (display-condition ()
+           (handler-case
+               (handler-case
+                   (print-condition)
+                 (condition ()
+                   ;; printing failed, try to describe it
+                   (describe-condition)))
+             (condition ()
+               ;; ok, give up trying to display the error and inform the user about it
+               (finish-output *error-output*)
+               (%primitive print condition-error-message))))
+         (print-condition ()
+           (format *error-output*
+                   "~&~@<Unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
+                   (type-of condition)
+                   #!+sb-thread sb!thread:*current-thread*
+                   #!-sb-thread nil
+                   condition)
+           (finish-output *error-output*))
+         (describe-condition ()
+           (format *error-output*
+                   "~&Unhandled ~S~@[ in thread ~S~]:~%"
+                   (type-of condition)
+                   #!+sb-thread sb!thread:*current-thread*
+                   #!-sb-thread nil)
+           (describe condition *error-output*)
+           (finish-output *error-output*))
+         (display-backtrace ()
+           (handler-case
+               (print-backtrace :stream *error-output*
+                                :from :interrupted-frame
+                                :print-thread t)
+             (condition ()
+               (values)))
+           (finish-output *error-output*)))
+      ;; This HANDLER-CASE is here mostly to stop output immediately
+      ;; (and fall through to QUIT) when there's an I/O error. Thus,
+      ;; when we're run under a shell script or something, we can die
+      ;; cleanly when the script dies (and our pipes are cut), instead
+      ;; of falling into ldb or something messy like that. Similarly, we
+      ;; can terminate cleanly even if BACKTRACE dies because of bugs in
+      ;; user PRINT-OBJECT methods. Separate the error handling of the
+      ;; two phases to maximize the chance of emitting some useful
+      ;; information.
+      (handler-case
+          (progn
+            (display-condition)
+            (display-backtrace)
+            (format *error-output*
+                    "~%unhandled condition in --disable-debugger mode, quitting~%")
+            (finish-output *error-output*)
+            (failure-quit))
+        (condition ()
+          ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
+          ;; fail when our output streams are blown away, as e.g. when
+          ;; we're running under a Unix shell script and it dies somehow
+          ;; (e.g. because of a SIGINT). In that case, we might as well
+          ;; just give it up for a bad job, and stop trying to notify
+          ;; the user of anything.
+          ;;
+          ;; Actually, the only way I've run across to exercise the
+          ;; problem is to have more than one layer of shell script.
+          ;; I have a shell script which does
+          ;;   time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
+          ;; and the problem occurs when I interrupt this with Ctrl-C
+          ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
+          ;; I haven't figured out whether it's bash, time, tee, Linux, or
+          ;; what that is responsible, but that it's possible at all
+          ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
+          (ignore-errors
+            (%primitive print backtrace-error-message))
+          (failure-quit :abort t))))))
 
 (defvar *old-debugger-hook* nil)
 
 
 (defvar *old-debugger-hook* nil)
 
@@ -1572,12 +1619,6 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
 \f
 ;;;; source location printing
 
 \f
 ;;;; source location printing
 
-;;; Stuff to clean up before saving a core
-(defun debug-deinit ()
-  ;; Nothing to do right now. Once there was, maybe once there
-  ;; will be again.
-  )
-
 (defun code-location-source-form (location context &optional (errorp t))
   (let* ((start-location (maybe-block-start-location location))
          (form-num (sb!di:code-location-form-number start-location)))
 (defun code-location-source-form (location context &optional (errorp t))
   (let* ((start-location (maybe-block-start-location location))
          (form-num (sb!di:code-location-form-number start-location)))
@@ -1799,11 +1840,6 @@ and LDB (the low-level debugger).  See also ENABLE-DEBUGGER."
   (sb!di:debug-var-info-available
    (sb!di:code-location-debug-fun
     (sb!di:frame-code-location frame))))
   (sb!di:debug-var-info-available
    (sb!di:code-location-debug-fun
     (sb!di:frame-code-location frame))))
-
-;; Hack: ensure that *U-T-F-F* has a tls index.
-#!+unwind-to-frame-and-call-vop
-(let ((sb!vm::*unwind-to-frame-function* (lambda ()))))
-
 \f
 ;;;; debug loop command utilities
 
 \f
 ;;;; debug loop command utilities