From b8d2c47e351cfe28802001d0315657c807bf73c4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 15 Feb 2015 12:17:23 +0100 Subject: [PATCH] Add Guile frame filter interface. gdb/ChangeLog: * guile/scm-frame-filter.c: * guile/lib/gdb/frames.scm: New files. * guile/guile.c (guile_extension_ops): Add the Guile frame filter. (initialize_gdb_module): Initialize the Guile frame filter module. * guile/guile-internal.h (frscm_scm_from_frame) (gdbscm_apply_frame_filter, gdbscm_initialize_frame_filters): New declarations. * Makefile.in: Add scm-frame-filter.c. * data-directory/Makefile.in: Add frames.scm. * guile/scm-frame.c (frscm_scm_from_frame): Export. gdb/doc/ChangeLog: * guile.texi (Guile Frame Filter API) (Writing a Frame Filter in Guile): New sections. --- gdb/ChangeLog | 15 + gdb/Makefile.in | 6 + gdb/data-directory/Makefile.in | 2 + gdb/doc/ChangeLog | 5 + gdb/doc/guile.texi | 379 +++++++++++++++ gdb/guile/guile-internal.h | 10 + gdb/guile/guile.c | 3 +- gdb/guile/lib/gdb/frames.scm | 326 +++++++++++++ gdb/guile/scm-frame-filter.c | 1001 ++++++++++++++++++++++++++++++++++++++++ gdb/guile/scm-frame.c | 2 +- 10 files changed, 1747 insertions(+), 2 deletions(-) create mode 100644 gdb/guile/lib/gdb/frames.scm create mode 100644 gdb/guile/scm-frame-filter.c diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 0b7b4b7..8003dab 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,18 @@ +2015-02-15 Andy Wingo + + * guile/scm-frame-filter.c: + * guile/lib/gdb/frames.scm: New files. + * guile/guile.c (guile_extension_ops): Add the Guile frame + filter. + (initialize_gdb_module): Initialize the Guile frame filter + module. + * guile/guile-internal.h (frscm_scm_from_frame) + (gdbscm_apply_frame_filter, gdbscm_initialize_frame_filters): New + declarations. + * Makefile.in: Add scm-frame-filter.c. + * data-directory/Makefile.in: Add frames.scm. + * guile/scm-frame.c (frscm_scm_from_frame): Export. + 2015-02-10 Andy Wingo * guile/guile.c (_initialize_guile): Disable automatic diff --git a/gdb/Makefile.in b/gdb/Makefile.in index 00fb2cd..49bd2d2 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -310,6 +310,7 @@ SUBDIR_GUILE_OBS = \ scm-disasm.o \ scm-exception.o \ scm-frame.o \ + scm-frame-filter.o \ scm-gsmob.o \ scm-iterator.o \ scm-lazy-string.o \ @@ -336,6 +337,7 @@ SUBDIR_GUILE_SRCS = \ guile/scm-disasm.c \ guile/scm-exception.c \ guile/scm-frame.c \ + guile/scm-frame-filter.c \ guile/scm-gsmob.c \ guile/scm-iterator.c \ guile/scm-lazy-string.c \ @@ -2405,6 +2407,10 @@ scm-frame.o: $(srcdir)/guile/scm-frame.c $(COMPILE) $(srcdir)/guile/scm-frame.c $(POSTCOMPILE) +scm-frame-filter.o: $(srcdir)/guile/scm-frame-filter.c + $(COMPILE) $(srcdir)/guile/scm-frame-filter.c + $(POSTCOMPILE) + scm-gsmob.o: $(srcdir)/guile/scm-gsmob.c $(COMPILE) $(srcdir)/guile/scm-gsmob.c $(POSTCOMPILE) diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in index c01b86d..e406e9e 100644 --- a/gdb/data-directory/Makefile.in +++ b/gdb/data-directory/Makefile.in @@ -87,6 +87,7 @@ GUILE_SOURCE_FILES = \ ./gdb.scm \ gdb/boot.scm \ gdb/experimental.scm \ + gdb/frames.scm \ gdb/init.scm \ gdb/iterator.scm \ gdb/printing.scm \ @@ -96,6 +97,7 @@ GUILE_SOURCE_FILES = \ GUILE_COMPILED_FILES = \ ./gdb.go \ gdb/experimental.go \ + gdb/frames.go \ gdb/iterator.go \ gdb/printing.go \ gdb/support.go \ diff --git a/gdb/doc/ChangeLog b/gdb/doc/ChangeLog index b8e1f7f..c7f6470 100644 --- a/gdb/doc/ChangeLog +++ b/gdb/doc/ChangeLog @@ -1,3 +1,8 @@ +2015-02-15 Andy Wingo + + * guile.texi (Guile Frame Filter API) + (Writing a Frame Filter in Guile): New sections. + 2015-02-09 Markus Metzger * gdb.texinfo (Branch Trace Configuration Format): Add size. diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi index 53e69f2..d9b3638 100644 --- a/gdb/doc/guile.texi +++ b/gdb/doc/guile.texi @@ -141,6 +141,8 @@ from the Guile interactive prompt. * Guile Pretty Printing API:: Pretty-printing values with Guile * Selecting Guile Pretty-Printers:: How GDB chooses a pretty-printer * Writing a Guile Pretty-Printer:: Writing a pretty-printer +* Guile Frame Filter API:: Filtering frames. +* Writing a Frame Filter in Guile:: Writing a frame filter. * Commands In Guile:: Implementing new commands in Guile * Parameters In Guile:: Adding new @value{GDBN} parameters * Progspaces In Guile:: Program spaces @@ -1693,6 +1695,383 @@ my_library.so: bar @end smallexample +@node Guile Frame Filter API +@subsubsection Filtering Frames in Guile +@cindex frame filters api + +Frame filters allow the user to programmatically alter the way a +backtrace (@pxref{Backtrace}) prints. Frame filters can reorganize, +annotate, insert, and remove frames in a backtrace. + +Only commands that print a backtrace, or, in the case of @sc{gdb/mi} +commands (@pxref{GDB/MI}), those that return a collection of frames +are affected. The commands that work with frame filters are: + +@code{backtrace} (@pxref{backtrace-command,, The backtrace command}), +@code{-stack-list-frames} +(@pxref{-stack-list-frames,, The -stack-list-frames command}), +@code{-stack-list-variables} (@pxref{-stack-list-variables,, The +-stack-list-variables command}), @code{-stack-list-arguments} +@pxref{-stack-list-arguments,, The -stack-list-arguments command}) and +@code{-stack-list-locals} (@pxref{-stack-list-locals,, The +-stack-list-locals command}). + +A frame filter is a function that takes a SRFI-41 stream of annotated +frame objects as an argument, and returns a potentially modified +stream of annotated frame objects. @xref{SRFI-41,,,guile,The Guile +Reference Manual}, for more on the SRFI-41 specification for lazy +streams. Operating over a stream allows frame filters to inspect, +reorganize, insert, and remove frames. @value{GDBN} also provides a +more simple @dfn{frame annotator} API that works on individual frames, +for the common case in which the user does not need to reorganize the +backtrace. Both APIs are described below. + +There can be multiple frame filters registered with @value{GDBN}, and +each one may be individually enabled or disabled at will. Multiple +frame filters can be enabled at the same time. Frame filters have an +associated @dfn{priority} which determines the order in which they are +applied over the annotated frame stream. For example, if there are +two filters registered and enabled, @var{f1} and @var{f2}, and the +priority of @var{f2} is greater than that of @var{f1}, then the result +of frame filtering will be @code{(@var{f2} (@var{f1} @var{stream}))}. +In this way, higher-priority frame filters get the last word on the +backtrace that is ultimately printed. + +An important consideration when designing frame filters, and well +worth reflecting upon, is that frame filters should avoid unwinding +the call stack if possible. Some stacks can run very deep, into the +tens of thousands in some cases. To search every frame when a frame +filter executes may be too expensive at that step. The frame filter +cannot know how many frames it has to iterate over, and it may have to +iterate through them all. This ends up duplicating effort as +@value{GDBN} performs this iteration when it prints the frames. +Therefore a frame filter should avoid peeking ahead in the frame +stream, if possible. @xref{Writing a Frame Filter}, for examples on +how to write a good frame filter. + +To use frame filters, first load the @code{(gdb frames)} module to +have access to the procedures that manipulate frame filters: + +@example +(use-modules (gdb frames)) +@end example + +@deffn {Scheme Procedure} add-frame-filter! name filter @ + @r{[}#:priority priority@r{]} @ + @r{[}#:objfile objfile@r{]} @r{[}#:progspace progspace@r{]} +Register the frame filter procedure @var{filter} with @value{GDBN}. +@var{filter} should be a function of one argument, taking a SRFI-41 +stream of annotated frames and returning a possibily modified stream +of annotated frames. The filter is identified by @var{name}, which +should be unique among all known filters. + +The filter will be registered with the given @var{priority}, which +should be a number, and which defaults to 20 if not given. By +default, the filter is @dfn{global}, meaning that it is associated +with all objfiles and progspaces. Pass one of @code{#:objfile} or +@code{#:progspace} to instead associate the filter with a specific +objfile or progspace, respectively. + +The filter will be initially enabled. +@end deffn + +@deffn {Scheme Procedure} all-frame-filters +Return a list of the names of all frame filters. +@end deffn + +@deffn {Scheme Procedure} remove-frame-filter! name +@deffnx {Scheme Procedure} enable-frame-filter! name +@deffnx {Scheme Procedure} disable-frame-filter! name +Remove, enable, or disable a frame filter, respectively. @var{name} +should correspond to the name of a filter previously added with +@code{add-frame-filter!}. If no such filter is found, an error is +signalled. +@end deffn + +When a command is executed from @value{GDBN} that is compatible with +frame filters, @value{GDBN} selects all filters registered in the +current progspace, filters for all objfiles, and filters with no +associated objfile or progspace. That list is then sorted by +priority, as described above, and applied to the annotated frame +stream. + +An annotated frame is a Guile record type that holds information about +a frame: its function name, its arguments, its locals, and so on. An +annotated frame is always associated with a GDB frame object. To +add, remove, or otherwise alter information associated with an +annotated frame, use the @code{reannotate-frame} procedure. + +@deffn {Scheme Procedure} reannotate-frame! ann @ + @r{[}#:function-name function-name@r{]} @ + @r{[}#:address address@r{]} @ + @r{[}#:filename filename@r{]} @ + @r{[}#:line line@r{]} @ + @r{[}#:arguments arguments@r{]} @ + @r{[}#:locals locals@r{]} @ + @r{[}#:children children@r{]} +Take the annotated frame object @var{ann} and return a new annotated +frame object, replacing the fields specified by the keyword arguments +with their new values. For example, calling @code{(reannotate-frame +@var{x} #:function-name "foo")} will create a new annotated frame +object that inherits all fields from @var{x}, but whose function name +has been set to @code{"foo"}. +@end deffn + +The @code{(gdb frames)} module defines accessors for the various +fields of annotated frame objects. + +@deffn {Scheme Procedure} annotated-frame-frame ann +Return the GDB frame object associated with the annotated frame +@var{ann}. @xref{Frames In Guile}. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-function-name ann +Return the function name associated with the annotated frame +@var{ann}, as a string, or @code{#f} if not available. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-address ann +Return the address associated with the annotated frame @var{ann}, as +an integer. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-filename ann +Return the file name associated with the annotated frame @var{ann}, as +a string, or @code{#f} if not available. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-line ann +Return the line number associated with the annotated frame @var{ann}, +as an integer, or @code{#f} if not available. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-arguments ann +Return a list of the function arguments associated with the annotated +frame @var{ann}. Each item of the list should either be a GDB symbol +(@pxref{Symbols In Guile}), a pair of a GDB symbol and a GDB value +(@pxref{Values From Inferior In Guile}, or a pair of a string and a +GDB value. In the first case, the value will be loaded from the frame +if needed. +@end deffn + +@deffn {Scheme Procedure} annotated-frame-locals ann +Return a list of the function arguments associated with the annotated +frame @var{ann}, in the same format as for +@code{annotated-frame-arguments}. +@end deffn + +Annotated frames may also have @dfn{child frames}. By default, no +frame has a child frame, but filters may reorganize the frame stream +into a stream of frame trees, by populating the child list. Of +course, such a reorganization is ultimately cosmetic, as it doesn't +alter the stack of frames seen by @value{GDBN} and navigable by the +user, for example by using the @code{frame} command. Still, nesting +frames may lead to a more understandable presentation of a backtrace. + +@deffn {Scheme Procedure} annotated-frame-children ann +Return a list of the @dfn{child frames} function name associated with +the annotated frame @var{ann}. Each item of the list should be an +annotated frame object. +@end deffn + +While frame filters can both reorganize and reannotate the frame +stream, it is often the case that one only wants to reannotate the +frames in a stream, without reorganizing then. In that case there is +a simpler API for @dfn{frame annotators} that simply maps annotated +frames to annotated frames. + +@deffn {Scheme Procedure} add-frame-annotator! name annotator @ + @r{[}#:priority priority@r{]} @ + @r{[}#:objfile objfile@r{]} @r{[}#:progspace progspace@r{]} +Register the frame annotator procedure @var{annotator} with +@value{GDBN}. @var{annotator} should be a function of one argument, +takingn annotated frame object and returning a possibily modified +annotated frame. The annotator is identified by @var{name}, which +should be unique among all known annotators. + +The annotator has an associated priority, as with frame filters. See +the documentation on @code{add-frame-filter!}, for more. + +The annotator will be initially enabled. +@end deffn + +@deffn {Scheme Procedure} all-frame-annotators +Return a list of the names of all frame annotators. +@end deffn + +@deffn {Scheme Procedure} remove-frame-annotator! name +@deffnx {Scheme Procedure} enable-frame-annotator! name +@deffnx {Scheme Procedure} disable-frame-annotator! name +Remove, enable, or disable a frame annotator, respectively. +@var{name} should correspond to the name of a annotator previously +added with @code{add-frame-annotator!}. If no such annotator is +found, an error is signalled. +@end deffn + +@node Writing a Frame Filter in Guile +@subsubsection Writing a Frame Filter in Guile +@cindex writing a frame filter + +The simplest kind of frame filter just takes the incoming stream of +frames and produces an identical stream of values. For example: + +@example +(use-modules (gdb frames)) + +(define (identity-frame-filter stream) + (cond + ((stream-null? stream) + ;; End of stream? Then return end-of-stream. + stream-null) + (else + ;; Otherwise recurse on the tail of the stream. + (stream-cons (stream-car stream) + (identity-frame-filter (stream-cdr stream)))))) +@end example + +If you are not familiar with SRFI-41 streams, you might think that +this would eagerly traverse the whole stack of frames. This would be +bad because we don't want to produce an entire backtrace at once when +the user might cancel after only seeing one page. However this is not +the case, because unlike normal Scheme procedures, @code{stream-cons} +is @dfn{lazy} in its arguments, which is to say that its arguments are +only evaluated when they are accessed via @code{stream-car} and +@code{stream-cdr}. In this way the stream looks infinite, but in +reality only produces values as they are requested by the caller. + +To use this frame filter, we have to register it with @value{GDBN}. + +@example +(add-frame-filter! "identity" identity-frame-filter) +@end example + +Now our filter will run each time a backtrace is printed, or in +general for any GDB command that uses the frame filter interface. + +Filters are enabled when they are added. You can control the enabled +or disabled state of a filter using the appropriate procedures: + +@example +(disable-frame-filter! "identity") +(enable-frame-filter! "identity") +@end example + +Finally, we can remove all filters with a simple application of +@code{for-each}: + +@example +(for-each remove-frame-filter! (all-frame-filters)) +@end example + +The same general mechanics apply to frame annotators as well. + +Let us define a more interesting example. For example, in Guile there +is a function @code{scm_call_n}, which may be invoked directly but is +often invoked via well-known wrappers like @code{scm_call_0}, +@code{scm_call_1}, and so on. For example here is part of a backtrace +of an optimized Guile build, when you first start a Guile REPL: + +@smallexample +#10 0x00007ffff7b6ed91 in vm_debug_engine ([...]) at vm-engine.c:815 +#11 0x00007ffff7b74380 in scm_call_n ([...]) at vm.c:1258 +#12 0x00007ffff7afb9d9 in scm_call_0 ([...]) at eval.c:475 +#13 0x00007ffff7b74a0e in sf_fill_input ([...]) at vports.c:94 +@end smallexample + +For the sake of the example, the arguments to each have been +abbreviated to @code{[...]}. Now, it might be nice if we could nest +@code{scm_call_n} inside @code{scm_call_0}, so let's do that: + +@smallexample +(use-modules (gdb) (gdb frames) (srfi srfi-41)) + +(define (nest-scm-call-filter stream) + (cond + ((stream-null? stream) + ;; No frames. + stream) + (else + (let ((ann (stream-car stream)) + (stream* (stream-cdr stream))) + ;; A base case, for when the head frame does not match. + (define (continue) + (stream-cons ann (nest-scm-call-filter stream*))) + + (cond + ;; Is this a call to scm_call_n and is there a next frame? + ((and (equal? (annotated-frame-function-name ann) "scm_call_n") + (not (stream-null? stream*))) + (let* ((next (stream-car stream*)) + (next-name (annotated-frame-function-name next))) + (cond + ;; Does the next frame have a function name and + ;; does it start with "scm_call_"? + ((and next-name + (string-prefix? "scm_call_" next-name)) + ;; A match! Reorganize the first two frames into + ;; one annotated frame with a child. + (let* ((children (cons ann + (annotated-frame-children next))) + (next (reannotate-frame next #:children children))) + (stream-cons next + (nest-scm-call-filter (stream-cdr stream*))))) + (else (continue))))) + (else (continue))))))) + +(add-frame-filter! "nest-scm-call" nest-scm-call-filter) +@end smallexample + +With this filter in place, the resulting backtrace looks like: + +@smallexample +#10 0x00007ffff7b6ed91 in vm_debug_engine ([...]) at vm-engine.c:815 +#12 0x00007ffff7afb9d9 in scm_call_0 ([...]) at eval.c:475 + #11 0x00007ffff7b74380 in scm_call_n ([...]) at vm.c:1258 +#13 0x00007ffff7b74a0e in sf_fill_input ([...]) at vports.c:94 +@end smallexample + +As you can see, frame #11 has been nested below frame #12. + +Sometimes, though, all this stream processing and stream recursion can +be too complicated if your desire is just to annotate individual +frames. In that situation, the frame annotator API can be more +appropriate. For example, if we know that there are some C procedures +that have ``aliases'' in some other language, like Scheme, then we can +annotate them in the backtrace with their Scheme names. + +@smallexample +(use-modules (gdb frames)) + +(define *function-name-aliases* + '(("scm_primitive_eval" . "primitive-eval"))) + +(define (alias-annotator ann) + (let* ((name (annotated-frame-function-name ann)) + (alias (assoc-ref *function-name-aliases* name))) + (if alias + (reannotate-frame ann #:function-name + (string-append "[" alias "] " name)) + ann))) + +(add-frame-annotator! "alias-annotator" alias-annotator) +@end smallexample + +A backtrace with this annotator in place produces: + +@smallexample +#19 [...] in vm_debug_engine ([...]) at vm-engine.c:806 +#20 [...] in scm_call_n ([...]) at vm.c:1258 +#21 [...] in [primitive-eval] scm_primitive_eval ([...]) at eval.c:656 +#22 [...] in scm_eval ([...]) at eval.c:690 +#23 [...] in scm_shell ([...]) at script.c:454 +@end smallexample + +Again, parts have been elided with @code{[...]}. + +It is possible to do the job of an annotator with a filter, but if the +task is simple enough for an annotator, it's much less code, as the +above example shows. + @node Commands In Guile @subsubsection Commands In Guile diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h index 7b7f592..9733e20 100644 --- a/gdb/guile/guile-internal.h +++ b/gdb/guile/guile-internal.h @@ -32,6 +32,7 @@ struct block; struct frame_info; struct objfile; struct symbol; +struct inferior; /* A function to pass to the safe-call routines to ignore things like memory errors. */ @@ -421,6 +422,9 @@ typedef struct _frame_smob frame_smob; extern int frscm_is_frame (SCM scm); +extern SCM frscm_scm_from_frame (struct frame_info *frame, + struct inferior *inferior); + extern frame_smob *frscm_get_frame_smob_arg_unsafe (SCM frame_scm, int arg_pos, const char *func_name); @@ -578,6 +582,11 @@ extern enum ext_lang_rc gdbscm_apply_val_pretty_printer const struct value_print_options *options, const struct language_defn *language); +extern enum ext_lang_bt_status gdbscm_apply_frame_filter + (const struct extension_language_defn *, + struct frame_info *frame, int flags, enum ext_lang_frame_args args_type, + struct ui_out *out, int frame_low, int frame_high); + extern int gdbscm_breakpoint_has_cond (const struct extension_language_defn *, struct breakpoint *b); @@ -594,6 +603,7 @@ extern void gdbscm_initialize_commands (void); extern void gdbscm_initialize_disasm (void); extern void gdbscm_initialize_exceptions (void); extern void gdbscm_initialize_frames (void); +extern void gdbscm_initialize_frame_filters (void); extern void gdbscm_initialize_iterators (void); extern void gdbscm_initialize_lazy_strings (void); extern void gdbscm_initialize_math (void); diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c index e9d2aae..3ad362b 100644 --- a/gdb/guile/guile.c +++ b/gdb/guile/guile.c @@ -147,7 +147,7 @@ static const struct extension_language_ops guile_extension_ops = gdbscm_apply_val_pretty_printer, - NULL, /* gdbscm_apply_frame_filter, */ + gdbscm_apply_frame_filter, gdbscm_preserve_values, @@ -663,6 +663,7 @@ initialize_gdb_module (void *data) gdbscm_initialize_commands (); gdbscm_initialize_disasm (); gdbscm_initialize_frames (); + gdbscm_initialize_frame_filters (); gdbscm_initialize_iterators (); gdbscm_initialize_lazy_strings (); gdbscm_initialize_math (); diff --git a/gdb/guile/lib/gdb/frames.scm b/gdb/guile/lib/gdb/frames.scm new file mode 100644 index 0000000..9bab59f --- /dev/null +++ b/gdb/guile/lib/gdb/frames.scm @@ -0,0 +1,326 @@ +;; Frame filter support. +;; +;; Copyright (C) 2015 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +(define-module (gdb frames) + #:use-module ((gdb) #:hide (frame? symbol?)) + #:use-module ((gdb) #:select ((frame? . gdb:frame?) (symbol? . gdb:symbol?))) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) + #:export (reannotate-frame + annotated-frame? + annotated-frame-frame + annotated-frame-function-name + annotated-frame-address + annotated-frame-filename + annotated-frame-line + annotated-frame-arguments + annotated-frame-locals + annotated-frame-children + + add-frame-annotator! + all-frame-annotators + remove-frame-annotator! + enable-frame-annotator! + disable-frame-annotator! + + add-frame-filter! + all-frame-filters + remove-frame-filter! + enable-frame-filter! + disable-frame-filter!)) + +(define-record-type + (make-annotated-frame frame function-name address filename line + arguments locals children) + annotated-frame? + (frame annotated-frame-frame) ; frame + (function-name annotated-frame-function-name) ; string + (address annotated-frame-address) ; int + (filename annotated-frame-filename) ; string + (line annotated-frame-line) ; int + ;; local := symbol | (string . value) + (arguments annotated-frame-arguments) ; (local ...) + (locals annotated-frame-locals) ; (local ...) + (children annotated-frame-children) ; (annotated-frame ...) + ) + +(define (frame-function-name frame) + (let ((f (frame-function frame))) + (cond + ((not f) f) + ((gdb:symbol? f) (symbol-print-name f)) + (else (object->string f))))) + +(define (frame-filename frame) + (or (and=> (frame-sal frame) + (lambda (sal) + (and=> (sal-symtab sal) symtab-filename))) + ;; FIXME: Fall back to (solib-name (frame-pc frame)) if present. + #f)) + +(define (frame-line frame) + (and=> (frame-sal frame) sal-line)) + +(define (frame-arguments frame) + (let lp ((block (false-if-exception (frame-block frame)))) + (cond + ((not block) '()) + ((not (block-function block)) (lp (block-superblock block))) + (else + (filter symbol-argument? (block-symbols block)))))) + +(define (frame-locals frame) + (let lp ((block (false-if-exception (frame-block frame)))) + (if (or (not block) (block-global? block) (block-static? block)) + '() + (append (remove symbol-argument? (block-symbols block)) + (lp (block-superblock block)))))) + +;; frame -> annotated-frame +(define (annotate-frame frame) + (make-annotated-frame frame + (frame-function-name frame) + (frame-pc frame) + (frame-filename frame) + (frame-line frame) + (frame-arguments frame) + (frame-locals frame) + '())) + +(define* (reannotate-frame ann #:key + (function-name (annotated-frame-function-name ann)) + (address (annotated-frame-address ann)) + (filename (annotated-frame-filename ann)) + (line (annotated-frame-line ann)) + (arguments (annotated-frame-arguments ann)) + (locals (annotated-frame-locals ann)) + (children (annotated-frame-children ann))) + (define (valid-local? x) + (or (gdb:symbol? x) + (and (pair? x) + (or (gdb:symbol? (car x)) (string? (car x))) + (value? (cdr x))))) + (define (list-of? pred x) + (and (list? x) (and-map pred x))) + (unless (or (not function-name) (string? function-name)) + (error "function-name should be a string or #f")) + (unless (and (exact-integer? address) (not (negative? address))) + (error "address should be an non-negative integer")) + (unless (or (not filename) (string? filename)) + (error "filename should be a string or #f")) + (unless (or (not line) (and (exact-integer? line) (positive? line))) + (error "line expected to a positive integer or #f")) + (unless (list-of? valid-local? arguments) + (error "arguments should be a list of symbol-value pairs, \ +string-value pairs, or symbols")) + (unless (list-of? valid-local? locals) + (error "locals should be a list of symbol-value pairs, \ +string-value pairs, or symbols")) + (unless (and-map annotated-frame? children) + (error "children should be annotated frames" children)) + (make-annotated-frame (annotated-frame-frame ann) + function-name address filename line arguments locals + children)) + +(define-record-type + (make-scoped-priority-item name priority enabled? entry scope) + priority-item? + (name &name) + (priority &priority) + (enabled? &enabled? set-enabled?!) + (entry &entry) + (scope &scope)) + +(define (add-to-priority-list priority-list name priority enabled? entry scope) + (when (find (lambda (x) (equal? (&name x) name)) priority-list) + (error "Name already present in list" name)) + (sort (cons (make-scoped-priority-item name priority enabled? entry scope) + priority-list) + (lambda (a b) + (>= (&priority a) (&priority b))))) + +(define (remove-from-priority-list priority-list name) + (remove (lambda (x) (equal? (&name x) name)) priority-list)) + +(define (priority-list-enable! priority-list name) + (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list))) + (unless item + (error "Name not found in list" name)) + (set-enabled?! item #t))) + +(define (priority-list-disable! priority-list name) + (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list))) + (unless item + (error "Name not found in list" name)) + (set-enabled?! item #f))) + +(define-syntax-rule (define-scoped-priority-list *priority-list* + all-names active-entries add! remove! enable! disable!) + (begin + (define *priority-list* '()) + + ;; -> (name ...), from low to high priority + (define (all-names) + (reverse (map &name *priority-list*))) + + ;; -> (entry ...), from low to high priority + (define* (active-entries progspace) + (reverse (filter-map (lambda (item) + (and (&enabled? item) + ;; The entry matches if its progspace + ;; matches, its objfile is still + ;; valid, or if it is not associated + ;; with a specific progspace or + ;; objfile. + (let ((scope (&scope item))) + (or (not scope) + (if (progspace? scope) + (eq? progspace scope) + (objfile-valid? scope)))) + (&entry item))) + *priority-list*))) + + (define* (add! name entry #:key objfile progspace (priority 20)) + ;; scope := objfile | progspace | #f + (define (compute-scope objfile progspace) + (cond + (objfile + (when progspace + (error "Only one of #:objfile or #:progspace may be given")) + (unless (objfile? objfile) + (error "Not an objfile" objfile)) + objfile) + (progspace + (unless (progspace? progspace) + (error "Not a progspace" progspace)) + progspace) + (else #f))) + (let ((scope (compute-scope objfile progspace))) + (set! *priority-list* + (add-to-priority-list *priority-list* + name priority #t entry scope)))) + + (define (remove! name) + (set! *priority-list* + (remove-from-priority-list *priority-list* name))) + + (define (enable! name) + (priority-list-enable! *priority-list* name)) + + (define (disable! name) + (priority-list-disable! *priority-list* name)))) + +;; frame-annotator := annotated-frame -> annotated-frame +(define-scoped-priority-list *frame-annotators* + all-frame-annotators + active-frame-annotators + add-frame-annotator! + remove-frame-annotator! + enable-frame-annotator! + disable-frame-annotator!) + +(define (apply-fold functions seed) + (fold (lambda (f seed) (f seed)) seed functions)) + +(define (apply-frame-annotators ann) + (apply-fold (active-frame-annotators (current-progspace)) ann)) + +;; frame-filter := Stream annotated-frame -> Stream annotated-frame +(define-scoped-priority-list *frame-filters* + all-frame-filters + active-frame-filters + add-frame-filter! + remove-frame-filter! + enable-frame-filter! + disable-frame-filter!) + +(define (apply-frame-filters ann) + (apply-fold (active-frame-filters (current-progspace)) ann)) + +;; frame int int -> Stream annotated-frame +(define (frame-stream frame frame-low frame-high) + (define (make-stream frame index count) + (let ((frames (stream-unfold annotate-frame gdb:frame? frame-older frame))) + (if count + (stream-take frames count) + frames))) + (if (negative? frame-low) + ;; Traverse the stack to find the outermost N frames. + (let ((count (- frame-low))) + (let lp ((older frame) (n 0)) + (cond + ((not older) + (make-stream frame 0 n)) + ((< n count) + (lp (frame-older frame) (1+ n))) + (else + ;; "older" is now "count" frames older than "frame". Keep + ;; going until we hit the oldest frame. + (let lp ((frame frame) (older older) (newer-index 0)) + (if older + (lp (frame-older frame) (frame-older older) (1+ newer-index)) + (make-stream frame newer-index count))))))) + (let lp ((frame frame) (frame-low frame-low) (newer-index 0)) + ;; Cut the innermost N frames. + (cond + ((not frame) 'no-frames) + ((zero? frame-low) + (let ((count (if (eqv? frame-high -1) + #f + (1+ (max (- frame-high newer-index) 0))))) + (make-stream frame newer-index count))) + (else + (lp (frame-older frame) (1- frame-low) (1+ newer-index))))))) + +(define (stream->gdb-iterator stream lower) + (make-iterator stream stream + (lambda (iter) + (let ((stream (iterator-progress iter))) + (cond + ((stream-null? stream) + (end-of-iteration)) + (else + (set-iterator-progress! iter (stream-cdr stream)) + (lower (stream-car stream)))))))) + +(define (annotated-frame->vector ann) + ;; C can't deal so nicely with record types, so lower to a more simple + ;; data structure. + (vector (annotated-frame-frame ann) + (annotated-frame-function-name ann) + (annotated-frame-address ann) + (annotated-frame-filename ann) + (annotated-frame-line ann) + (annotated-frame-arguments ann) + (annotated-frame-locals ann) + (map annotated-frame->vector (annotated-frame-children ann)))) + +(define (apply-frame-filter frame frame-low frame-high) + (and (or (pair? (active-frame-filters (current-progspace))) + (pair? (active-frame-annotators (current-progspace)))) + (stream->gdb-iterator + (apply-frame-filters + (stream-map + apply-frame-annotators + (frame-stream frame frame-low frame-high))) + annotated-frame->vector))) + +(load-extension "gdb" "gdbscm_load_frame_filters") diff --git a/gdb/guile/scm-frame-filter.c b/gdb/guile/scm-frame-filter.c new file mode 100644 index 0000000..0c9687b --- /dev/null +++ b/gdb/guile/scm-frame-filter.c @@ -0,0 +1,1001 @@ +/* Scheme interface to frame filter. + + Copyright (C) 2015 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* See README file in this directory for implementation notes, coding + conventions, et.al. */ + +#include "defs.h" +#include "annotate.h" +#include "block.h" +#include "demangle.h" +#include "frame.h" +#include "inferior.h" +#include "language.h" +#include "objfiles.h" +#include "symfile.h" +#include "symtab.h" +#include "stack.h" +#include "valprint.h" +#include "value.h" +#include "guile-internal.h" + +/* Non-zero if the (gdb frames) module has been loaded. */ +static int gdbscm_frame_filters_loaded = 0; + +/* The captured apply-frame-filter variable. */ +static SCM apply_frame_filter = SCM_BOOL_F; + +/* Called by lib/gdb/frames.scm. */ +static void +gdbscm_load_frame_filters (void *unused) +{ + if (gdbscm_frame_filters_loaded) + return; + + gdbscm_frame_filters_loaded = 1; + + apply_frame_filter = scm_c_lookup ("apply-frame-filter"); +} + +/* Helper to throw type errors as Scheme exceptions. */ +static void +gdbscm_throw_type_error (const char *subr, int arg_pos, SCM val, + const char *expected_type) +{ + gdbscm_throw (gdbscm_make_type_error (subr, arg_pos, val, expected_type)); +} + +/* We surround TRY_CATCH blocks with Scheme dynwinds, so that Scheme + exceptions can interoperate with GDB exceptions. Since GDB's + TRY_CATCH saves and restores cleanups around its body, and + automatically runs inner cleanups on exception, we arrange to do the + same on Scheme exceptions. */ +static void +dynwind_restore_cleanups (void *data) +{ + struct cleanup *cleanups = data; + restore_cleanups (cleanups); +} + +static void +dynwind_do_cleanups (void *data) +{ + struct cleanup *cleanups = data; + do_cleanups (cleanups); +} + +/* Use BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS instead of TRY_CATCH when + you are inside gdbscm_safe_call, and close it with + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND. This will cause + GDB exceptions raised within the block to be re-raised as Scheme + exceptions. Leaving the block in any way -- whether normally, via a + GDB exception, or a Scheme exception -- will cause any cleanups that + were registered within the block to run. + + Given that almost all code in this file is dynamically within one of + these blocks, when should you add a new one? There are only a few + cases: + + 1. You need to call make_cleanup_ui_out_tuple_begin_end or + some other bracketed UI operation. + 2. You are allocating something "big" that should be cleaned up + promptly, like make_cleanup_ui_file_delete. + 3. You want to register a Scheme unwind procedure, and need to + prevent GDB exceptions from passing your dynwind. */ + +#define BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS() \ + do { \ + volatile struct gdb_exception __except; \ + /* Any cleanup pushed within the TRY_CATCH will be run on GDB \ + exception. We will have to run them manually on normal exit or \ + Scheme exception. */ \ + scm_dynwind_begin (0); \ + /* Save the cleanup stack, and arrange to restore it after any exit \ + from the TRY_CATCH, local or non-local. */ \ + scm_dynwind_unwind_handler (dynwind_restore_cleanups, \ + save_cleanups (), \ + SCM_F_WIND_EXPLICITLY); \ + TRY_CATCH (__except, RETURN_MASK_ALL) \ + { \ + struct cleanup *__cleanups = make_cleanup (null_cleanup, NULL); \ + /* Ensure cleanups run on Scheme exception. */ \ + scm_dynwind_unwind_handler (dynwind_do_cleanups, __cleanups, 0);\ + do + +#define RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND() \ + while (0); \ + /* Ensure cleanups run on normal exit. */ \ + do_cleanups (__cleanups); \ + } \ + /* Pop the dynwind and restore the saved cleanup stack. */ \ + scm_dynwind_end (); \ + if (__except.reason < 0) \ + /* Rethrow GDB exception as Scheme exception. */ \ + gdbscm_throw_gdb_exception (__except); \ + } while (0) + + +/* Helper function to extract a symbol, a name, a language definition, + and a value from ITEM, which is an element of a Scheme "arguments" or + "locals" list. + + ITEM will either be a pair of a string and a value, a pair of a + symbol and a value, or just a symbol. NAME is a pass-through + argument where the name of the symbol will be written. NAME is + allocated in this function, and a cleanup handler is registered if + needed. SYM is a pass-through argument where the symbol will be + written. If the name is a string and not a symbol, SYM will be set + to NULL. LANGUAGE is also a pass-through argument denoting the + language attributed to the symbol. In the case of SYM being NULL, + this will be set to the current language. Finally, VALUE will be set + to the unwrapped GDB value, if ITEM is a pair, and otherwise + NULL. */ +static void +extract_sym_and_value (SCM item, const char **name, struct symbol **sym, + const struct language_defn **language, + struct value **value, struct gdbarch *gdbarch) +{ + if (scm_is_pair (item)) + { + SCM symbol_scm = scm_car (item), value_scm = scm_cdr (item); + SCM exception = SCM_BOOL_F; + + if (scm_is_string (symbol_scm)) + { + *name = gdbscm_scm_to_host_string (symbol_scm, NULL, + &exception); + if (!*name) + gdbscm_throw (exception); + make_cleanup (xfree, name); + + *sym = NULL; + *language = current_language; + } + else + { + *sym = syscm_get_valid_symbol_arg_unsafe (symbol_scm, + GDBSCM_ARG_NONE, + "print-frame"); + *name = SYMBOL_PRINT_NAME (*sym); + + if (language_mode == language_mode_auto) + *language = language_def (SYMBOL_LANGUAGE (*sym)); + else + *language = current_language; + } + + *value = vlscm_convert_value_from_scheme ("print-frame", + GDBSCM_ARG_NONE, + value_scm, + &exception, + gdbarch, + *language); + if (!*value) + gdbscm_throw (exception); + } + else + { + *sym = syscm_get_valid_symbol_arg_unsafe (item, GDBSCM_ARG_NONE, + "print-frame"); + *name = SYMBOL_PRINT_NAME (*sym); + + if (language_mode == language_mode_auto) + *language = language_def (SYMBOL_LANGUAGE (*sym)); + else + *language = current_language; + + *value = NULL; + } +} + +enum mi_print_types +{ + MI_PRINT_ARGS, + MI_PRINT_LOCALS +}; + +/* MI prints only certain values according to the type of symbol and + also what the user has specified. SYM is the symbol to check, and + MI_PRINT_TYPES is an enum specifying what the user wants emitted + for the MI command in question. */ +static int +mi_should_print (struct symbol *sym, enum mi_print_types type) +{ + int print_me = 0; + + switch (SYMBOL_CLASS (sym)) + { + default: + case LOC_UNDEF: /* catches errors */ + case LOC_CONST: /* constant */ + case LOC_TYPEDEF: /* local typedef */ + case LOC_LABEL: /* local label */ + case LOC_BLOCK: /* local function */ + case LOC_CONST_BYTES: /* loc. byte seq. */ + case LOC_UNRESOLVED: /* unresolved static */ + case LOC_OPTIMIZED_OUT: /* optimized out */ + print_me = 0; + break; + + case LOC_ARG: /* argument */ + case LOC_REF_ARG: /* reference arg */ + case LOC_REGPARM_ADDR: /* indirect register arg */ + case LOC_LOCAL: /* stack local */ + case LOC_STATIC: /* static */ + case LOC_REGISTER: /* register */ + case LOC_COMPUTED: /* computed location */ + if (type == MI_PRINT_LOCALS) + print_me = ! SYMBOL_IS_ARGUMENT (sym); + else + print_me = SYMBOL_IS_ARGUMENT (sym); + } + return print_me; +} + +/* Helper function which outputs a type name extracted from VAL to a + "type" field in the output stream OUT. OUT is the ui-out structure + the type name will be output too, and VAL is the value that the + type will be extracted from. */ +static void +gdbscm_print_type (struct ui_out *out, struct value *val) +{ + struct type *type; + + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + struct ui_file *stb = mem_fileopen (); + make_cleanup_ui_file_delete (stb); + type = check_typedef (value_type (val)); + type_print (value_type (val), "", stb, -1); + ui_out_field_stream (out, "type", stb); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); +} + +/* Helper function which outputs a value to an output field in a + stream. OUT is the ui-out structure the value will be output to, + VAL is the value that will be printed, OPTS contains the value + printing options, ARGS_TYPE is an enumerator describing the + argument format, and LANGUAGE is the language_defn that the value + will be printed with. */ +static void +gdbscm_print_value (struct ui_out *out, struct value *val, + const struct value_print_options *opts, + int indent, + enum ext_lang_frame_args args_type, + const struct language_defn *language) +{ + int should_print = 0; + int local_indent = (4 * indent); + + /* Never set an indent level for common_val_print if MI. */ + if (ui_out_is_mi_like_p (out)) + local_indent = 0; + + /* MI does not print certain values, differentiated by type, + depending on what ARGS_TYPE indicates. Test type against option. + For CLI print all values. */ + if (args_type == MI_PRINT_SIMPLE_VALUES + || args_type == MI_PRINT_ALL_VALUES) + { + struct type *type = check_typedef (value_type (val)); + + if (args_type == MI_PRINT_ALL_VALUES) + should_print = 1; + else if (args_type == MI_PRINT_SIMPLE_VALUES + && TYPE_CODE (type) != TYPE_CODE_ARRAY + && TYPE_CODE (type) != TYPE_CODE_STRUCT + && TYPE_CODE (type) != TYPE_CODE_UNION) + should_print = 1; + } + else if (args_type != NO_VALUES) + should_print = 1; + + if (should_print) + { + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + struct ui_file *stb = mem_fileopen (); + make_cleanup_ui_file_delete (stb); + common_val_print (val, stb, indent, opts, language); + ui_out_field_stream (out, "value", stb); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); + } +} + +enum print_args_field +{ + WITH_ARGS_FIELD, + WITHOUT_ARGS_FIELD +}; + +/* Helper function to output a single frame argument and value to an + output stream. This function will account for entry values if the FV + parameter is populated, the frame argument has entry values + associated with them, and the appropriate "set entry-value" options + are set. Will output in CLI or MI like format depending on the type + of output stream detected. OUT is the output stream, SYM_NAME is the + name of the symbol. If SYM_NAME is populated then it must have an + accompanying value in the parameter FV. FA is a frame argument + structure. If FA is populated, both SYM_NAME and FV are ignored. + OPTS contains the value printing options, ARGS_TYPE is an enumerator + describing the argument format, PRINT_ARGS_FIELD is a flag which + indicates if we output "ARGS=1" in MI output in commands where both + arguments and locals are printed. */ +static void +gdbscm_print_single_arg (struct ui_out *out, + const char *sym_name, + struct frame_arg *fa, + struct value *fv, + const struct value_print_options *opts, + enum ext_lang_frame_args args_type, + enum print_args_field print_args_field, + const struct language_defn *language) +{ + struct value *val; + + if (fa != NULL) + { + if (fa->val == NULL && fa->error == NULL) + return; + language = language_def (SYMBOL_LANGUAGE (fa->sym)); + val = fa->val; + } + else + val = fv; + + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + /* MI has varying rules for tuples, but generally if there is + only one element in each item in the list, do not start a + tuple. The exception is -stack-list-variables which emits an + ARGS="1" field if the value is a frame argument. This is + denoted in this function with PRINT_ARGS_FIELD which is flag + from the caller to emit the ARGS field. */ + if (ui_out_is_mi_like_p (out)) + { + if (print_args_field == WITH_ARGS_FIELD + || args_type != NO_VALUES) + make_cleanup_ui_out_tuple_begin_end (out, NULL); + } + + annotate_arg_begin (); + + /* If frame argument is populated, check for entry-values and the + entry value options. */ + if (fa != NULL) + { + struct ui_file *stb; + + stb = mem_fileopen (); + make_cleanup_ui_file_delete (stb); + fprintf_symbol_filtered (stb, SYMBOL_PRINT_NAME (fa->sym), + SYMBOL_LANGUAGE (fa->sym), + DMGL_PARAMS | DMGL_ANSI); + if (fa->entry_kind == print_entry_values_compact) + { + fputs_filtered ("=", stb); + + fprintf_symbol_filtered (stb, SYMBOL_PRINT_NAME (fa->sym), + SYMBOL_LANGUAGE (fa->sym), + DMGL_PARAMS | DMGL_ANSI); + } + if (fa->entry_kind == print_entry_values_only + || fa->entry_kind == print_entry_values_compact) + { + fputs_filtered ("@entry", stb); + } + ui_out_field_stream (out, "name", stb); + } + else + /* Otherwise, just output the name. */ + ui_out_field_string (out, "name", sym_name); + + annotate_arg_name_end (); + + if (! ui_out_is_mi_like_p (out)) + ui_out_text (out, "="); + + if (print_args_field == WITH_ARGS_FIELD) + ui_out_field_int (out, "arg", 1); + + /* For MI print the type, but only for simple values. This seems + weird, but this is how MI choose to format the various output + types. */ + if (args_type == MI_PRINT_SIMPLE_VALUES && val != NULL) + gdbscm_print_type (out, val); + + if (val != NULL) + annotate_arg_value (value_type (val)); + + /* If the output is to the CLI, and the user option "set print + frame-arguments" is set to none, just output "...". */ + if (! ui_out_is_mi_like_p (out) && args_type == NO_VALUES) + ui_out_field_string (out, "value", "..."); + else + { + /* Otherwise, print the value for both MI and the CLI, except + for the case of MI_PRINT_NO_VALUES. */ + if (args_type != NO_VALUES) + { + if (val == NULL) + { + gdb_assert (fa != NULL && fa->error != NULL); + ui_out_field_fmt (out, "value", + _(""), + fa->error); + } + else + gdbscm_print_value (out, val, opts, 0, args_type, + language); + } + } + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); +} + +/* Helper function to print one local. LOCAL is the pair or symbol that + is compatible with extract_sym_and_value, OUT is the output stream, + INDENT is whether we should indent the output (for CLI), ARGS_TYPE is + an enumerator describing the argument format, PRINT_ARGS_FIELD is + flag which indicates whether to output the ARGS field in the case of + -stack-list-variables and FRAME is the backing frame. */ +static void +gdbscm_print_local (SCM local, + struct ui_out *out, + int indent, + enum ext_lang_frame_args args_type, + struct frame_info *frame, + enum print_args_field print_args_field, + struct gdbarch *gdbarch) +{ + struct value_print_options opts; + const struct language_defn *language; + const char *sym_name; + struct value *val; + struct symbol *sym; + int local_indent = 8 + (8 * indent); + int out_is_mi = ui_out_is_mi_like_p (out); + + get_user_print_options (&opts); + opts.deref_ref = 1; + + extract_sym_and_value (local, &sym_name, &sym, &language, &val, + gdbarch); + + if (sym && out_is_mi && ! mi_should_print (sym, MI_PRINT_LOCALS)) + return; + + if (!val) + /* If the object did not provide a value, read it. */ + val = read_var_value (sym, frame); + + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + /* With PRINT_NO_VALUES, MI does not emit a tuple normally as each + output contains only one field. The exception is + -stack-list-variables, which always provides a tuple. */ + if (out_is_mi) + { + if (print_args_field == WITH_ARGS_FIELD + || args_type != NO_VALUES) + make_cleanup_ui_out_tuple_begin_end (out, NULL); + } + else + { + /* If the output is not MI we indent locals. */ + ui_out_spaces (out, local_indent); + } + + ui_out_field_string (out, "name", sym_name); + + if (! out_is_mi) + ui_out_text (out, " = "); + + if (args_type == MI_PRINT_SIMPLE_VALUES) + gdbscm_print_type (out, val); + + /* CLI always prints values for locals. MI uses the + simple/no/all system. */ + if (! out_is_mi) + { + int val_indent = (indent + 1) * 4; + + gdbscm_print_value (out, val, &opts, val_indent, args_type, + language); + } + else + { + if (args_type != NO_VALUES) + gdbscm_print_value (out, val, &opts, 0, args_type, language); + } + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); + + ui_out_text (out, "\n"); +} + +/* Helper function for printing locals. This function largely just + creates the wrapping tuple, and calls enumerate_locals. Returns + EXT_LANG_BT_ERROR on error, or EXT_LANG_BT_OK on success. */ +static void +gdbscm_print_locals (SCM locals, + struct ui_out *out, + enum ext_lang_frame_args args_type, + int indent, + struct frame_info *frame, + enum print_args_field print_args_field, + struct gdbarch *gdbarch) +{ + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + make_cleanup_ui_out_list_begin_end (out, "locals"); + + for (; scm_is_pair (locals); locals = scm_cdr (locals)) + { + SCM local = scm_car (locals); + + gdbscm_print_local (local, out, indent, args_type, frame, + print_args_field, gdbarch); + } + + if (!scm_is_null (locals)) + gdbscm_throw_type_error ("print-locals", GDBSCM_ARG_NONE, + locals, "null-terminated locals list"); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); +} + +/* Helper function to print an argument. ARG is a pair or a symbol, in + the format expected by extract_sym_and_value, OUT is the output + stream, ARGS_TYPE is an enumerator describing the argument format, + PRINT_ARGS_FIELD is a flag which indicates if we output "ARGS=1" in + MI output in commands where both arguments and locals are printed, + and FRAME is the backing frame. */ +static void +gdbscm_print_arg (SCM arg, struct ui_out *out, + enum ext_lang_frame_args args_type, + struct frame_info *frame, + enum print_args_field print_args_field, + struct gdbarch *gdbarch) +{ + struct value_print_options opts; + const struct language_defn *language; + const char *sym_name; + struct symbol *sym; + struct value *val; + + get_user_print_options (&opts); + if (args_type == CLI_SCALAR_VALUES) + opts.summary = 1; + opts.deref_ref = 1; + + extract_sym_and_value (arg, &sym_name, &sym, &language, &val, gdbarch); + + if (sym && ui_out_is_mi_like_p (out) + && ! mi_should_print (sym, MI_PRINT_ARGS)) + return; + + annotate_arg_begin (); + + if (val) + { + /* If the annotated frame provides a value, just print that. */ + gdbscm_print_single_arg (out, sym_name, NULL, val, &opts, + args_type, print_args_field, + language); + } + else + { + struct frame_arg arg, entryarg; + + /* Otherwise, the annotated frame did not provide a value, so this + is a frame argument to be read by GDB. In this case we have to + account for entry-values. */ + read_frame_arg (sym, frame, &arg, &entryarg); + make_cleanup (xfree, arg.error); + make_cleanup (xfree, entryarg.error); + + if (arg.entry_kind != print_entry_values_only) + gdbscm_print_single_arg (out, NULL, &arg, NULL, &opts, + args_type, print_args_field, NULL); + + if (entryarg.entry_kind != print_entry_values_no) + { + if (arg.entry_kind != print_entry_values_only) + { + /* Delimit the two arguments that we are printing. */ + ui_out_text (out, ", "); + ui_out_wrap_hint (out, " "); + } + + gdbscm_print_single_arg (out, NULL, &entryarg, NULL, &opts, + args_type, print_args_field, NULL); + } + } + + + annotate_arg_end (); +} + +/* Helper function for printing frame arguments. */ +static void +gdbscm_print_args (SCM args, struct ui_out *out, + enum ext_lang_frame_args args_type, + struct frame_info *frame, + enum print_args_field print_args_field, + struct gdbarch *gdbarch) +{ + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + int arg_index = 0; + + make_cleanup_ui_out_list_begin_end (out, "args"); + + annotate_frame_args (); + if (! ui_out_is_mi_like_p (out)) + ui_out_text (out, " ("); + + for (; scm_is_pair (args); args = scm_cdr (args), arg_index++) + { + SCM arg = scm_car (args); + + if (arg_index > 0) + ui_out_text (out, ", "); + + gdbscm_print_arg (arg, out, args_type, frame, + print_args_field, gdbarch); + } + + if (!scm_is_null (args)) + gdbscm_throw_type_error ("print-args", GDBSCM_ARG_NONE, + args, "null-terminated argument list"); + + if (! ui_out_is_mi_like_p (out)) + ui_out_text (out, ")"); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); +} + +/* Print a single frame to the designated output stream, detecting + whether the output is MI or console, and formatting the output + according to the conventions of that protocol. ANN is the annotated + frame object, as a vector. FLAGS is an integer describing the + various print options. The FLAGS variables is described in + "apply_frame_filter" function. ARGS_TYPE is an enumerator + describing the argument format. OUT is the output stream to print, + INDENT is the level of indention for this frame, in the case of + child frames. */ +static void +gdbscm_print_frame (SCM ann, int flags, enum ext_lang_frame_args args_type, + struct ui_out *out, int indent) +{ + struct gdbarch *gdbarch; + struct frame_info *frame; + struct value_print_options opts; + int print_level, print_frame_info, print_args, print_locals; + SCM frame_scm, function_name_scm, address_scm, filename_scm, line_scm; + SCM arguments_scm, locals_scm, children_scm; + + /* Extract print settings from FLAGS. */ + print_level = (flags & PRINT_LEVEL) ? 1 : 0; + print_frame_info = (flags & PRINT_FRAME_INFO) ? 1 : 0; + print_args = (flags & PRINT_ARGS) ? 1 : 0; + print_locals = (flags & PRINT_LOCALS) ? 1 : 0; + + get_user_print_options (&opts); + + frame_scm = scm_c_vector_ref (ann, 0); + function_name_scm = scm_c_vector_ref (ann, 1); + address_scm = scm_c_vector_ref (ann, 2); + filename_scm = scm_c_vector_ref (ann, 3); + line_scm = scm_c_vector_ref (ann, 4); + arguments_scm = scm_c_vector_ref (ann, 5); + locals_scm = scm_c_vector_ref (ann, 6); + children_scm = scm_c_vector_ref (ann, 7); + + { + frame_smob *smob = + frscm_get_frame_smob_arg_unsafe (frame_scm, 0, "print-frame"); + frame = frscm_frame_smob_to_frame (smob); + } + + /* stack-list-variables. */ + if (print_locals && print_args && ! print_frame_info) + { + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + /* Getting the frame arch needs to happen within a dynwind. */ + gdbarch = get_frame_arch (frame); + + make_cleanup_ui_out_list_begin_end (out, "variables"); + gdbscm_print_args (arguments_scm, out, args_type, frame, + WITH_ARGS_FIELD, gdbarch); + gdbscm_print_locals (locals_scm, out, args_type, indent, frame, + WITH_ARGS_FIELD, gdbarch); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); + /* FIXME: Print variables for child frames? */ + return; + } + + BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS () + { + /* Getting the frame arch needs to happen within a dynwind. */ + gdbarch = get_frame_arch (frame); + + /* -stack-list-locals does not require a wrapping frame + attribute. */ + if (print_frame_info || (print_args && ! print_locals)) + make_cleanup_ui_out_list_begin_end (out, "frame"); + + if (print_frame_info && indent > 0) + { + /* Child frames are also printed with this function + (recursively) and are printed with indention. */ + ui_out_spaces (out, indent * 4); + } + + /* Print frame level. MI does not require the level if + locals/variables only are being printed. */ + if ((print_frame_info || print_args) && print_level) + { + CORE_ADDR address = 0; + int level = frame_relative_level (frame); + + if (gdbscm_is_true (address_scm)) + address = gdbscm_scm_to_ulongest (address_scm); + + annotate_frame_begin (print_level ? level : 0, gdbarch, + address); + ui_out_text (out, "#"); + ui_out_field_fmt_int (out, 2, ui_left, "level", level); + } + + if (print_frame_info) + { + /* Print address to the address field. If an address is not + provided, print nothing. */ + if (opts.addressprint && gdbscm_is_true (address_scm)) + { + CORE_ADDR address = gdbscm_scm_to_ulongest (address_scm); + annotate_frame_address (); + ui_out_field_core_addr (out, "addr", gdbarch, address); + annotate_frame_address_end (); + ui_out_text (out, " in "); + } + + /* Print frame function name. */ + if (gdbscm_is_false (function_name_scm)) + { + annotate_frame_function_name (); + ui_out_field_skip (out, "func"); + } + else if (scm_is_string (function_name_scm)) + { + SCM exception = SCM_BOOL_F; + char *function; + + function = gdbscm_scm_to_host_string (function_name_scm, + NULL, + &exception); + if (!function) + gdbscm_throw (exception); + make_cleanup (xfree, function); + + annotate_frame_function_name (); + ui_out_field_string (out, "func", function); + } + else + { + gdbscm_throw_type_error ("print-frame", GDBSCM_ARG_NONE, + function_name_scm, + "string or false"); + } + } + + /* Frame arguments. Check the result, and error if something went + wrong. */ + if (print_args) + gdbscm_print_args (arguments_scm, out, args_type, frame, + WITHOUT_ARGS_FIELD, gdbarch); + + /* File name/source/line number information. */ + if (print_frame_info) + { + char *filename = NULL; + + annotate_frame_source_begin (); + + if (gdbscm_is_true (filename_scm)) + { + SCM exception = SCM_BOOL_F; + + filename = gdbscm_scm_to_host_string (filename_scm, NULL, + &exception); + + if (!filename) + gdbscm_throw (exception); + + make_cleanup (xfree, filename); + + ui_out_wrap_hint (out, " "); + ui_out_text (out, " at "); + annotate_frame_source_file (); + ui_out_field_string (out, "file", filename); + annotate_frame_source_file_end (); + + if (gdbscm_is_true (line_scm)) + { + int line = scm_to_int (line_scm); + ui_out_text (out, ":"); + annotate_frame_source_line (); + ui_out_field_int (out, "line", line); + } + } + } + + /* For MI we need to deal with child frames, so if MI output + detected do not send newline. */ + if (! ui_out_is_mi_like_p (out)) + { + annotate_frame_end (); + ui_out_text (out, "\n"); + } + + if (print_locals) + gdbscm_print_locals (locals_scm, out, args_type, indent, frame, + WITHOUT_ARGS_FIELD, gdbarch); + + /* Finally recursively print child frames, if any. */ + if (! ui_out_is_mi_like_p (out)) + indent++; + + /* No need for another dynwind; since we're at the end of the + function, the RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND + below will close the "children" list just fine. */ + make_cleanup_ui_out_list_begin_end (out, "children"); + for (; + scm_is_pair (children_scm); + children_scm = scm_cdr (children_scm)) + { + SCM child = scm_car (children_scm); + + gdbscm_print_frame (child, flags, args_type, out, indent); + } + + if (!scm_is_null (children_scm)) + gdbscm_throw_type_error ("print-frame", GDBSCM_ARG_NONE, + children_scm, + "null-terminated child list"); + } + RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND (); +} + +/* Iterate through the frame stream, printing each one. Throws Scheme + exceptions on error. */ +static void +print_annotated_frame_stream (SCM iter, int flags, + enum ext_lang_frame_args args_type, + struct ui_out *out) +{ + while (1) + { + SCM ann = itscm_safe_call_next_x (iter, gdbscm_memory_error_p); + + if (itscm_is_end_of_iteration (ann)) + break; + + /* Since we handle all exceptions via gdbscm_safe_call, really + we'd like an itcm_call_next_x method that propagates the + exception, but lacking that we manually re-throw as needed. */ + if (gdbscm_is_exception (ann)) + gdbscm_throw (ann); + + gdbscm_print_frame (ann, flags, args_type, out, 0); + } +} + +struct print_args { + SCM iter; + int flags; + enum ext_lang_frame_args args_type; + struct ui_out *out; +}; + +/* Returns normally if successful, or otherwise throws an exception. */ +static SCM +do_print_annotated_frame_stream (void *data) +{ + struct print_args *args = data; + + print_annotated_frame_stream (args->iter, args->flags, args->args_type, + args->out); + + return SCM_BOOL_T; +} + +/* This is the only publicly exported function in this file. FRAME is + the source frame to start frame-filter invocation. FLAGS is an + integer holding the flags for printing. The following elements of + the FRAME_FILTER_FLAGS enum denotes the make-up of FLAGS: + PRINT_LEVEL is a flag indicating whether to print the frame's + relative level in the output. PRINT_FRAME_INFO is a flag that + indicates whether this function should print the frame information, + PRINT_ARGS is a flag that indicates whether to print frame + arguments, and PRINT_LOCALS, likewise, with frame local variables. + ARGS_TYPE is an enumerator describing the argument format, OUT is + the output stream to print. FRAME_LOW is the beginning of the slice + of frames to print, and FRAME_HIGH is the upper limit of the frames + to count. Returns EXT_LANG_BT_ERROR on error, or + EXT_LANG_BT_COMPLETED on success. */ + +enum ext_lang_bt_status +gdbscm_apply_frame_filter (const struct extension_language_defn *extlang, + struct frame_info *frame, int flags, + enum ext_lang_frame_args args_type, + struct ui_out *out, int frame_low, + int frame_high) +{ + struct inferior *inferior; + SCM result; + + /* Note that it's possible to have loaded the Guile interface, but not + yet loaded (gdb frames), so checking gdb_scheme_initialized is not + sufficient. */ + if (!gdbscm_frame_filters_loaded) + return EXT_LANG_BT_NO_FILTERS; + + inferior = current_inferior(); + result = gdbscm_safe_call_3 (scm_variable_ref (apply_frame_filter), + frscm_scm_from_frame (frame, inferior), + scm_from_int (frame_low), + scm_from_int (frame_high), + gdbscm_memory_error_p); + + if (gdbscm_is_false (result)) + return EXT_LANG_BT_NO_FILTERS; + + if (itscm_is_iterator (result)) + { + struct print_args args = { result, flags, args_type, out }; + + /* Recurse through gdbscm_call_guile so that we can just throw + exceptions on error. */ + result = gdbscm_call_guile (do_print_annotated_frame_stream, &args, + gdbscm_memory_error_p); + } + + if (gdbscm_is_exception (result)) + { + gdbscm_print_gdb_exception (SCM_BOOL_F, result); + return EXT_LANG_BT_ERROR; + } + + return EXT_LANG_BT_COMPLETED; +} + +/* Register gdbscm_load_frame_filters for calling by (gdb frames). */ +void +gdbscm_initialize_frame_filters (void) +{ + scm_c_register_extension ("gdb", "gdbscm_load_frame_filters", + gdbscm_load_frame_filters, NULL); +} diff --git a/gdb/guile/scm-frame.c b/gdb/guile/scm-frame.c index a30c093..3927714 100644 --- a/gdb/guile/scm-frame.c +++ b/gdb/guile/scm-frame.c @@ -213,7 +213,7 @@ gdbscm_frame_p (SCM scm) /* Create a new object that encapsulates FRAME. Returns a object if there is an error. */ -static SCM +SCM frscm_scm_from_frame (struct frame_info *frame, struct inferior *inferior) { frame_smob *f_smob, f_smob_for_lookup; -- 2.1.4