* fix bug 32: print closures as #<CLOSURE name-goes-here>.
* fix bug 33: better inspection of closures
* remove bug 60: LIST-LOCATIONS has been deleted at some
point in history, no point in keeping a bug about it.
* move to using structured function names: (XEP FOO), etc
instead of "XEP for FOO". Ditto for component names.
* unless SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS* is true
display various entry points in backtraces as if they were
"normal functions", and adjust the argument list accordingly.
* fix for debugger I/O style issues: use *DEBUG-IO*, not
*STANDARD-OUTPUT*.
* use INTERACTIVE-EVAL in the debugger instead of reimplementing
it.
* update debugger documentation.
Process inferior-lisp exited abnormally with code 1
I haven't noticed a repeatable case of this yet.
-32:
- The printer doesn't report closures very well. This is true in
- CMU CL 18b as well:
- (defstruct foo bar)
- (print #'foo-bar)
- gives
- #<FUNCTION "CLOSURE" {406974D5}>
- It would be nice to make closures have a settable name slot,
- and make things like DEFSTRUCT and FLET, which create closures,
- set helpful values into this slot.
-
33:
And as long as we're wishing, it would be awfully nice if INSPECT could
also report on closures, telling about the values of the bound variables.
so they could be supported after all. Very likely
SIGCONTEXT-FLOATING-POINT-MODES could now be supported, too.
-60:
- The debugger LIST-LOCATIONS command doesn't work properly.
- (How should it work properly?)
-
61:
Compiling and loading
(DEFUN FAIL (X) (THROW 'FAIL-TAG X))
Has the XEP for TEST in the backtrace, not the TEST frame itself.
(sparc and x86 at least)
+ Since SBCL 0.8.20.1 this is hidden unless *SHOW-ENTRY-POINT-DETAILS*
+ is true.
+
355: change-class of generic-function
(reported by Bruno Haible)
The MOP doesn't support change-class on a generic-function. However, SBCL
+changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20:
+ * internal entry point details and argument counts no longer appear
+ in backtraces unless explicitly requested by setting
+ SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS*.
+ * built-in and standard functions no longer have names like "top
+ level local call to FOO".
+ * fixed bug 32: functions defined in non-null lexical environments
+ now have more legible printed representation
+ * fixed bug 33: functions defined in non-null lexical environemnts
+ are now more amenable to inspection by INSPECT.
+ * workaround for bug 354: XEPs no longer appear in backtraces unless
+ explicitly requested.
+
changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19:
* fixed inspection of specialized arrays. (thanks to Simon Alexander)
* fixed disassembly of SHLD and SHRD on x86. (thanks to David
"True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
(and (sb-int:valid-function-name-p name) t))
+;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST?
(defun function-arglist (function)
"Describe the lambda list for the function designator FUNCTION.
Works for special-operators, macros, simple functions and generic
@chapter Debugger
@cindex Debugger
-The SBCL debugger (as the CMUCL debugger it was derived from) has very
-good support for source-level debugging of compiled code. Although
-some other debuggers allow access of variables by name, this seems to
-be the first Lisp debugger that:
-
-@itemize
-
-@item
-Tells you when a variable doesn't have a value because it hasn't been
-initialized yet or has already been deallocated, or
-
-@item
-Can display the precise source location corresponding to a code
-location in the debugged program.
-
-@end itemize
-
-These features allow the debugging of compiled code to be made almost
-indistinguishable from interpreted code debugging.
-
+This chapter documents the debugging facilities of SBCL, including
+the debugger, single-stepper and @code{trace}, and the effect of
+@code{(optimize debug)} declarations.
@menu
-* Starting the Debugger::
-* The Debugger Command Loop::
-* Controlling Printing in the Debugger::
+* Debugger Entry::
+* Debugger Command Loop::
* Stack Frames::
* Variable Access::
* Source Location Printing::
* Single Stepping::
@end menu
-@node Starting the Debugger
+@node Debugger Entry
@comment node-name, next, previous, up
-@section Starting the Debugger
-
-The debugger is an interactive command loop that allows a user to examine
-the function call stack. The debugger is invoked when:
+@section Debugger Entry
-@itemize
-
-@item
-A @code{serious-condition} is signaled, and it is not handled, or
-
-@item
-@code{error} is called, and the condition it signals is not handled,
-or
-
-@item
-the debugger is explicitly entered with the Lisp @code{break} or
-@code{invoke-debugger} functions.
+@menu
+* Debugger Banner::
+* Debugger Invokation::
+@end menu
-@end itemize
+@node Debugger Banner
+@comment node-name, next, previous, up
+@subsection Debugger Banner
-When you enter the TTY debugger, it looks something like this:
+When you enter the debugger, it looks something like this:
@example
debugger invoked on a TYPE-ERROR in thread 11184:
The value 3 is not of type LIST.
+
+You can type HELP for debugger help, or (SB-EXT:QUIT) to exit from SBCL.
+
restarts (invokable by number or by possibly-abbreviated name):
0: [ABORT ] Reduce debugger level (leaving debugger, returning to toplevel).
1: [TOPLEVEL] Restart at toplevel READ/EVAL/PRINT loop.
-(CAR 1 3)[:EXTERNAL]
+(CAR 1 3)
0]
@end example
The first group of lines describe what the error was that put us in
-the debugger. In this case @code{car} was called on @code{3}. After
-@samp{restarts} is a list of all the ways that we can restart
-execution after this error. In this case, both options return to
-top-level. After printing its banner, the debugger prints the current
-frame and the debugger prompt.
+the debugger. In this case @code{car} was called on @code{3}, causing
+a @code{type-error}.
+
+This is followed by the ``beginner help line'', which appears only if
+@code{sb-ext:*debugger-beginner-help*} is true (default).
+
+Next comes a listing of the active restart names, along with their
+descriptions -- the ways we can restart execution after this error. In
+this case, both options return to top-level. Restarts can be selected
+by entering the corresponding number or name.
+
+The current frame appears right underneath the restarts, immediately
+followed by the debugger prompt.
+
+@node Debugger Invokation
+@comment node-name, next, previous, up
+@subsection Debugger Invokation
+
+The debugger is invoked when:
+
+@itemize
+
+@item
+@code{error} is called, and the condition it signals is not handled.
+
+@item
+@code{break} is called, or @code{signal} is called with a condition
+that matches the current @code{*break-on-signals*}.
+
+@item
+the debugger is explicitly entered with the @code{invoke-debugger}
+function.
+
+@end itemize
When the debugger is invoked by a condition, ANSI mandates that the
value of @code{*debugger-hook*}, if any, be called with two arguments:
the condition that caused the debugger to be invoked and the previous
value of @code{*debugger-hook*}. When this happens,
-@code{*debugger-hook*} is bound to NIL to prevent recursive
-errors. However, ANSI also mandates that @code{*debugger-hook*} not be
-invoked when the debugger is to be entered by the @code{break}
-function. For users who wish to provide an alternate debugger
-interface (and thus catch @code{break} entries into the debugger),
-SBCL provides @code{sb-ext:*invoke-debugger-hook*}, which is invoked
-during any entry into the debugger.
+@code{*debugger-hook*} is bound to NIL to prevent recursive errors.
+However, ANSI also mandates that @code{*debugger-hook*} not be invoked
+when the debugger is to be entered by the @code{break} function. For
+users who wish to provide an alternate debugger interface (and thus
+catch @code{break} entries into the debugger), SBCL provides
+@code{sb-ext:*invoke-debugger-hook*}, which is invoked during any
+entry into the debugger.
@include var-sb-ext-star-invoke-debugger-hook-star.texinfo
-
-@node The Debugger Command Loop
+@node Debugger Command Loop
@comment node-name, next, previous, up
-@section The Debugger Command Loop
-@cindex Evaluation, in the debugger
-
-The debugger is an interactive read-eval-print loop much like the normal
-top-level, but some symbols are interpreted as debugger commands instead
-of being evaluated. A debugger command starts with the symbol name of
-the command, possibly followed by some arguments on the same line. Some
-commands prompt for additional input. Debugger commands can be
-abbreviated by any unambiguous prefix: @command{help} can be typed as
-@samp{h}, @samp{he}, etc. For convenience, some commands have
-ambiguous one-letter abbreviations: @samp{f} for @command{frame}.
-@comment FIXME: what does that last bit mean?
-
-The package is not significant in debugger commands; any symbol with the
-name of a debugger command will work. If you want to show the value of
-a variable that happens also to be the name of a debugger command, you
-can use the @command{list-locals} command or the @code{sb-debug:var}
-function, or you can wrap the variable in a @code{progn} to hide it from
+@section Debugger Command Loop
+
+The debugger is an interactive read-eval-print loop much like the
+normal top level, but some symbols are interpreted as debugger
+commands instead of being evaluated. A debugger command starts with
+the symbol name of the command, possibly followed by some arguments on
+the same line. Some commands prompt for additional input. Debugger
+commands can be abbreviated by any unambiguous prefix: @command{help}
+can be typed as @samp{h}, @samp{he}, etc.
+
+The package is not significant in debugger commands; any symbol with
+the name of a debugger command will work. If you want to show the
+value of a variable that happens also to be the name of a debugger
+command you can wrap the variable in a @code{progn} to hide it from
the command loop.
The debugger prompt is ``@code{@var{frame}]}'', where @var{frame} is
the number of the current frame. Frames are numbered starting from
zero at the top (most recent call), increasing down to the bottom.
-The current frame is the frame that commands refer to. The current
-frame also provides the lexical environment for evaluation of
-non-command forms.
-
- The debugger evaluates forms in the lexical environment of the
-functions being debugged. The debugger can only access variables.
-You can't @code{go} or @code{return-from} into a function, and you
-can't call local functions. Special variable references are evaluated
-with their current value (the innermost binding around the debugger
-invocation) -- you don't get the value that the special had in the
-current frame. For more information on debugger variable access, see
-@ref{Variable Access}.
+The current frame is the frame that commands refer to.
-
-@node Controlling Printing in the Debugger
-@comment node-name, next, previous, up
-@section Controlling Printing in the Debugger
-
-In the debugger, it is possible to override the printing behaviour of
-the REPL.
+It is possible to override the normal printing behaviour in the
+debugger by using the @code{sb-ext:*debug-print-variable-alist*}.
@include var-sb-ext-star-debug-print-variable-alist-star.texinfo
@item
@dfn{variables} (@pxref{Variable Access}), which are the values being operated
-on;
+on.
@item
@dfn{arguments} to the call (which are really just particularly
-interesting variables), and
+interesting variables).
@item
-a current location (@pxref{Source Location Printing}), which is the place in
-the program where the function was running when it stopped to call
-another function, or because of an interrupt or error.
+a current source location (@pxref{Source Location Printing}), which is
+the place in the program where the function was running when it
+stopped to call another function, or because of an interrupt or error.
@end itemize
-
@menu
* Stack Motion::
* How Arguments are Printed::
* Function Names::
-* Funny Frames::
* Debug Tail Recursion::
* Unknown Locations and Interrupts::
@end menu
then @samp{#<unavailable-arg>} will be printed instead of the argument
value.
-@vindex *debug-print-variable-alist*
-Printing of argument values is controlled by
-@code{*debug-print-variable-alist*}. @xref{Controlling Printing in
-the Debugger}.
+ Note that inline expansion and open-coding affect what frames
+are present in the debugger, see @ref{Debugger Policy Control}.
+@comment FIXME: link here to section about open coding once it exists.
+@c @ref{open-coding}
@node Function Names
@comment node-name, next, previous, up
@subsection Function Names
-If a function is defined by @code{defun}, @code{labels}, or
-@code{flet}, then the debugger will print the actual function name
-after the open parenthesis, like:
-
-@example
-(STRING-UPCASE "test case" :START 0 :END NIL)
-((SETF AREF) #\a "for" 1)
-@end example
-
-Otherwise, the function name is a string, and will be printed in
-quotes:
-
-@example
-("DEFUN MYFUN" BAR)
-("DEFMACRO DO" (DO ((I 0 (1+ I))) ((= I 13))) NIL)
-("SETQ *GC-NOTIFY-BEFORE*")
-@end example
-
-This string name is derived from the @code{def@var{mumble}} form
-that encloses or expanded into the lambda, or the outermost enclosing
-form if there is no @code{def@var{mumble}}.
+If a function is defined by @code{defun} it will appear in backtrace
+by that name. Functions defined by @code{labels} and @code{flet} will
+appear as @code{(FLET <name>)} and @code{(LABELS <name>)} respectively.
+Anonymous lambdas will appear as @code{(LAMDBA <lambda-list>)}.
+@menu
+* Entry Point Details::
+@end menu
-@node Funny Frames
+@node Entry Point Details
@comment node-name, next, previous, up
-@subsection Funny Frames
+@subsubsection Entry Point Details
@cindex External entry points
@cindex Entry points, external
@cindex Block compilation, debugger implications
@cindex Optional, stack frame kind
@cindex Cleanup, stack frame kind
-Sometimes the evaluator introduces new functions that are used to
+Sometimes the compiler introduces new functions that are used to
implement a user function, but are not directly specified in the
-source. The main place this is done is for checking argument type and
-syntax. Usually these functions do their thing and then go away, and
-thus are not seen on the stack in the debugger. But when you get some
-sort of error during lambda-list processing, you end up in the
-debugger on one of these funny frames.
-
-These funny frames are flagged by printing
-``@code{[@var{keyword}]}'' after the parentheses. For example,
-this call:
-
-@lisp
-(car 'a 'b)
-@end lisp
-
-will look like this:
-
-@example
-(CAR 2 A)[:EXTERNAL]
-@end example
-
-And this call:
-
-@lisp
-(string-upcase "test case" :end)
-@end lisp
-
-would look like this:
-
-@example
-("SB!INT:&MORE processing" "test case" 1053984 1)[:OPTIONAL]
-@end example
-
-As you can see, these frames have only a vague resemblance to the
-original call. Fortunately, the error message displayed when you
-enter the debugger will usually tell you what problem is (in these
-cases, too many arguments and odd keyword arguments.) Also, if you go
-down the stack to the frame for the calling function, you can display
-the original source. @xref{Source Location Printing}.
-
-@c FIXME: is the block-compilation part correct for SBCL?
-
-With recursive or block compiled functions, an @code{:EXTERNAL} frame
-may appear before the frame representing the first call to the
-recursive function or entry to the compiled block. This is a
-consequence of the way the compiler does block compilation: there is
-nothing odd with your program. You will also see @code{:CLEANUP}
-frames during the execution of @code{unwind-protect} cleanup
-code. Note that inline expansion and open-coding affect what frames
-are present in the debugger, see @ref{Debugger Policy Control}.
-@comment FIXME: link here to section about open coding once it exists.
-@c @ref{open-coding}
-
+source. This is mostly done for argument type and count checking.
+
+The debugger will normally show these entry point functions as if
+they were the normal main entry point, but more detail can be obtained
+by setting @code{sb-debug:*show-entry-point-details*} to true; this is
+primarily useful for debugging SBCL itself, but may help pinpoint
+problems that occur during lambda-list processing.
+
+@c FIXME: the following bits talked about block-compilation, but
+@c we don't currently support it...
+
+@c With recursive
+@c or block compiled
+@c functions, an additional @code{:EXTERNAL} frame
+@c may appear before the frame representing the first call to the
+@c recursive function
+@c or entry to the compiled block.
+@c This is a
+@c consequence of the way the compiler works: there is
+@c nothing odd with your program. You will also see @code{:CLEANUP}
+@c frames during the execution of @code{unwind-protect} cleanup
+@c code.
+
+With recursive functions, an additional @code{:EXTERNAL} frame may
+appear before the frame representing the first call to the recursive
+function. This is a consequence of the way the compiler works: there
+is nothing odd with your program. You will also see @code{:CLEANUP}
+frames during the execution of @code{unwind-protect} cleanup code.
+The @code{:EXTERNAL} and @code{:CLEANUP} above are entry-point types,
+visible only if @code{sb-debug:*show-entry-point-details*} os true.
@node Debug Tail Recursion
@comment node-name, next, previous, up
@cindex Tail recursion
@cindex Recursion, tail
-Both the compiler and the interpreter are ``properly tail recursive.''
-If a function call is in a tail-recursive position, the stack frame
-will be deallocated @emph{at the time of the call}, rather than after
-the call returns. Consider this backtrace:
+The compiler is ``properly tail recursive.'' If a function call is in
+a tail-recursive position, the stack frame will be deallocated
+@emph{at the time of the call}, rather than after the call returns.
+Consider this backtrace:
@example
(BAR ...)
@comment FIXME: reinstate this link once the chapter is in the manual.
@c For a more thorough discussion of tail recursion, @ref{tail-recursion}.
-
@node Unknown Locations and Interrupts
@comment node-name, next, previous, up
@subsection Unknown Locations and Interrupts
SBCL can also be configured to exit if an unhandled error occurs,
which is mainly useful for acting as part of a shell pipeline; doing
so under most other circumstances would mean giving up large parts of
-the flexibility and robustness of Common Lisp. See @ref{Starting the
-Debugger}.
-
+the flexibility and robustness of Common Lisp. See @ref{Debugger Entry}.
@node Command Line Options
@comment node-name, next, previous, up
@item --disable-debugger
This is equivalent to @code{--eval '(sb-ext:disable-debugger)'}.
-@xref{Starting the Debugger}.
+@xref{Debugger Entry}.
@end table
"*DEBUG-CONDITION*"
"*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
"*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
+ "*SHOW-ENTRY-POINT-DETAILS*"
"*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
"*TRACE-FRAME*" "*TRACED-FUN-LIST*"
"ARG" "BACKTRACE" "BACKTRACE-AS-LIST" "INTERNAL-DEBUG" "VAR"
(def!struct debug-info
;; Some string describing something about the code in this component.
- (name (missing-arg) :type simple-string)
+ (name (missing-arg) :type t)
;; A list of DEBUG-SOURCE structures describing where the code for this
;; component came from, in the order that they were read.
;;
;; optional. Stick the extra var in the result
;; element representing the keyword or optional,
;; which is the previous one.
+ ;;
+ ;; FIXME: NCONC used for side-effect: the effect is defined,
+ ;; but this is bad style no matter what.
(nconc (car res)
(list (compiled-debug-fun-lambda-list-var
args (incf i) vars))))
Any command -- including the name of a restart -- may be uniquely abbreviated.
The debugger rebinds various special variables for controlling i/o, sometimes
to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
- its own special values, based on SB-EXT:*DEBUG-PRINT-VARIBALE-ALIST*.
+ its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
Debug commands do not affect *, //, and similar variables, but evaluation in
the debug loop does affect these variables.
SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
- drop you deeper into the debugger.
+ drop you deeper into the debugger. The default NIL allows recursive entry
+ to debugger.
Getting in and out of the debugger:
RESTART invokes restart numbered as shown (prompt if not given).
that restart.
Changing frames:
- U up frame D down frame
- B bottom frame F n frame n (n=0 for top frame)
+ UP up frame DOWN down frame
+ BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
Inspecting frames:
BACKTRACE [n] shows n frames going down the stack.
- LIST-LOCALS, L lists locals in current function.
- PRINT, P displays current function call.
+ LIST-LOCALS, L lists locals in current frame.
+ PRINT, P displays function call for current frame.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
Stepping:
- STEP
- [EXPERIMENTAL] Selects the CONTINUE restart if one exists and starts
- single-stepping. Single stepping affects only code compiled with
- under high DEBUG optimization quality. See User Manul for details.
+ STEP Selects the CONTINUE restart if one exists and starts
+ single-stepping. Single stepping affects only code compiled with
+ under high DEBUG optimization quality. See User Manual for details.
Function and macro commands:
(SB-DEBUG:ARG n)
Other commands:
RETURN expr
- [EXPERIMENTAL] Return the values resulting from evaluation of expr
- from the current frame, if this frame was compiled with a sufficiently
- high DEBUG optimization quality.
+ Return the values resulting from evaluation of expr from the
+ current frame, if this frame was compiled with a sufficiently high
+ DEBUG optimization quality.
+
SLURP
Discard all pending input on *STANDARD-INPUT*. (This can be
useful when the debugger was invoked to handle an error in
(return loc))))
(cond ((and (not (sb!di:debug-block-elsewhere-p block))
start)
- ;; FIXME: Why output on T instead of *DEBUG-FOO* or something?
- (format t "~%unknown location: using block start~%")
+ (format *debug-io* "~%unknown location: using block start~%")
start)
(t
loc)))
\f
;;;; BACKTRACE
-(defun backtrace (&optional (count most-positive-fixnum)
- (*standard-output* *debug-io*))
+(defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
#!+sb-doc
- "Show a listing of the call stack going down from the current frame. In the
- debugger, the current frame is indicated by the prompt. COUNT is how many
- frames to show."
- (fresh-line *standard-output*)
+ "Show a listing of the call stack going down from the current frame.
+In the debugger, the current frame is indicated by the prompt. COUNT
+is how many frames to show."
+ (fresh-line stream)
(do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
(sb!di:frame-down frame))
(count count (1- count)))
((or (null frame) (zerop count)))
- (print-frame-call frame :number t))
- (fresh-line *standard-output*)
+ (print-frame-call frame stream :number t))
+ (fresh-line stream)
(values))
(defun backtrace-as-list (&optional (count most-positive-fixnum))
(push (frame-call-as-list frame) reversed-result)))
(defun frame-call-as-list (frame)
- (cons (sb!di:debug-fun-name (sb!di:frame-debug-fun frame))
- (frame-args-as-list frame)))
+ (multiple-value-bind (name args) (frame-call frame)
+ (cons name args)))
\f
;;;; frame printing
(sb!di:lambda-list-unavailable
()
(make-unprintable-object "unavailable lambda list")))))
-
-;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
-;;; print as many of the values as possible, punting the loop over
-;;; lambda-list variables since any other arguments will be in the
-;;; &REST arg's list of values.
-(defun print-frame-call-1 (frame)
- (let ((debug-fun (sb!di:frame-debug-fun frame)))
-
- (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
- (let ((args (ensure-printable-object (frame-args-as-list frame))))
- ;; Since we go to some trouble to make nice informative function
- ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
- ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
- (let ((*print-length* nil)
- (*print-level* nil))
- (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
- ;; For the function arguments, we can just print normally.
- (if (listp args)
- (format t "~{ ~_~S~}" args)
- (format t " ~S" args))))
-
- (when (sb!di:debug-fun-kind debug-fun)
- (write-char #\[)
- (prin1 (sb!di:debug-fun-kind debug-fun))
- (write-char #\]))))
+(legal-fun-name-p '(lambda ()))
+(defvar *show-entry-point-details* nil)
+
+(defun frame-call (frame)
+ (labels ((clean-name-and-args (name args)
+ (if (and (consp name) (not *show-entry-point-details*))
+ (case (first name)
+ ((sb!c::xep sb!c::tl-xep)
+ (clean-name-and-args
+ (second name)
+ (let ((count (first args))
+ (real-args (rest args)))
+ (subseq real-args 0 (min count (length real-args))))))
+ ((sb!c::&more-processor)
+ (clean-name-and-args
+ (second name)
+ (let* ((more (last args 2))
+ (context (first more))
+ (count (second more)))
+ (append (butlast args 2)
+ (multiple-value-list
+ (sb!c:%more-arg-values context 0 count))))))
+ ;; FIXME: do we need to deal with
+ ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
+ ;; &AUX-BINDINGS appear in backtraces, so they are
+ ;; left alone for now. --NS 2005-02-28
+ ((sb!c::hairy-arg-processor
+ sb!c::varargs-entry sb!c::&optional-processor)
+ (clean-name-and-args (second name) args))
+ (t
+ (values name args)))
+ (values name args))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame)))
+ (multiple-value-bind (name args)
+ (clean-name-and-args (sb!di:debug-fun-name debug-fun)
+ (frame-args-as-list frame))
+ (values name args
+ (when *show-entry-point-details*
+ (sb!di:debug-fun-kind debug-fun)))))))
(defun ensure-printable-object (object)
(handler-case
;;; zero indicates just printing the DEBUG-FUN's name, and one
;;; indicates displaying call-like, one-liner format with argument
;;; values.
-(defun print-frame-call (frame &key (verbosity 1) (number nil))
- (cond
- ((zerop verbosity)
- (when number
- (format t "~&~S: " (sb!di:frame-number frame)))
- (format t "~S" frame))
- (t
- (when number
- (format t "~&~S: " (sb!di:frame-number frame)))
- (print-frame-call-1 frame)))
+(defun print-frame-call (frame stream &key (verbosity 1) (number nil))
+ (when number
+ (format stream "~&~S: " (sb!di:frame-number frame)))
+ (if (zerop verbosity)
+ (let ((*print-readably* nil))
+ (prin1 frame stream))
+ (multiple-value-bind (name args kind) (frame-call frame)
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ ;; Since we go to some trouble to make nice informative function
+ ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+ ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+ ;; For the function arguments, we can just print normally.
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (ensure-printable-object name) stream))
+ ;; If we hit a &REST arg, then print as many of the values as
+ ;; possible, punting the loop over lambda-list variables since any
+ ;; other arguments will be in the &REST arg's list of values.
+ (let ((args (ensure-printable-object args)))
+ (if (listp args)
+ (format stream "~{ ~_~S~}" args)
+ (format stream " ~S" args))))
+ (when kind
+ (format stream "[~S]" kind))))
(when (>= verbosity 2)
(let ((loc (sb!di:frame-code-location frame)))
(handler-case
(progn
+ ;; FIXME: Is this call really necessary here? If it is,
+ ;; then the reason for it should be unobscured.
(sb!di:code-location-debug-block loc)
- (format t "~%source: ")
- (print-code-location-source-form loc 0))
- (sb!di:debug-condition (ignore) ignore)
- (error (c) (format t "error finding source: ~A" c))))))
+ (format stream "~%source: ")
+ (prin1 (code-location-source-form loc 0) stream))
+ (sb!di:debug-condition (ignore)
+ ignore)
+ (error (c)
+ (format stream "error finding source: ~A" c))))))
\f
;;;; INVOKE-DEBUGGER
;; been converted to behave this way. -- WHN 2000-11-16)
(unwind-protect
- (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
- ;; used to rebind *STANDARD-INPUT* here too, but that's
- ;; been fixed already.)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
+ (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
+ ;; here as well, but that is probably bogus since it
+ ;; removes the users ability to do output to a redirected
+ ;; *S-O*. Now we just rebind it so that users can temporarily
+ ;; frob it. FIXME: This and other "what gets bound when"
+ ;; behaviour should be documented in the manual.
+ (*standard-output* *standard-output*)
+ ;; This seems reasonable: e.g. if the user has redirected
;; *ERROR-OUTPUT* to some log file, it's probably wrong
;; to send errors which occur in interactive debugging to
;; that file, and right to send them to *DEBUG-IO*.
(princ condition *debug-io*)
(/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil))))
- (fresh-line)
- (print-frame-call *current-frame* :verbosity 2)
+ (fresh-line *debug-io*)
+ (print-frame-call *current-frame* *debug-io* :verbosity 2)
(loop
(catch 'debug-loop-catcher
(handler-bind ((error (lambda (condition)
(when *flush-debug-errors*
(clear-input *debug-io*)
- (princ condition)
- ;; FIXME: Doing input on *DEBUG-IO*
- ;; and output on T seems broken.
- (format t
+ (princ condition *debug-io*)
+ (format *debug-io*
"~&error flushed (because ~
~S is set)"
'*flush-debug-errors*)
(cond ((not cmd-fun)
(debug-eval-print exp))
((consp cmd-fun)
- (format t "~&Your command, ~S, is ambiguous:~%"
+ (format *debug-io*
+ "~&Your command, ~S, is ambiguous:~%"
exp)
(dolist (ele cmd-fun)
- (format t " ~A~%" ele)))
+ (format *debug-io* " ~A~%" ele)))
(t
(funcall cmd-fun))))))))))))
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
(defun debug-eval-print (expr)
(/noshow "entering DEBUG-EVAL-PRINT" expr)
- (/noshow (fboundp 'compile))
- (setq +++ ++ ++ + + - - expr)
- (let* ((values (multiple-value-list (eval -)))
- (*standard-output* *debug-io*))
+ (let ((values (multiple-value-list
+ (interactive-eval (sb!di:preprocess-for-eval expr)))))
(/noshow "done with EVAL in DEBUG-EVAL-PRINT")
- (fresh-line)
- (if values (prin1 (car values)))
- (dolist (x (cdr values))
- (fresh-line)
- (prin1 x))
- (setq /// // // / / values)
- (setq *** ** ** * * (car values))
- ;; Make sure that nobody passes back an unbound marker.
- (unless (boundp '*)
- (setq * nil)
- (fresh-line)
- ;; FIXME: The way INTERACTIVE-EVAL does this seems better.
- (princ "Setting * to NIL (was unbound marker)."))))
+ (dolist (value values)
+ (fresh-line *debug-io*)
+ (prin1 value))))
\f
;;;; debug loop functions
(let ((next (sb!di:frame-up *current-frame*)))
(cond (next
(setf *current-frame* next)
- (print-frame-call next))
+ (print-frame-call next *debug-io*))
(t
- (format t "~&Top of stack.")))))
+ (format *debug-io* "~&Top of stack.")))))
(!def-debug-command "DOWN" ()
(let ((next (sb!di:frame-down *current-frame*)))
(cond (next
(setf *current-frame* next)
- (print-frame-call next))
+ (print-frame-call next *debug-io*))
(t
- (format t "~&Bottom of stack.")))))
+ (format *debug-io* "~&Bottom of stack.")))))
(!def-debug-command-alias "D" "DOWN")
;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
;;; ((null lead)
;;; (setf *current-frame* prev)
-;;; (print-frame-call prev))))
+;;; (print-frame-call prev *debug-io*))))
(!def-debug-command "BOTTOM" ()
(do ((prev *current-frame* lead)
(lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
((null lead)
(setf *current-frame* prev)
- (print-frame-call prev))))
+ (print-frame-call prev *debug-io*))))
(!def-debug-command-alias "B" "BOTTOM")
(cond (next-frame
(setf frame next-frame))
(t
- (format t
+ (format *debug-io*
"The ~A of the stack was encountered.~%"
limit-string)
(return frame)))))))
- (print-frame-call *current-frame*))
+ (print-frame-call *current-frame* *debug-io*))
(!def-debug-command-alias "F" "FRAME")
\f
(string= (symbol-name sym1)
(symbol-name sym2)))))
(t
- (format t "~S is invalid as a restart name.~%" num)
+ (format *debug-io* "~S is invalid as a restart name.~%"
+ num)
(return-from restart-debug-command nil)))))
(/show0 "got RESTART")
(if restart
(invoke-restart-interactively restart)
- ;; FIXME: Even if this isn't handled by WARN, it probably
- ;; shouldn't go to *STANDARD-OUTPUT*, but *ERROR-OUTPUT* or
- ;; *QUERY-IO* or something. Look through this file to
- ;; straighten out stream usage.
- (princ "There is no such restart.")))))
+ (princ "There is no such restart." *debug-io*)))))
\f
;;;; information commands
(backtrace (read-if-available most-positive-fixnum)))
(!def-debug-command "PRINT" ()
- (print-frame-call *current-frame*))
+ (print-frame-call *current-frame* *debug-io*))
(!def-debug-command-alias "P" "PRINT")
(setf any-p t)
(when (eq (sb!di:debug-var-validity v location) :valid)
(setf any-valid-p t)
- (format t "~S~:[#~W~;~*~] = ~S~%"
+ (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
(sb!di:debug-var-symbol v)
(zerop (sb!di:debug-var-id v))
(sb!di:debug-var-id v)
(cond
((not any-p)
- (format t "There are no local variables ~@[starting with ~A ~]~
- in the function."
+ (format *debug-io*
+ "There are no local variables ~@[starting with ~A ~]~
+ in the function."
prefix))
((not any-valid-p)
- (format t "All variables ~@[starting with ~A ~]currently ~
- have invalid values."
+ (format *debug-io*
+ "All variables ~@[starting with ~A ~]currently ~
+ have invalid values."
prefix))))
- (write-line "There is no variable information available."))))
+ (write-line "There is no variable information available."
+ *debug-io*))))
(!def-debug-command-alias "L" "LIST-LOCALS")
(!def-debug-command "SOURCE" ()
- (fresh-line)
- (print-code-location-source-form (sb!di:frame-code-location *current-frame*)
- (read-if-available 0)))
+ (print (code-location-source-form (sb!di:frame-code-location *current-frame*)
+ (read-if-available 0))
+ *debug-io*))
\f
;;;; source location printing
(setq *cached-source-stream* (open name :if-does-not-exist nil))
(unless *cached-source-stream*
(error "The source file no longer exists:~% ~A" (namestring name)))
- (format t "~%; file: ~A~%" (namestring name)))
+ (format *debug-io* "~%; file: ~A~%" (namestring name)))
(setq *cached-debug-source*
(if (= (sb!di:debug-source-created d-source)
((eq *cached-debug-source* d-source)
(file-position *cached-source-stream* char-offset))
(t
- (format t "~%; File has been modified since compilation:~%; ~A~@
+ (format *debug-io*
+ "~%; File has been modified since compilation:~%; ~A~@
; Using form offset instead of character position.~%"
(namestring name))
(file-position *cached-source-stream* 0)
(let ((*readtable* *cached-readtable*))
(read *cached-source-stream*))))
-(defun print-code-location-source-form (location context)
+(defun code-location-source-form (location context)
(let* ((location (maybe-block-start-location location))
(form-num (sb!di:code-location-form-number location)))
(multiple-value-bind (translations form) (get-toplevel-form location)
(unless (< form-num (length translations))
(error "The source path no longer exists."))
- (prin1 (sb!di:source-path-context form
- (svref translations form-num)
- context)))))
+ (sb!di:source-path-context form
+ (svref translations form-num)
+ context))))
\f
;;; step to the next steppable form
(!def-debug-command "STEP" ()
(function (sb!di:debug-fun-fun debug-fun)))
(if function
(describe function)
- (format t "can't figure out the function for this frame"))))
+ (format *debug-io* "can't figure out the function for this frame"))))
(!def-debug-command "SLURP" ()
(loop while (read-char-no-hang *standard-input*)))
return
(sb!di:frame-code-location *current-frame*))
*current-frame*))
- (format t "~@<can't find a tag for this frame ~
- ~2I~_(hint: try increasing the DEBUG optimization quality ~
- and recompiling)~:@>"))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>"))))
\f
;;;; debug loop command utilities
(defun read-prompting-maybe (prompt)
(unless (sb!int:listen-skip-whitespace *debug-io*)
- (princ prompt)
- (force-output))
+ (princ prompt *debug-io*)
+ (force-output *debug-io*))
(read *debug-io*))
(defun read-if-available (default)
(block ,(fun-name-block-name name)
,@forms)))
(lambda `(lambda ,@lambda-guts))
- #-sb-xc-host
+ #-sb-xc-host
(named-lambda `(named-lambda ,name ,@lambda-guts))
(inline-lambda
(when (inline-fun-name-p name)
`(progn
;; In cross-compilation of toplevel DEFUNs, we arrange for
;; the LAMBDA to be statically linked by GENESIS.
- ;;
- ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
- ;; here instead of LAMBDA. The reason is historical:
- ;; COLD-FSET was written before NAMED-LAMBDA, and has special
- ;; logic of its own to notify the compiler about NAME.
- #+sb-xc-host
+ ;;
+ ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
+ ;; here instead of LAMBDA. The reason is historical:
+ ;; COLD-FSET was written before NAMED-LAMBDA, and has special
+ ;; logic of its own to notify the compiler about NAME.
+ #+sb-xc-host
(cold-fset ,name ,lambda)
-
+
(eval-when (:compile-toplevel)
(sb!c:%compiler-defun ',name ',inline-lambda t))
(eval-when (:load-toplevel :execute)
;; If we want to move over to list-style names
;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like
;; functionality] here might be a good place to start.
- (debug-name (sb!c::debug-namify "DEFMACRO " name)))
+ (debug-name (sb!c::debug-name 'macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%defmacro ',name #',def ',lambda-list ,doc ,debug-name)))))))
+ (sb!c::%defmacro ',name #',def ',lambda-list
+ ,doc ',debug-name)))))))
(macrolet
((def (times set-p)
;;;; various operations on names
;;; Is NAME a legal function name?
+(declaim (inline legal-fun-name-p))
(defun legal-fun-name-p (name)
(values (valid-function-name-p name)))
(%failed-aver ,(format nil "~A" expr))))
(defun %failed-aver (expr-as-string)
+ ;; hackish way to tell we're in a cold sbcl and output the
+ ;; message before signallign error, as it may be this is too
+ ;; early in the cold init.
+ (when (find-package "SB!C")
+ (fresh-line)
+ (write-line "failed AVER:")
+ (write-line expr-as-string)
+ (terpri))
(bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
(defun bug (format-control &rest format-arguments)
(inspected-standard-object-elements object)))
(defmethod inspected-parts ((object function))
- (let* ((type (sb-kernel:widetag-of object))
- (object (if (= type sb-vm:closure-header-widetag)
- (sb-kernel:%closure-fun object)
- object)))
- (values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object
- (sb-kernel:%simple-fun-arglist object)
- ;; Defined-from stuff used to be here. Someone took
- ;; it out. FIXME: We should make it easy to get
- ;; to DESCRIBE from the inspector.
- )
- t
- nil)))
+ (values (format nil "The object is a ~A named ~S.~%"
+ (if (closurep object) 'closure 'function)
+ (%fun-name object))
+ t
+ ;; Defined-from stuff used to be here. Someone took
+ ;; it out. FIXME: We should make it easy to get
+ ;; to DESCRIBE from the inspector.
+ (list*
+ (cons "Lambda-list" (%fun-lambda-list object))
+ (cons "Ftype" (%fun-type object))
+ (when (closurep object)
+ (list
+ (cons "Closed over values" (%closure-values object)))))))
(defmethod inspected-parts ((object vector))
(values (format nil
(let ((def `(lambda (,whole ,environment)
,@local-decs
,body))
- (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name)))
+ (debug-name (sb!c::debug-name 'compiler-macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%define-compiler-macro ',name
- #',def
- ',lambda-list
- ,doc
- ,debug-name))))))
+ (sb!c::%define-compiler-macro ',name
+ #',def
+ ',lambda-list
+ ,doc
+ ',debug-name))))))
;;; FIXME: This will look remarkably similar to those who have already
;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various
(defun pprint-flet (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter
- "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
- stream
- list))
+ (if (cddr list)
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
+ stream
+ list)
+ ;; for printing function names like (flet foo)
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (write (pprint-pop) :stream stream)
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (write (pprint-pop) :stream stream)))))
(defun pprint-let (stream list &rest noise)
(declare (ignore noise))
nil)
(defun output-fun (object stream)
- (let* ((*print-length* 3) ; in case we have to..
- (*print-level* 3) ; ..print an interpreted function definition
- ;; FIXME: This find-the-function-name idiom ought to be
- ;; encapsulated in a function somewhere.
- (name (case (fun-subtype object)
- (#.sb!vm:closure-header-widetag "CLOSURE")
- (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
- (t 'no-name-available)))
- (identified-by-name-p (and (symbolp name)
- (fboundp name)
- (eq (fdefinition name) object))))
- (print-unreadable-object (object
- stream
- :identity (not identified-by-name-p))
- (prin1 'function stream)
- (unless (eq name 'no-name-available)
- (format stream " ~S" name)))))
+ (let* ((*print-length* 3) ; in case we have to..
+ (*print-level* 3) ; ..print an interpreted function definition
+ (name (%fun-name object))
+ (proper-name-p (and (legal-fun-name-p name) (fboundp name)
+ (eq (fdefinition name) object))))
+ (print-unreadable-object (object stream :identity (not proper-name-p))
+ (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
+ (closurep object)
+ name))))
\f
;;;; catch-all for unknown things
(values (svref (sb!c::debug-source-name source) 0)
nil
name))
- ;; FIXME: shouldn't these two clauses be the other way
- ;; round? Using VALID-FUNCTION-NAME-P to see if we
- ;; want to find an inline-expansion?
- ((stringp name)
- (values nil t name))
- (t
+ ((legal-fun-name-p name)
(let ((exp (fun-name-inline-expansion name)))
- (if exp
- (values exp nil name)
- (values nil t name))))))
+ (values exp (not exp) name)))
+ (t
+ (values nil t name))))
(values nil t name))))
+(defun closurep (object)
+ (= sb!vm:closure-header-widetag (widetag-of object)))
+
+(defun %fun-fun (function)
+ (declare (function function))
+ (case (widetag-of function)
+ (#.sb!vm:simple-fun-header-widetag
+ function)
+ (#.sb!vm:closure-header-widetag
+ (%closure-fun function))
+ (#.sb!vm:funcallable-instance-header-widetag
+ (funcallable-instance-fun function))))
+
+(defun %closure-values (object)
+ (declare (function object))
+ (coerce (loop for index from 0 below (1- (get-closure-length object))
+ collect (%closure-index-ref object index))
+ 'simple-vector))
+
+(defun %fun-lambda-list (object)
+ (%simple-fun-arglist (%fun-fun object)))
+
;;; a SETFable function to return the associated debug name for FUN
;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
;;; or NIL if there's none
-(defun %fun-name (fun)
- (case (widetag-of fun)
- (#.sb!vm:closure-header-widetag
- (%simple-fun-name (%closure-fun fun)))
- (#.sb!vm:simple-fun-header-widetag
- ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
- ;; functions is left over from CMU CL (modulo various renaming
- ;; that's gone on since the fork).
- (%simple-fun-name fun))
- (#.sb!vm:funcallable-instance-header-widetag
- (%simple-fun-name
- (funcallable-instance-fun fun)))))
+(defun %fun-name (function)
+ (%simple-fun-name (%fun-fun function)))
+
+(defun %fun-type (function)
+ (%simple-fun-type (%fun-fun function)))
(defun (setf %fun-name) (new-name fun)
(aver nil) ; since this is unsafe 'til bug 137 is fixed
+++, ++, +, ///, //, /, and -."
(setf - form)
(let ((results
- (multiple-value-list
- (eval-in-lexenv form
- (make-null-interactive-lexenv)))))
+ (multiple-value-list
+ (eval-in-lexenv form
+ (make-null-interactive-lexenv)))))
(setf /// //
// /
/ results
#+sb-xc
(defun !typecheckfuns-cold-init ()
+ (/show0 "in typecheckfuns-cold-init")
(setf *typecheckfuns* (make-hash-table :test 'equal))
;; Initialize the table of common typespecs.
(setf *common-typespecs* #.*compile-time-common-typespecs*)
;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs.
+ (/show0 "typecheckfuns-cold-init initial setfs done")
(macrolet ((macro ()
`(progn
,@(map 'list
(lambda (typespec)
- `(setf (gethash ',typespec *typecheckfuns*)
- (lambda (arg)
- (unless (typep arg ',typespec)
- (typecheck-failure arg ',typespec))
- (values))))
- *common-typespecs*))))
+ `(progn
+ (/show0 "setf")
+ (setf (gethash ',typespec *typecheckfuns*)
+ (progn
+ (/show0 "lambda")
+ (lambda (arg)
+ (unless (typep arg ',typespec)
+ (typecheck-failure arg ',typespec))
+ (values))))))
+ *common-typespecs*))))
(macro))
(values))
(values (real) (top) (real-top))))
-;;; COMPONENTs want strings for names, LEAF-DEBUG-NAMEs mightn't be
-;;; strings...
-(defun component-name-from-functional-debug-name (functional)
- (declare (type functional functional))
- (let ((leaf-debug-name (leaf-debug-name functional)))
- (the simple-string
- (if (stringp leaf-debug-name)
- leaf-debug-name
- (debug-namify "function " leaf-debug-name)))))
-
;;; Given a list of top level lambdas, return
;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
;;; Each of the three values returned is a list of COMPONENTs:
;; component, since it might end up with multiple
;; lambdas in it, not just this one, but it does
;; seem a better name than just "<unknown>".
- (component-name-from-functional-debug-name
- component-lambda)))
+ (leaf-debug-name component-lambda)))
(let ((res (dfo-scavenge-dependency-graph component-lambda
new-component)))
(when (eq res new-component)
convention (names like *FOO*) for special variables" symbol))
(values))
-;;; Hacky (duplicating machinery found elsewhere because this function
-;;; turns out to be on a critical path in the compiler) shorthand for
-;;; creating debug names from source names or other stems, e.g.
-;;;
-;;; (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR"
-;;; (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)"
-;;;
-;;; If ALT is given it must be a string -- it is then used in place of
-;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS.
-;;;
-(declaim (inline debug-namify))
-(defun debug-namify (head tail &optional alt)
- (declare (type (or null string) alt))
- (flet ((symbol-debug-name (symbol)
- ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL.
- (if (and alt (eq '.anonymous. symbol))
- alt
- (let ((package (symbol-package symbol))
- (name (symbol-name symbol)))
- (cond
- ((eq package *keyword-package*)
- (concatenate 'string ":" name))
- ((eq package *cl-package*)
- name)
- ((null package)
- (concatenate 'string "#:" name))
- (t
- (multiple-value-bind (symbol status)
- (find-symbol name package)
- (declare (ignore symbol))
- (concatenate 'string
- (package-name package)
- (if (eq status :external) ":" "::")
- name))))))))
- (cond ((and (stringp head) (stringp tail))
- (concatenate 'string head tail))
- ((and (stringp head) (symbolp tail))
- (concatenate 'string head (symbol-debug-name tail)))
- ((and (symbolp head) (stringp tail))
- (concatenate 'string (symbol-debug-name head) tail))
- (t
- (macrolet ((out (obj s)
- `(typecase ,obj
- (string (write-string ,obj ,s))
- (symbol (write-string (symbol-debug-name ,obj) ,s))
- (t (prin1 ,obj ,s)))))
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*print-pretty* nil)
- (*package* *cl-package*)
- (*print-length* 3)
- (*print-level* 2))
- (with-output-to-string (s)
- (out head s)
- (out tail s)))))))))
+(defvar *debug-name-level* 6)
+
+(defun debug-name (type thing)
+ (labels ((walk (x level)
+ (if (> *debug-name-level* (incf level))
+ (typecase x
+ (cons
+ (cons (walk (car x) level) (walk (cdr x) level)))
+ ((or symbol number string)
+ x)
+ (t
+ (format nil "#<~S>" (type-of x))))
+ "#<...>")))
+ ;; FIXME: It might be nice to put markers in the tree instead of
+ ;; this #<...> business, so that they would evantually be printed
+ ;; without the quotes.
+ (let ((name (list type (walk thing 0))))
+ (when (legal-fun-name-p name)
+ (bug "~S is a legal function name, and cannot be used as a ~
+ debug name." name))
+ name)))
(reference-constant start next result thing))
\f
;;;; FUNCTION and NAMED-LAMBDA
+(defun name-lambdalike (thing)
+ (ecase (car thing)
+ ((named-lambda)
+ (second thing))
+ ((lambda instance-lambda)
+ `(lambda ,(second thing)))
+ ((lambda-with-lexenv)'
+ `(lambda ,(fifth thing)))))
+
(defun fun-name-leaf (thing)
(if (consp thing)
(cond
'(lambda named-lambda instance-lambda lambda-with-lexenv))
(values (ir1-convert-lambdalike
thing
- :debug-name (debug-namify "#'" thing))
+ :debug-name (name-lambdalike thing))
t))
((legal-fun-name-p thing)
(values (find-lexically-apparent-fun
(let ((fun (ir1-convert-lambda-body
forms
vars
- :debug-name (debug-namify "LET S"
- bindings))))
+ :debug-name (debug-name 'let bindings))))
(reference-leaf start ctran fun-lvar fun))
(values next result))))
(ir1-convert-combination-args fun-lvar ctran next result values)))))
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
- :debug-name (debug-namify
- "FLET " n)))
+ :debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
(placeholder-funs (mapcar (lambda (name)
(make-functional
:%source-name name
- :%debug-name (debug-namify
- "LABELS placeholder "
+ :%debug-name (debug-name
+ 'labels-placeholder
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
- :debug-name (debug-namify
- "LABELS " name)))
+ :debug-name (debug-name 'labels name)))
names defs))))
;; Modify all the references to the dummy function leaves so
(ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for " tag))))
+ :debug-name (debug-name 'escape-fun tag))))
(ctran (make-ctran)))
(setf (functional-kind fun) :escape)
(ir1-convert start ctran nil `(%%allocate-closures ,fun))
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-namify "LAMBDA-inlined "
- source-name
- "<unknown function>")))
+ :debug-name (debug-name 'lambda-inlined source-name)))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(list (first aux-vars))
:aux-vars (rest aux-vars)
:aux-vals (rest aux-vals)
- :debug-name (debug-namify
- "&AUX bindings "
- aux-vars))))
+ :debug-name (debug-name
+ '&aux-bindings
+ aux-vars))))
(reference-leaf start ctran fun-lvar fun)
(ir1-convert-combination-args fun-lvar ctran next result
(list (first aux-vals)))))
;;; then we mark the corresponding var as EVER-USED to inhibit
;;; "defined but not read" warnings for arguments that are only used
;;; by default forms.
-(defun convert-optional-entry (fun vars vals defaults)
+(defun convert-optional-entry (fun vars vals defaults name)
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
(arg-vars (mapcar (lambda (var)
,@(reverse vals)
,@(default-vals))))
arg-vars
- :debug-name
- (debug-namify "&OPTIONAL processor "
- (gensym))
+ ;; FIXME: Would be nice to
+ ;; share these names instead
+ ;; of consing up several
+ ;; identical ones. Oh well.
+ :debug-name (debug-name
+ '&optional-processor
+ name)
:note-lexical-bindings nil))))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
;; problems: hidden references should not be established to
;; lambdas of kind NIL should not have (otherwise the compiler
;; might let-convert or delete them) and to variables.
- (if (or force
- supplied-p-p ; this entry will be of kind NIL
- (and (lambda-p ep) (eq (lambda-kind ep) nil)))
- (convert-optional-entry ep
- default-vars default-vals
- (if supplied-p
- (list default nil)
- (list default)))
- (delay
- (register-entry-point
- (convert-optional-entry (force ep)
- default-vars default-vals
- (if supplied-p
- (list default nil)
- (list default)))
- res)))))
+ (let ((name (or debug-name source-name))
+ (defaults (if supplied-p (list default nil) (list default))))
+ (if (or force
+ supplied-p-p ; this entry will be of kind NIL
+ (and (lambda-p ep) (eq (lambda-kind ep) nil)))
+ (convert-optional-entry ep
+ default-vars default-vals
+ defaults
+ name)
+ (delay
+ (register-entry-point
+ (convert-optional-entry (force ep)
+ default-vars default-vals
+ defaults
+ name)
+ res))))))
;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
;;;
;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
;;; until we have scanned all the keywords.
-(defun convert-more-entry (res entry-vars entry-vals rest morep keys)
+(defun convert-more-entry (res entry-vars entry-vals rest morep keys name)
(declare (type optional-dispatch res) (list entry-vars entry-vals keys))
(collect ((arg-vars)
(arg-vals (reverse entry-vals))
(%funcall ,(optional-dispatch-main-entry res)
,@(arg-vals))))
(arg-vars)
- :debug-name "&MORE processing"
+ :debug-name (debug-name '&more-processor name)
:note-lexical-bindings nil)))
(setf (optional-dispatch-more-entry res)
(register-entry-point ep res)))))
(main-vals (arg-info-default info))
(bind-vals n-val)))))
- (let* ((main-entry (ir1-convert-lambda-body
+ (let* ((name (or debug-name source-name))
+ (main-entry (ir1-convert-lambda-body
body (main-vars)
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
- :debug-name (debug-namify
- "varargs entry for " source-name debug-name)))
+ :debug-name (debug-name 'varargs-entry name)))
(last-entry (convert-optional-entry main-entry default-vars
- (main-vals) ())))
+ (main-vals) () name)))
(setf (optional-dispatch-main-entry res)
(register-entry-point main-entry res))
- (convert-more-entry res entry-vars entry-vals rest more-context keys)
+ (convert-more-entry res entry-vars entry-vals rest more-context keys
+ name)
(push (register-entry-point
(if supplied-p-p
- (convert-optional-entry last-entry entry-vars entry-vals ())
+ (convert-optional-entry last-entry entry-vars entry-vals
+ () name)
last-entry)
res)
(optional-dispatch-entry-points res))
entry-vars entry-vals
nil nil nil vars supplied-p-p body aux-vars
aux-vals source-name debug-name)
- (let ((fun (ir1-convert-lambda-body
+ (let* ((name (or debug-name source-name))
+ (fun (ir1-convert-lambda-body
body (reverse default-vars)
:aux-vars aux-vars
:aux-vals aux-vals
- :debug-name (debug-namify
- "hairy arg processor for "
- source-name
- debug-name))))
+ :debug-name (debug-name 'hairy-arg-processor name))))
+
(setf (optional-dispatch-main-entry res) fun)
(register-entry-point fun res)
(push (if supplied-p-p
(register-entry-point
- (convert-optional-entry fun entry-vars entry-vals ())
+ (convert-optional-entry fun entry-vars entry-vals ()
+ name)
res)
fun)
(optional-dispatch-entry-points res))
(push (if (lambda-p ep)
(register-entry-point
(if supplied-p-p
- (convert-optional-entry ep entry-vars entry-vals ())
+ (convert-optional-entry
+ ep entry-vars entry-vals nil
+ (or debug-name source-name))
ep)
res)
(progn (aver (not supplied-p-p))
(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals
&key
(source-name '.anonymous.)
- (debug-name (debug-namify
- "OPTIONAL-DISPATCH "
- vars)))
+ (debug-name
+ (debug-name '&optional-dispatch vars)))
(declare (list body vars aux-vars aux-vals))
(let ((res (make-optional-dispatch :arglist vars
:allowp allowp
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
debug-name)
-
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
(type-of form)
(process-decls decls (append aux-vars vars) nil))
(forms (if (and *allow-instrumenting*
(policy *lexenv* (>= insert-debug-catch 2)))
- `((catch (locally (declare (optimize (insert-step-conditions 0)))
- (make-symbol "SB-DEBUG-CATCH-TAG"))
+ `((catch (locally
+ (declare (optimize (insert-step-conditions 0)))
+ (make-symbol "SB-DEBUG-CATCH-TAG"))
,@forms))
forms))
(forms (if (eq result-type *wild-type*)
;;; helper for LAMBDA-like things, to massage them into a form
;;; suitable for IR1-CONVERT-LAMBDA.
-;;;
-;;; KLUDGE: We cons up a &REST list here, maybe for no particularly
-;;; good reason. It's probably lost in the noise of all the other
-;;; consing, but it's still inelegant. And we force our called
-;;; functions to do full runtime keyword parsing, ugh. -- CSR,
-;;; 2003-01-25
-(defun ir1-convert-lambdalike (thing &rest args
- &key (source-name '.anonymous.)
+(defun ir1-convert-lambdalike (thing
+ &key
+ (source-name '.anonymous.)
debug-name)
- (declare (ignorable source-name debug-name))
(ecase (car thing)
- ((lambda) (apply #'ir1-convert-lambda thing args))
+ ((lambda)
+ (ir1-convert-lambda thing
+ :source-name source-name
+ :debug-name debug-name))
((instance-lambda)
- (let ((res (apply #'ir1-convert-lambda
- `(lambda ,@(cdr thing)) args)))
+ (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
+ :source-name source-name
+ :debug-name debug-name)))
(setf (getf (functional-plist res) :fin-function) t)
res))
((named-lambda)
- (let ((name (cadr thing)))
+ (let ((name (cadr thing))
+ (lambda-expression `(lambda ,@(cddr thing))))
(if (legal-fun-name-p name)
(let ((defined-fun-res (get-defined-fun name))
- (res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
- :source-name name
- :debug-name nil
- args)))
+ (res (ir1-convert-lambda lambda-expression
+ :source-name name)))
(assert-global-function-definition-type name res)
- (setf (defined-fun-functional defined-fun-res)
- res)
+ (setf (defined-fun-functional defined-fun-res) res)
(unless (eq (defined-fun-inlinep defined-fun-res) :notinline)
(substitute-leaf-if
(lambda (ref)
(policy ref (> recognize-self-calls 0)))
res defined-fun-res))
res)
- (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
- :debug-name name args))))
- ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args))))
+ (ir1-convert-lambda lambda-expression :debug-name name))))
+ ((lambda-with-lexenv)
+ (ir1-convert-inline-lambda thing
+ :source-name source-name
+ :debug-name debug-name))))
\f
;;;; defining global functions
(component (make-empty-component))
(*current-component* component)
(*allow-instrumenting* t))
- (setf (component-name component) "initial component")
+ (setf (component-name component) 'initial-component)
(setf (component-kind component) :initial)
(let* ((forms (if for-value `(,form) `(,form nil)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-namify "top level form " form))))
+ :debug-name (debug-name 'top-level-form form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
form
(ir1-convert-lambda
opname
- :debug-name (debug-namify
- "LAMBDA CAR "
+ :debug-name (debug-name
+ 'lambda-car
opname))))))))))
(values))
-
+
;; Generate a reference to a manifest constant, creating a new leaf
;; if necessary. If we are producing a fasl file, make sure that
;; MAKE-LOAD-FORM gets used on any parts of the constant that it
(aver (null (functional-entry-fun fun)))
(with-ir1-environment-from-node (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
- :debug-name (debug-namify
- "XEP for "
- (leaf-debug-name fun)))))
+ :debug-name (debug-name
+ 'xep (leaf-debug-name fun)))))
(setf (functional-kind res) :external
(leaf-ever-used res) t
(functional-entry-fun res) fun
(values nil
(ir1-convert-lambda
(functional-inline-expansion original-functional)
- :debug-name (debug-namify
- "local inline "
- (leaf-debug-name
- original-functional)))))))
+ :debug-name (debug-name 'local-inline
+ (leaf-debug-name
+ original-functional)))))))
(cond (losing-local-object
(if (functional-p losing-local-object)
(let ((*compiler-error-context* call))
`(lambda ,vars
(declare (ignorable ,@ignores))
(%funcall ,entry ,@args))
- :debug-name (debug-namify "hairy function entry "
- (lvar-fun-name
- (basic-combination-fun call)))))))
+ :debug-name (debug-name 'hairy-function-entry
+ (lvar-fun-name
+ (basic-combination-fun call)))))))
(convert-call ref call new-fun)
(dolist (ref (leaf-refs entry))
(convert-call-if-possible ref (lvar-dest (node-lvar ref))))))
(component (make-empty-component))
(*current-component* component))
(setf (component-name component)
- (debug-namify "~S initial component" name))
+ (debug-name 'initial-component name))
(setf (component-kind component) :initial)
(let* ((locall-fun (let ((*allow-instrumenting* t))
- (ir1-convert-lambdalike
- definition
- :debug-name (debug-namify "top level local call "
- name))))
+ (apply #'ir1-convert-lambdalike
+ definition
+ (list :source-name name))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
- :debug-name (unless name
- "top level form"))))
+ :debug-name (debug-name 'tl-xep name))))
(when name
(assert-global-function-definition-type name locall-fun))
(setf (functional-entry-fun fun) locall-fun
'(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* (
- (*lexenv* (make-lexenv :policy *policy*
- :handled-conditions *handled-conditions*
- :disabled-package-locks *disabled-package-locks*))
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
(fun (make-functional-from-toplevel-lambda lambda-expression
:name name
:path path)))
;; messed up by IR1 optimizations, so the DFO should be recomputed.
(reanalyze nil :type boolean)
;; some sort of name for the code in this component
- (name "<unknown>" :type simple-string)
+ (name "<unknown>" :type t)
;; When I am a child, this is :NO-IR2-YET.
;; In my adulthood, IR2 stores notes to itself here.
;; After I have left the great wheel and am staring into the GC, this
;; or not, as if it is a valid function name then it can look for an
;; inline expansion.
;;
- ;; The value of this slot can be anything, except that it shouldn't
- ;; be a legal function name, since otherwise debugging gets
- ;; confusing. (If a legal function name is a good name for the
- ;; function, it should be in %SOURCE-NAME, and then we shouldn't
- ;; need a %DEBUG-NAME.) In SBCL as of 0.pre7.87, it's always a
- ;; string unless it's NIL, since that's how CMU CL represented debug
- ;; names. However, eventually I (WHN) think it we should start using
- ;; list values instead, since they have much nicer print properties
- ;; (abbreviation, skipping package prefixes when unneeded, and
- ;; renaming package prefixes when we do things like renaming SB!EXT
- ;; to SB-EXT).
- ;;
;; E.g. for the function which implements (DEFUN FOO ...), we could
;; have
;; %SOURCE-NAME=FOO
;; for the function which implements the top level form
;; (IN-PACKAGE :FOO) we could have
;; %SOURCE-NAME=NIL
- ;; %DEBUG-NAME="top level form (IN-PACKAGE :FOO)"
+ ;; %DEBUG-NAME=(TOP-LEVEL-FORM (IN-PACKAGE :FOO)
;; for the function which implements FOO in
;; (DEFUN BAR (...) (FLET ((FOO (...) ...)) ...))
;; we could have
;; %SOURCE-NAME=FOO
- ;; %DEBUG-NAME="FLET FOO in BAR"
+ ;; %DEBUG-NAME=(FLET FOO)
;; and for the function which implements FOO in
;; (DEFMACRO FOO (...) ...)
;; we could have
;; %SOURCE-NAME=FOO (or maybe .ANONYMOUS.?)
- ;; %DEBUG-NAME="DEFMACRO FOO"
+ ;; %DEBUG-NAME=(MACRO-FUNCTION FOO)
(%debug-name nil
:type (or null (not (satisfies legal-fun-name-p)))
:read-only t)
;; FIXME: It might be better to add another DEFKNOWN property
;; (e.g. NO-TAIL-RECURSION) and use it for error-handling
;; functions like ERROR, instead of spreading this special case
- ;; net so widely.
+ ;; net so widely. --WHN?
+ ;;
+ ;; Why is that bad? Because this non-elimination of
+ ;; non-returning tail calls causes the XEP for FOO appear in
+ ;; backtrace for (defun foo (x) (error "foo ~S" x)) wich seems
+ ;; less then optimal. --NS 2005-02-28
(when ret
(let ((result (return-result ret)))
(do-uses (use result)
(cond ((= safety 0) 0)
;; FIXME: It is duplicated in PROBABLE-TYPE-CHECK-P and in
;; some other places.
-
((and (<= speed safety)
(<= space safety)
(<= compilation-speed safety))
\f
;;;; Check that we get debug arglists right.
+;;; FIXME: This should use some get-argslist like functionality that
+;;; we actually export.
+;;;
;;; Return the debug arglist of the function object FUN as a list, or
;;; punt with :UNKNOWN.
(defun get-arglist (fun)
;;; and that it contains the frames we expect, doesn't contain any
;;; "bogus stack frame"s, and contains the appropriate toplevel call
;;; and hasn't been cut off anywhere.
-(defun verify-backtrace (test-function frame-name
- &key (key #'first) (test #'eql)
- (allow-bogus-frames nil))
- (let ((result nil)
- (return-value nil))
- (block outer-handler
- (handler-bind
- ((error #'(lambda (condition)
- (let ((backtrace (ignore-errors
- (sb-debug:backtrace-as-list))))
- ;; Make sure we find what we're looking for.
- (if (member frame-name backtrace :key key :test test)
- (setf result (list :error condition))
- (print (list :failed :frame frame-name :backtrace backtrace)))
- ;; Make sure there's no bogus stack frames
- ;; unless they're explicitly allowed.
- (when (and (not allow-bogus-frames)
- (member "bogus stack frame" backtrace
- :key #'first :test #'equal))
- (print 'verify-backtrace-bogus)
+(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil))
+ (labels ((args-equal (want real)
+ (cond ((endp want)
+ (endp real))
+ ((eq '&rest (car want))
+ t)
+ ((or (eq '? (car want)) (equal (car want) (car real)))
+ (args-equal (cdr want) (cdr real)))
+ (t
+ nil))))
+ (let ((result nil))
+ (block outer-handler
+ (handler-bind
+ ((error (lambda (condition)
+ ;; find the part of the backtrace we're interested in
+ (let ((backtrace (progn
+ ;; (backtrace 13)
+ (member (caar frame-specs)
+ (sb-debug:backtrace-as-list)
+ :key #'car
+ :test #'equal))))
+
+ (setf result condition)
+
+ (unless backtrace
+ (print :missing-backtrace)
(setf result nil))
+
+ ;; check that we have all the frames we wanted
+ (mapcar
+ (lambda (spec frame)
+ (unless (or (not spec)
+ (and (equal (car spec) (car frame))
+ (args-equal (cdr spec)
+ (cdr frame))))
+ (print (list :mismatch spec frame))
+ (setf result nil)))
+ frame-specs
+ backtrace)
+
;; Make sure the backtrace isn't stunted in
;; any way. (Depends on running in the main
;; thread.)
- (unless (member 'sb-impl::toplevel-init backtrace
- :key #'first :test #'equal)
- (print 'verify-backtrace-stunted)
- (setf result nil)))
- (return-from outer-handler))))
- (funcall test-function)))
- (values result return-value)))
+ (let ((end (last backtrace 2)))
+ (unless (equal (caar end)
+ (if *show-entry-point-details*
+ '(sb-c::tl-xep sb-impl::toplevel-init)
+ 'sb-impl::toplevel-init))
+ (print (list :backtrace-stunted (caar end)))
+ (setf result nil)))
+ (return-from outer-handler)))))
+ (funcall test-function)))
+ result)))
+
+(defvar *undefined-function-frame*
+ ;; bug 353
+ '(#+(or x86 x86-64) "bogus stack frame"
+ #-(or x86 x86-64) "undefined function"))
+#-(or alpha) ; bug 346
;;; Test for "undefined function" (undefined_tramp) working properly.
;;; Try it with and without tail call elimination, since they can have
;;; different effects. (Specifically, if undefined_tramp is incorrect
;;; a stunted stack can result from the tail call variant.)
-#-(or alpha) ; bug 346
(flet ((optimized ()
(declare (optimize (speed 2) (debug 1))) ; tail call elimination
(#:undefined-function 42))
(test (fun)
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(funcall fun)))
- #-x86 ; <- known bug (?): fails for me on 0.8.17.31/Linux/x86 -- WHN 2004-12-27
- (dolist (frame '(#-(or x86 x86-64) "undefined function" ; bug 353
- "FLET COMMON-LISP-USER::TEST"))
- (assert (verify-backtrace (lambda () (test #'optimized)) frame
- :test #'equal
- :allow-bogus-frames (or #+(or x86 x86-64) t))))
- (dolist (frame '(#-(or x86 x86-64) "undefined function" ; bug 353
- "FLET COMMON-LISP-USER::NOT-OPTIMIZED"
- "FLET COMMON-LISP-USER::TEST"))
- (assert (verify-backtrace (lambda () (test #'not-optimized)) frame
- :test #'equal
- :allow-bogus-frames (or #+(or x86 x86-64) t)))))
+ (assert (verify-backtrace
+ (lambda () (test #'optimized))
+ (list *undefined-function-frame*
+ (list '(flet test) #'optimized))))
+
+ (assert (verify-backtrace
+ (lambda () (test #'not-optimized))
+ (list *undefined-function-frame*
+ (list '(flet not-optimized))
+ (list '(flet test) #'not-optimized)))))
+
+#-alpha ; bug 346
;;; Division by zero was a common error on PPC. It depended on the
;;; return function either being before INTEGER-/-INTEGER in memory,
;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
;;; the return value (to the flet or the enclosing top level form) is
;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
;;; Enabling it might catch other problems, so do it anyway.
-#-alpha ; bug 346
-(progn
- (flet ((test-function ()
- (declare (optimize (speed 2) (debug 1))) ; tail call elimination
- (/ 42 0)))
- (assert (verify-backtrace #'test-function '/)))
-
- (flet ((test-function ()
- (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
- (/ 42 0)))
- (assert (verify-backtrace #'test-function '/))))
+(flet ((optimized ()
+ (declare (optimize (speed 2) (debug 1))) ; tail call elimination
+ (/ 42 0))
+ (not-optimized ()
+ (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
+ (/ 42 0))
+ (test (fun)
+ (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
+ (funcall fun)))
+ (assert (verify-backtrace (lambda () (test #'optimized))
+ (list '(/ 42 &rest)
+ (list '(flet test) #'optimized))))
+ (assert (verify-backtrace (lambda () (test #'not-optimized))
+ (list '(/ 42 &rest)
+ '((flet not-optimized))
+ (list '(flet test) #'not-optimized)))))
#-(or alpha) ; bug 61
(progn
(defun throw-test ()
(throw 'no-such-tag t))
- (assert (verify-backtrace #'throw-test
- #-(or x86 x86-64 sparc) 'throw-test
- #+(or x86 x86-64 sparc) "XEP for COMMON-LISP-USER::THROW-TEST" ; bug 354
- :test #'equal)))
+ (assert (verify-backtrace #'throw-test '((throw-test)))))
+
+;;; test entry point handling in backtraces
+
+(defun oops ()
+ (error "oops"))
+
+(defun bt.1 (&key key)
+ (list key))
+
+(defun bt.2 (x)
+ (list x))
+
+(defun bt.3 (&key (key (oops)))
+ (list key))
+
+;;; ERROR instead of OOPS so that tail call elimination doesn't happen
+(defun bt.4 (&optional opt)
+ (list (error "error")))
+
+(defun bt.5 (&optional (opt (oops)))
+ (list opt))
+
+(macrolet ((with-details (bool &body body)
+ `(let ((sb-debug:*show-entry-point-details* ,bool))
+ ,@body)))
+
+ ;; &MORE-PROCESSOR
+ (with-details t
+ (assert (verify-backtrace (lambda () (bt.1 :key))
+ '(((sb-c::&more-processor bt.1) &rest)))))
+ (with-details nil
+ (assert (verify-backtrace (lambda () (bt.1 :key))
+ '((bt.1 :key)))))
+
+ ;; XEP
+ (with-details t
+ (assert (verify-backtrace #'bt.2
+ '(((sb-c::xep bt.2) 0 ?)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.2
+ '((bt.2)))))
+
+ ;; TL-XEP
+ (with-details t
+ (assert (verify-backtrace #'namestring
+ '(((sb-c::tl-xep namestring) 0 ?)))))
+ (with-details nil
+ (assert (verify-backtrace #'namestring
+ '((namestring)))))
+
+ ;; VARARGS-ENTRY
+ (with-details t
+ (assert (verify-backtrace #'bt.3
+ '(((sb-c::varargs-entry bt.3) :key nil)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.3
+ '((bt.3 :key nil)))))
+
+ ;; HAIRY-ARG-PROCESSOR
+ (with-details t
+ (assert (verify-backtrace #'bt.4
+ '(((sb-c::hairy-arg-processor bt.4) ?)))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.4
+ '((bt.4 ?)))))
+
+ ;; &OPTIONAL-PROCESSOR
+ (with-details t
+ (assert (verify-backtrace #'bt.5
+ '(((sb-c::&optional-processor bt.5))))))
+ (with-details nil
+ (assert (verify-backtrace #'bt.5
+ '((bt.5))))))
;;; success
(quit :unix-status 104)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.20"
+"0.8.20.1"
projects / sbcl.git / commitdiff