Ping for this testsuite patch; I've occasionally found it *very*
helpful when debugging DejaGnu.
Dave
On Wed, 2024-07-31 at 20:51 -0400, David Malcolm wrote:
> I wrote this support file to help me debug Tcl issues in the
> testsuite.
>
> Adding a call to:
>
> print_stack_backtrace
>
> somewhere in a .exp file (along with "load_lib print-stack.exp")
> leads
> to the interpreter printing a backtrace in a form that e.g. Emacs can
> consume, with filename:linenum: lines, and quoting the line of .exp
> source code.
>
> Fer example, adding a print_stack_backtrace to scansarif.exp in
> run-sarif-pytest I get this output:
>
> VVV START OF BACKTRACE VVV
> /home/david/coding/gcc-
> newgit/src/gcc/testsuite/lib/scansarif.exp:142: frame 16 in proc
> print_stack_backtrace
> 142 | print_stack_backtrace
> <proc>: frame 15 in proc run-sarif-pytest
> <eval>: frame 14 in proc dg-final-proc
> /usr/share/dejagnu/dg.exp:851: frame 13 in proc dg-final-proc
> 851 | if {[catch "dg-final-proc $prog" errmsg]} {
> <eval>: frame 12 in proc saved-dg-test
> /home/david/coding/gcc-newgit/src/gcc/testsuite/lib/gcc-
> dg.exp:1080: frame 11 in proc saved-dg-test
> 1080 | if { [ catch { eval saved-dg-test $args } errmsg ] }
> {
> /usr/share/dejagnu/dg.exp:559: frame 10 in proc dg-test
> 559 | dg-test $testcase $options ${default-extra-options}
> /home/david/coding/gcc-newgit/src/gcc/testsuite/gcc.dg/sarif-
> output/sarif-output.exp:28: frame 9
> 28 | dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.c]] ""
> ""
> <eval>: frame 8
> <eval>: frame 7
> /usr/share/dejagnu/runtest.exp:1460: frame 6
> 1460 | if { [catch "uplevel #0 source $test_file_name"] ==
> 1 } {
> /usr/share/dejagnu/runtest.exp:1886: frame 5 in proc dg-runtest
> 1886 | runtest $test_name
> /usr/share/dejagnu/runtest.exp:1845: frame 4 in proc dg-runtest
> 1845 | foreach test_name [lsort [find ${dir}
> *.exp]] {
> /usr/share/dejagnu/runtest.exp:1788: frame 3 in proc dg-runtest
> 1788 | foreach dir "${test_top_dirs}" {
> /usr/share/dejagnu/runtest.exp:1669: frame 2 in proc dg-runtest
> 1669 | foreach pass $multipass {
> /usr/share/dejagnu/runtest.exp:1619: frame 1 in proc dg-runtest
> 1619 | foreach current_target $target_list {
> ^^^ END OF BACKTRACE ^^^
>
> and can click on the lines in Emacs's compilation buffer to take
> me to the relevant places.
>
> I found this made it *much* easier to debug my .exp files. That
> said, I'm uncomfortable with Tcl, and so
> (a) there may be a better way of doing this
> (b) I may have made mistakes
>
> OK for trunk?
>
> gcc/testsuite/ChangeLog:
> * lib/print-stack.exp: New file.
>
> Signed-off-by: David Malcolm <dmalc...@redhat.com>
> ---
> gcc/testsuite/lib/print-stack.exp | 59
> +++++++++++++++++++++++++++++++
> 1 file changed, 59 insertions(+)
> create mode 100644 gcc/testsuite/lib/print-stack.exp
>
> diff --git a/gcc/testsuite/lib/print-stack.exp
> b/gcc/testsuite/lib/print-stack.exp
> new file mode 100644
> index 00000000000..5688d0a63de
> --- /dev/null
> +++ b/gcc/testsuite/lib/print-stack.exp
> @@ -0,0 +1,59 @@
> +# Copyright (C) 2024 Free Software Foundation, Inc.
> +# Contributed by David Malcolm <dmalc...@redhat.com>.
> +
> +# 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 GCC; see the file COPYING3. If not see
> +# <http://www.gnu.org/licenses/>.
> +
> +# Get the 1-based line for LINENUM from FILENAME as a string
> +
> +proc get_line { filename linenum } {
> + set f [open $filename]
> + set lines [split [read $f] \n]
> + close $f
> + return [lindex $lines [expr $linenum - 1] ]
> +}
> +
> +# Print a backtrace of the Tcl interpreter's stack, showing
> +# frames, levels, source file and line where available.
> +
> +proc print_stack_backtrace {} {
> + set current_frame_level [info frame]
> + puts "VVV START OF BACKTRACE VVV"
> + for {set i [expr $current_frame_level - 1]} {$i > 0} {incr i -1}
> {
> + set frame [info frame $i]
> + if { [dict exists $frame "level"] } {
> + set level_num [dict get $frame "level"]
> + set relative_level_offset [expr 1 - $level_num]
> + set level [info level $relative_level_offset]
> + set procname [lindex $level 0]
> + # TODO: args = rest of $level, but this can be very long
> + } else {
> + set procname ""
> + }
> + set suffix ""
> + if { $procname != "" } {
> + set suffix " in proc $procname"
> + }
> + if { [dict get $frame "type"] == "source" } {
> + set fname [dict get $frame "file"]
> + set line [dict get $frame "line"]
> + puts " $fname:$line: frame $i$suffix"
> + puts " $line | [get_line $fname $line]"
> + } else {
> + set type [dict get $frame "type"]
> + puts " <$type>: frame $i$suffix"
> + }
> + }
> + puts "^^^ END OF BACKTRACE ^^^"
> +}
