[PATCH 1/8] [gdb/testsuite] Factor out proc finally

[PATCH 1/8] [gdb/testsuite] Factor out proc finally

[Tom de Vries]

There's a common pattern in the tcl procs to run cleanup code, emulating
the 'finally' functionality:
...
    set code [catch {
      # Try.
      ...
    } result]

    # Finally.
    ...

    # Return as appropriate.
    if { $code == 1 } {
        global errorInfo errorCode
        return -code error -errorinfo $errorInfo -errorcode $errorCode $result

    } elseif { $code > 1 } {
        return -code $code $result
    }

    <use> $result
...

Factor this out into a new proc 'finally', such that we can simply write:
...
    finally {
        # Try.
        ...
    } {
        # Finally.
    	...
    }
...

Note: to factor this out into a proc, we have to bump the
implicit "-level 1" here to:
...
    } elseif { $code > 1 } {
        return -code $code -level 2 $result
    }
...

Note: a normal 'finally' implementation would for this example:
...
proc bar {} {
    puts "bar: entry"
    finally {
        puts "bar: body"
        return
    } {
        puts "bar: finally"
    }
    puts "bar: exit"
}

proc foo {} {
    puts "foo: entry"
    bar
    puts "foo: exit"
}

puts"toplevel: entry"
foo
puts "toplevel: exit"
...
have this output:
...
toplevel: entry
foo: entry
bar: entry
bar: body
bar: finally
foo: exit
toplevel: exit
...

But our implementation also skips "foo: exit".  That seems to be something
some test-cases rely upon, which should probably be fixed.

Tested on x86_64-linux.
---
 gdb/testsuite/lib/gdb.exp | 268 ++++++++++++++++----------------------
 1 file changed, 114 insertions(+), 154 deletions(-)

diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 7f02504262d..e5d247de36f 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -51,6 +51,27 @@ proc gdb_persistent_global_no_decl { args } {
     }
 }
 
+# Execute BODY, then FINALLY, even if an exception is thrown in BODY.
+
+proc finally { body finally } {
+    # Execute body.
+    set code [catch {uplevel 1 $body} result]
+
+    uplevel 1 $finally
+
+    # Return as appropriate.
+    if { $code == 1 } {
+        global errorInfo errorCode
+        return -code error -errorinfo $errorInfo -errorcode $errorCode $result
+    } elseif { $code > 1 } {
+	# FIXME: Should have "-level 1" here, to emulate actual
+	# finally behaviour.
+        return -code $code -level 2 $result
+    }
+
+    return $result
+}
+
 # Override proc load_lib.
 rename load_lib saved_load_lib
 # Run the runtest version of load_lib, and mark all variables that were
@@ -61,22 +82,15 @@ proc load_lib { file } {
        set known_globals($varname) 1
     }
 
-    set code [catch "saved_load_lib $file" result]
-
-    foreach varname [info globals] {
-       if { ![info exists known_globals($varname)] } {
-           gdb_persistent_global_no_decl $varname
-       }
-    }
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code error -errorinfo $errorInfo -errorcode $errorCode $result
-    } elseif {$code > 1} {
-	return -code $code $result
+    finally {
+	saved_load_lib $file
+    } {
+	foreach varname [info globals] {
+	    if { ![info exists known_globals($varname)] } {
+		gdb_persistent_global_no_decl $varname
+	    }
+	}
     }
-
-    return $result
 }
 
 load_lib libgloss.exp
@@ -1224,25 +1238,20 @@ proc gdb_test_multiple { command message args } {
     }
     set gdb_test_name "$message"
 
-    set result 0
-    set code [catch {gdb_expect $code} string]
-
-    # Clean up the gdb_test_name variable.  If we had a
-    # previous value then restore it, otherwise, delete the variable
-    # from the parent scope.
-    if { [info exists gdb_test_name_old] } {
-	set gdb_test_name "$gdb_test_name_old"
-    } else {
-	unset gdb_test_name
+    finally {
+	gdb_expect $code
+    } {
+	# Clean up the gdb_test_name variable.  If we had a
+	# previous value then restore it, otherwise, delete the variable
+	# from the parent scope.
+	if { [info exists gdb_test_name_old] } {
+	    set gdb_test_name "$gdb_test_name_old"
+	} else {
+	    unset gdb_test_name
+	}
     }
 
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code error -errorinfo $errorInfo -errorcode $errorCode $string
-    } elseif {$code > 1} {
-	return -code $code $string
-    }
-    return $result
+    return 0
 }
 
 # Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ...
@@ -2452,14 +2461,10 @@ proc with_test_prefix { prefix body } {
 
   set saved $pf_prefix
   append pf_prefix " " $prefix ":"
-  set code [catch {uplevel 1 $body} result]
-  set pf_prefix $saved
-
-  if {$code == 1} {
-      global errorInfo errorCode
-      return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-  } else {
-      return -code $code $result
+  finally {
+      uplevel 1 $body
+  } {
+      set pf_prefix $saved
   }
 }
 
@@ -2535,26 +2540,21 @@ proc save_vars { vars body } {
 	}
     }
 
-    set code [catch {uplevel 1 $body} result]
-
-    foreach {var value} [array get saved_scalars] {
-	uplevel 1 [list set $var $value]
-    }
-
-    foreach {var value} [array get saved_arrays] {
-	uplevel 1 [list unset $var]
-	uplevel 1 [list array set $var $value]
-    }
+    finally {
+	uplevel 1 $body
+    } {
+	foreach {var value} [array get saved_scalars] {
+	    uplevel 1 [list set $var $value]
+	}
 
-    foreach var $unset_vars {
-	uplevel 1 [list unset -nocomplain $var]
-    }
+	foreach {var value} [array get saved_arrays] {
+	    uplevel 1 [list unset $var]
+	    uplevel 1 [list array set $var $value]
+	}
 
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+	foreach var $unset_vars {
+	    uplevel 1 [list unset -nocomplain $var]
+	}
     }
 }
 
@@ -2586,22 +2586,18 @@ proc save_target_board_info { vars body } {
 	}
     }
 
-    set code [catch {uplevel 1 $body} result]
+    finally {
+	uplevel 1 $body
+    } {
 
-    foreach {var value} [array get saved_target_board_info] {
-	unset_board_info $var
-	set_board_info $var $value
-    }
-
-    foreach var $unset_target_board_info {
-	unset_board_info $var
-    }
+	foreach {var value} [array get saved_target_board_info] {
+	    unset_board_info $var
+	    set_board_info $var $value
+	}
 
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+	foreach var $unset_target_board_info {
+	    unset_board_info $var
+	}
     }
 }
 
@@ -2617,16 +2613,11 @@ proc with_cwd { dir body } {
     verbose -log "Switching to directory $dir (saved CWD: $saved_dir)."
     cd $dir
 
-    set code [catch {uplevel 1 $body} result]
-
-    verbose -log "Switching back to $saved_dir."
-    cd $saved_dir
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	verbose -log "Switching back to $saved_dir."
+	cd $saved_dir
     }
 }
 
@@ -2667,17 +2658,12 @@ proc with_gdb_prompt { prompt body } {
     set gdb_prompt $prompt
     gdb_test_no_output "set prompt $prompt " ""
 
-    set code [catch {uplevel 1 $body} result]
-
-    verbose -log "Restoring gdb prompt to \"$saved \"."
-    set gdb_prompt $saved
-    gdb_test_no_output "set prompt $saved " ""
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	verbose -log "Restoring gdb prompt to \"$saved \"."
+	set gdb_prompt $saved
+	gdb_test_no_output "set prompt $saved " ""
     }
 }
 
@@ -2702,15 +2688,10 @@ proc with_target_charset { target_charset body } {
 
     gdb_test_no_output "set target-charset $target_charset" ""
 
-    set code [catch {uplevel 1 $body} result]
-
-    gdb_test_no_output "set target-charset $saved" ""
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	gdb_test_no_output "set target-charset $saved" ""
     }
 }
 
@@ -2748,19 +2729,14 @@ proc with_spawn_id { spawn_id body } {
 
     switch_gdb_spawn_id $spawn_id
 
-    set code [catch {uplevel 1 $body} result]
-
-    if [info exists saved_spawn_id] {
-	switch_gdb_spawn_id $saved_spawn_id
-    } else {
-	clear_gdb_spawn_id
-    }
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	if [info exists saved_spawn_id] {
+	    switch_gdb_spawn_id $saved_spawn_id
+	} else {
+	    clear_gdb_spawn_id
+	}
     }
 }
 
@@ -2801,14 +2777,10 @@ proc with_timeout_factor { factor body } {
     set savedtimeout $timeout
 
     set timeout [expr [get_largest_timeout] * $factor]
-    set code [catch {uplevel 1 $body} result]
-
-    set timeout $savedtimeout
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	set timeout $savedtimeout
     }
 }
 
@@ -5376,18 +5348,13 @@ proc with_complaints { n body } {
 	gdb_test_no_output "set complaints $n" ""
     }
 
-    set code [catch {uplevel 1 $body} result]
-
-    # Restore saved setting of complaints.
-    if { $save != "" } {
-	gdb_test_no_output "set complaints $save" ""
-    }
-
-    if {$code == 1} {
-	global errorInfo errorCode
-	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
-    } else {
-	return -code $code $result
+    finally {
+	uplevel 1 $body
+    } {
+	# Restore saved setting of complaints.
+	if { $save != "" } {
+	    gdb_test_no_output "set complaints $save" ""
+	}
     }
 }
 
@@ -8035,30 +8002,23 @@ proc with_override { name override body } {
 	set existed false
     }
 
-    # Install the override.
     set new_args [info args $override]
     set new_body [info body $override]
-    eval proc $name {$new_args} {$new_body}
 
     # Execute body.
-    set code [catch {uplevel 1 $body} result]
-
-    # Restore old proc if it existed on entry, else delete it.
-    if { $existed } {
-	eval proc $name {$old_args} {$old_body}
-    } else {
-	rename $name ""
-    }
-
-    # Return as appropriate.
-    if { $code == 1 } {
-        global errorInfo errorCode
-        return -code error -errorinfo $errorInfo -errorcode $errorCode $result
-    } elseif { $code > 1 } {
-        return -code $code $result
+    finally {
+	# Install the override.
+	eval proc $name {$new_args} {$new_body}
+
+	uplevel 1 $body
+    } {
+	# Restore old proc if it existed on entry, else delete it.
+	if { $existed } {
+	    eval proc $name {$old_args} {$old_body}
+	} else {
+	    rename $name ""
+	}
     }
-
-    return $result
 }
 
 # Setup tuiterm.exp environment.  To be used in test-cases instead of

base-commit: 1ed0032b40063795d6c3ce89eab3101a8fd67569
-- 
2.26.2

[PATCH 2/8] [gdb/testsuite] Speed up MACRO_AT_* calls

[Tom de Vries]

Currently, for each MACRO_AT_range or MACRO_AT_func in dwarf assembly the
following is done:
- $srcdir/$subdir/$srcfile is compiled to an executable using
  flags "debug"
- a new gdb instance is started
- the new executable is loaded.

This is inefficient, because the executable is identical within the same
Dwarf::assemble call.

Share the gdb instance in the same Dwarf::assemble invocation, which speeds
up a make check with RUNTESTFLAGS like this to catch all dwarf assembly
test-cases:
...
rtf=$(echo $(cd src/gdb/testsuite; find gdb.* -type f -name "*.exp" \
      | xargs grep -l Dwarf::assemble))
...
from:
...
real    1m39.916s
user    1m25.668s
sys     0m21.377s
...
to:
...
real    1m29.512s
user    1m17.316s
sys     0m19.100s
...

Tested on x86_64-linux.
---
 gdb/testsuite/lib/dwarf.exp | 154 +++++++++++++++++++++++++++++++++---
 1 file changed, 142 insertions(+), 12 deletions(-)

diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index b48cfad3b9e..499dc257805 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -196,6 +196,139 @@ proc build_executable_and_dwo_files { testname executable options args } {
     return 0
 }
 
+# Utility function for procs shared_gdb_*.
+
+proc init_shared_gdb {} {
+    global shared_gdb_enabled
+    global shared_gdb_started
+
+    if { ! [info exists shared_gdb_enabled] } {
+	set shared_gdb_enabled 0
+	set shared_gdb_started 0
+    }
+}
+
+# Cluster of four procs:
+# - shared_gdb_enable
+# - shared_gdb_disable
+# - shared_gdb_start_use SRC OPTIONS
+# - shared_gdb_end_use
+#
+# Can be used like so:
+#
+#   {
+#     if { $share } shared_gdb_enable
+#     ...
+#     shared_gdb_start_use $src $options
+#     ...
+#     shared_gdb_end_use
+#     ...
+#     shared_gdb_start_use $src $options
+#     ...
+#     shared_gdb_end_use
+#     ...
+#     if { $share } shared_gdb_disable
+#   }
+#
+# to write functionalty that could share ($share == 1) or could not
+# share ($share == 0) a gdb session between two uses.
+
+proc shared_gdb_enable {} {
+    set me shared_gdb_enable
+
+    init_shared_gdb
+    global shared_gdb_enabled
+    global shared_gdb_started
+
+    if { $shared_gdb_enabled } {
+	error "$me: gdb sharing already enabled"
+    }
+    set shared_gdb_enabled 1
+
+    if { $shared_gdb_started } {
+	error "$me: gdb sharing not stopped"
+    }
+}
+
+# See above.
+
+proc shared_gdb_disable {} {
+    init_shared_gdb
+    global shared_gdb_enabled
+    global shared_gdb_started
+
+    if { ! $shared_gdb_enabled } {
+	error "$me: gdb sharing not enabled"
+    }
+    set shared_gdb_enabled 0
+
+    if { $shared_gdb_started } {
+	gdb_exit
+	set shared_gdb_started 0
+    }
+}
+
+# See above.
+
+proc shared_gdb_start_use { src options } {
+    set me shared_gdb_start_use
+
+    init_shared_gdb
+    global shared_gdb_enabled
+    global shared_gdb_started
+    global shared_gdb_src
+    global shared_gdb_options
+
+    set do_start 1
+    if { $shared_gdb_enabled && $shared_gdb_started } {
+	if { $shared_gdb_src != $src
+	     || $shared_gdb_options != $options } {
+	    error "$me: gdb sharing inconsistent"
+	}
+
+	set do_start 0
+    }
+
+    if { $do_start } {
+	set exe [standard_temp_file func_addr[pid].x]
+
+	gdb_compile $src $exe executable $options
+
+	gdb_exit
+	gdb_start
+	gdb_load "$exe"
+
+	if { $shared_gdb_enabled } {
+	    set shared_gdb_started 1
+	    set shared_gdb_src $src
+	    set shared_gdb_options $options
+	}
+    }
+}
+
+# See above.
+
+proc shared_gdb_end_use {} {
+    init_shared_gdb
+    global shared_gdb_enabled
+
+    if { ! $shared_gdb_enabled } {
+	gdb_exit
+    }
+}
+
+# Enable gdb session sharing within BODY.
+
+proc with_shared_gdb { body } {
+    finally {
+	shared_gdb_enable
+
+	uplevel 1 $body
+    } {
+	shared_gdb_disable
+    }
+}
+
 # Return a list of expressions about function FUNC's address and length.
 # The first expression is the address of function FUNC, and the second
 # one is FUNC's length.  SRC is the source file having function FUNC.
@@ -227,13 +360,7 @@ proc build_executable_and_dwo_files { testname executable options args } {
 proc function_range { func src {options {debug}} } {
     global decimal gdb_prompt
 
-    set exe [standard_temp_file func_addr[pid].x]
-
-    gdb_compile $src $exe executable $options
-
-    gdb_exit
-    gdb_start
-    gdb_load "$exe"
+    shared_gdb_start_use $src $options
 
     # Compute the label offset, and we can get the function start address
     # by "${func}_label - $func_label_offset".
@@ -271,7 +398,8 @@ proc function_range { func src {options {debug}} } {
 	}
     }
 
-    gdb_exit
+    shared_gdb_end_use
+
     return [list "${func}_label - $func_label_offset" $func_length]
 }
 
@@ -2588,10 +2716,12 @@ namespace eval Dwarf {
 	# the first in .debug_info.
 	dummy_cu
 
-	# Not "uplevel" here, because we want to evaluate in this
-	# namespace.  This is somewhat bad because it means we can't
-	# readily refer to outer variables.
-	eval $body
+	with_shared_gdb {
+	    # Not "uplevel" here, because we want to evaluate in this
+	    # namespace.  This is somewhat bad because it means we can't
+	    # readily refer to outer variables.
+	    eval $body
+	}
 
 	# Dummy CU at the end to ensure that the last CU in $body is not
 	# the last in .debug_info.
-- 
2.26.2

[PATCH 3/8] [gdb/testsuite] Add test-case gdb.dwarf2/dw2-lines.exp

[Tom de Vries]

Add a new test-case gdb.dwarf2/dw2-lines.exp that tests various.debug_line
sections.

Tested on x86_64-linux.
---
 gdb/testsuite/gdb.dwarf2/dw2-lines.c   |  45 +++++++
 gdb/testsuite/gdb.dwarf2/dw2-lines.exp | 156 +++++++++++++++++++++++++
 gdb/testsuite/lib/dwarf.exp            |   6 +
 3 files changed, 207 insertions(+)
 create mode 100644 gdb/testsuite/gdb.dwarf2/dw2-lines.c
 create mode 100644 gdb/testsuite/gdb.dwarf2/dw2-lines.exp

diff --git a/gdb/testsuite/gdb.dwarf2/dw2-lines.c b/gdb/testsuite/gdb.dwarf2/dw2-lines.c
new file mode 100644
index 00000000000..5bfa5975724
--- /dev/null
+++ b/gdb/testsuite/gdb.dwarf2/dw2-lines.c
@@ -0,0 +1,45 @@
+/*
+   Copyright 2021 Free Software Foundation, Inc.
+
+   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 <http://www.gnu.org/licenses/>.  */
+
+void
+foo (int x)
+{
+
+}
+
+void
+bar (void)
+{
+  asm ("bar_label: .globl bar_label");
+  foo (1);
+  asm ("bar_label_2: .globl bar_label_2");
+  foo (2);
+  asm ("bar_label_3: .globl bar_label_3");
+  foo (3);
+  asm ("bar_label_4: .globl bar_label_4");
+  foo (4);
+  asm ("bar_label_5: .globl bar_label_5");
+}
+
+int
+main (void)
+{
+  asm ("main_label: .globl main_label");
+
+  bar ();
+
+  return 0;
+}
diff --git a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
new file mode 100644
index 00000000000..cde602fd468
--- /dev/null
+++ b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
@@ -0,0 +1,156 @@
+# Copyright 2021 Free Software Foundation, Inc.
+
+# 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 <http://www.gnu.org/licenses/>.
+
+# Test line number information in various configurations.
+
+load_lib dwarf.exp
+
+# This test can only be run on targets which support DWARF-2 and use gas.
+require dwarf2_support 1
+
+standard_testfile .c -dw.S
+
+with_shared_gdb {
+    set func_info_vars \
+	[concat \
+	     [get_func_info main] \
+	     [get_func_info bar]]
+}
+
+# Helper function.
+proc line_for { l } {
+    global srcfile
+    set line [gdb_get_line_number "$l:" $srcfile]
+    return [expr $line + 1]
+}
+
+# Execute test.
+proc test_1 { _cv _cdw64 _lv _ldw64 } {
+    global srcfile srcfile2 testfile
+    global cv cdw64 lv ldw64
+    set cv $_cv
+    set cdw64 $_cdw64
+    set lv $_lv
+    set ldw64 $_ldw64
+
+    set asm_file [standard_output_file $srcfile2]
+    Dwarf::assemble $asm_file {
+	declare_labels Llines
+	global srcdir subdir srcfile cv cdw64 lv ldw64
+	global func_info_vars
+	foreach var $func_info_vars {
+	    global $var
+	}
+
+	cu { version $cv is_64 $cdw64 } {
+	    compile_unit {
+		{language @DW_LANG_C}
+		{name $srcfile}
+		{stmt_list $Llines DW_FORM_sec_offset}
+	    } {
+		subprogram {
+		    {external 1 flag}
+		    {name main}
+		    {low_pc $main_start addr}
+		    {high_pc "$main_start + $main_len" addr}
+		}
+		subprogram {
+		    {external 1 flag}
+		    {name bar}
+		    {low_pc $bar_start addr}
+		    {high_pc "$bar_start + $bar_len" addr}
+		}
+	    }
+	}
+
+	lines [list version $lv is_64 $ldw64] Llines {
+	    include_dir "${srcdir}/${subdir}"
+	    file_name "$srcfile" 1
+
+	    program {
+		{DW_LNE_set_address bar_label}
+		{line [line_for bar_label]}
+		{DW_LNS_copy}
+
+		{DW_LNE_set_address bar_label_2}
+		{line [line_for bar_label_2]}
+		{DW_LNS_copy}
+
+		{DW_LNE_set_address bar_label_3}
+		{line [line_for bar_label_3]}
+		{DW_LNS_copy}
+
+		{DW_LNE_set_address bar_label_4}
+		{line [line_for bar_label_4]}
+		{DW_LNS_copy}
+
+		{DW_LNE_set_address bar_label_5}
+		{DW_LNE_end_sequence}
+	    }
+	}
+    }
+
+    if { [prepare_for_testing "failed to prepare" ${testfile} \
+	      [list $srcfile $asm_file] {nodebug}] } {
+	return -1
+    }
+
+    if ![runto_main] {
+	return -1
+    }
+
+    gdb_breakpoint "bar"
+    gdb_continue_to_breakpoint "foo \\(1\\)"
+
+    gdb_test "next" "foo \\(2\\).*" "next to foo (2)"
+    gdb_test "next" "foo \\(3\\).*" "next to foo (3)"
+    gdb_test "next" "foo \\(4\\).*" "next to foo (4)"
+}
+
+
+# Add unique test prefix.
+proc test { cv cdw64 lv ldw64 } {
+    with_test_prefix cv=$cv {
+	with_test_prefix cdw=[expr $cdw64 ? 64 : 32] {
+	    with_test_prefix lv=$lv {
+		with_test_prefix ldw=[expr $ldw64 ? 64 : 32] {
+		    test_1 $cv $cdw64 $lv $ldw64
+		}
+	    }
+	}
+    }
+}
+
+set cv_low 2
+set cv_high 4
+
+set lv_low 2
+set lv_high 3
+
+for { set cv $cv_low } { $cv <= $cv_high } { incr cv } {
+    for { set lv $lv_low } { $lv <= $lv_high } { incr lv } {
+	# I'm not sure if it makes sense to have a dwarf vx CU with
+	# a dwarf vx+1 line unit.
+	if { $lv > $lv } {
+	    continue
+	}
+
+	foreach cdw64 { 0 1 } {
+	    foreach ldw64 { 0 1 } {
+		test $cv $cdw64 $lv $ldw64
+	    }
+	}
+    }
+}
diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 499dc257805..3dcaf06c2ef 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -405,6 +405,7 @@ proc function_range { func src {options {debug}} } {
 
 # Extract the start, length, and end for function called NAME and
 # create suitable variables in the callers scope.
+# Return the list of created variables.
 proc get_func_info { name {options {debug}} } {
     global srcdir subdir srcfile
 
@@ -417,6 +418,11 @@ proc get_func_info { name {options {debug}} } {
 		 ${options}]  \
 	func_start func_len
     set func_end "$func_start + $func_len"
+
+    return [list \
+		"${name}_start" \
+		"${name}_len" \
+		"${name}_end"]
 }
 
 # A DWARF assembler.
-- 
2.26.2

[PATCH 4/8] [gdb/testsuite] Support .debug_line v4 in dwarf assembler

[Tom de Vries]

The .debug_line header got a new field in v4:
maximum_operations_per_instruction.

Generate this field in the dwarf assembler, for now hardcoding the value to 1,
meaning non-VLIW.

Tested on x86_64-linux.
---
 gdb/testsuite/gdb.dwarf2/dw2-lines.exp | 2 +-
 gdb/testsuite/lib/dwarf.exp            | 4 ++++
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
index cde602fd468..5a5888a467e 100644
--- a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
+++ b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
@@ -137,7 +137,7 @@ set cv_low 2
 set cv_high 4
 
 set lv_low 2
-set lv_high 3
+set lv_high 4
 
 for { set cv $cv_low } { $cv <= $cv_high } { incr cv } {
     for { set lv $lv_low } { $lv <= $lv_high } { incr lv } {
diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 3dcaf06c2ef..0509b781500 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -2197,6 +2197,10 @@ namespace eval Dwarf {
 	define_label $header_len_label
 
 	_op .byte 1 "minimum_instruction_length"
+	if { $_unit_version >= 4 } {
+	    # Assume non-VLIW for now.
+	    _op .byte 1 "maximum_operations_per_instruction"
+	}
 	_op .byte $_default_is_stmt "default_is_stmt"
 	_op .byte 1 "line_base"
 	_op .byte 1 "line_range"
-- 
2.26.2

[PATCH 5/8] [gdb/testsuite] Factor out_line_finalize_header

[Tom de Vries]

Rather than generate dwarf immediately in procs include_dir and file_name,
postpone generation and store the data in variables.  Then handle the
generation in a new proc _line_finalize_header.

Tested on x86-64-linux.
---
 gdb/testsuite/lib/dwarf.exp | 75 ++++++++++++++++++++++++-------------
 1 file changed, 49 insertions(+), 26 deletions(-)

diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 0509b781500..777bfb77c45 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -2134,6 +2134,9 @@ namespace eval Dwarf {
     proc lines {options label body} {
 	variable _line_count
 	variable _line_saw_file
+	variable _line_include_dirs
+	variable _line_file_names
+	variable _line_header_finalized
 	variable _line_saw_program
 	variable _line_header_end_label
 
@@ -2143,6 +2146,9 @@ namespace eval Dwarf {
 	set _unit_addr_size default
 	set _line_saw_program 0
 	set _line_saw_file 0
+	set _line_include_dirs {}
+	set _line_file_names {}
+	set _line_header_finalized 0
 	set _default_is_stmt 1
 
 	foreach { name value } $options {
@@ -2223,21 +2229,50 @@ namespace eval Dwarf {
 	_op .byte 1 "standard opcode 9"
 
 	proc include_dir {dirname} {
-	    _op .ascii [_quote $dirname]
+	    variable _line_include_dirs
+	    lappend _line_include_dirs $dirname
 	}
 
 	proc file_name {filename diridx} {
-	    variable _line_saw_file
-	    if "! $_line_saw_file" {
-		# Terminate the dir list.
-		_op .byte 0 "Terminator."
-		set _line_saw_file 1
+	    variable _line_file_names
+	    lappend _line_file_names $filename $diridx
+
+	    variable _line_saw_file 1
+	    set _line_saw_file 1
+	}
+
+	proc _line_finalize_header {} {
+	    variable _line_header_finalized
+	    if { $_line_header_finalized } {
+		return
 	    }
+	    set _line_header_finalized 1
 
-	    _op .ascii [_quote $filename]
-	    _op .sleb128 $diridx
-	    _op .sleb128 0 "mtime"
-	    _op .sleb128 0 "length"
+	    variable _line_include_dirs
+	    variable _line_file_names
+
+	    if { 1 } {
+		foreach dirname $_line_include_dirs {
+		    _op .ascii [_quote $dirname]
+		}
+
+		_op .byte 0 "Terminator (include_directories)"
+
+		foreach { filename diridx } $_line_file_names {
+		    _op .ascii [_quote $filename]
+		    _op .sleb128 $diridx
+		    _op .sleb128 0 "mtime"
+		    _op .sleb128 0 "length"
+		}
+
+		_op .byte 0 "Terminator (file_names)"
+	    }
+
+	    set _line_include_dirs {}
+	    set _line_file_names {}
+
+	    variable _line_header_end_label
+	    define_label $_line_header_end_label
 	}
 
 	proc program {statements} {
@@ -2245,14 +2280,11 @@ namespace eval Dwarf {
 	    variable _line_header_end_label
 	    variable _line
 
+	    set _line_saw_program 1
+
 	    set _line 1
 
-	    if "! $_line_saw_program" {
-		# Terminate the file list.
-		_op .byte 0 "Terminator."
-		define_label $_line_header_end_label
-		set _line_saw_program 1
-	    }
+	    _line_finalize_header
 
 	    proc DW_LNE_set_address {addr} {
 		_op .byte 0
@@ -2343,16 +2375,7 @@ namespace eval Dwarf {
 	rename include_dir ""
 	rename file_name ""
 
-	# Terminate dir list if we saw no files.
-	if "! $_line_saw_file" {
-	    _op .byte 0 "Terminator."
-	}
-
-	# Terminate the file list.
-	if "! $_line_saw_program" {
-	    _op .byte 0 "Terminator."
-	    define_label $_line_header_end_label
-	}
+	_line_finalize_header
 
 	define_label $unit_end_label
     }
-- 
2.26.2

[PATCH 6/8] [gdb/testsuite] Support .debug_line v5 in dwarf assembler

[Tom de Vries]

The v5 section version for .debug_line has:
- two new fields address_size and segment_selector_size
- a different way to encode the directory and filename tables.

Add support for this in the dwarf assembler.

For now, make the v5 directory and filename tables work with the v4 type of
specification in the test-cases by adding duplicate entries at position 0.

This will need to be properly fixed with an intrusive fix that changes how
directory and filename entries are specified in the test-cases, f.i:
...
set diridx [include_dir "${srcdir}/${subdir}"]
set fileidx [file_name "$srcfile" $diridx]
...

Tested on x86_64-linux.
---
 gdb/testsuite/gdb.dwarf2/dw2-lines.exp |  6 +++
 gdb/testsuite/lib/dwarf.exp            | 69 ++++++++++++++++++++++++--
 2 files changed, 70 insertions(+), 5 deletions(-)

diff --git a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
index 5a5888a467e..27134af8f5d 100644
--- a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
+++ b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
@@ -154,3 +154,9 @@ for { set cv $cv_low } { $cv <= $cv_high } { incr cv } {
 	}
     }
 }
+
+foreach cdw64 { 0 1 } {
+    foreach ldw64 { 0 1 } {
+	test 5 $cdw64 5 $ldw64
+    }
+}
diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 777bfb77c45..76ba65df9fd 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -2116,6 +2116,9 @@ namespace eval Dwarf {
     #                default = 4
     # addr_size n  - the size of addresses in bytes: 4, 8, or default
     #                default = default
+    # seg_sel_size n
+    #              - the size of segment selector_size in bytes:
+    #                default = 0
     #
     # LABEL is the label of the current unit (which is probably
     # referenced by a DW_AT_stmt_list), or "" if there is no such
@@ -2139,10 +2142,11 @@ namespace eval Dwarf {
 	variable _line_header_finalized
 	variable _line_saw_program
 	variable _line_header_end_label
+	variable _line_unit_version
 
 	# Establish the defaults.
 	set is_64 0
-	set _unit_version 4
+	set _line_unit_version 4
 	set _unit_addr_size default
 	set _line_saw_program 0
 	set _line_saw_file 0
@@ -2150,12 +2154,14 @@ namespace eval Dwarf {
 	set _line_file_names {}
 	set _line_header_finalized 0
 	set _default_is_stmt 1
+	set _seg_sel_size 0
 
 	foreach { name value } $options {
 	    switch -exact -- $name {
 		is_64 { set is_64 $value }
-		version { set _unit_version $value }
+		version { set _line_unit_version $value }
 		addr_size { set _unit_addr_size $value }
+		seg_sel_size { set _seg_sel_size $value }
 		default_is_stmt { set _default_is_stmt $value }
 		default { error "unknown option $name" }
 	    }
@@ -2192,7 +2198,13 @@ namespace eval Dwarf {
 
 	define_label $unit_len_label
 
-	_op .2byte $_unit_version version
+	_op .2byte $_line_unit_version version
+
+	if { $_line_unit_version >= 5 } {
+	    _op .byte $_unit_addr_size "address_size"
+	    # Hardcode to 0 for now.
+	    _op .byte $_seg_sel_size "seg_sel_size"
+	}
 
 	if {$is_64} {
 	    _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
@@ -2203,7 +2215,7 @@ namespace eval Dwarf {
 	define_label $header_len_label
 
 	_op .byte 1 "minimum_instruction_length"
-	if { $_unit_version >= 4 } {
+	if { $_line_unit_version >= 4 } {
 	    # Assume non-VLIW for now.
 	    _op .byte 1 "maximum_operations_per_instruction"
 	}
@@ -2251,7 +2263,54 @@ namespace eval Dwarf {
 	    variable _line_include_dirs
 	    variable _line_file_names
 
-	    if { 1 } {
+	    variable _line_unit_version
+	    if { $_line_unit_version >= 5 } {
+		_op .byte 1 "directory_entry_format_count"
+		_op .uleb128 1 \
+		    "directory_entry_format (content type code: DW_LNCT_path)"
+		_op .uleb128 0x08 \
+		    "directory_entry_format (form: DW_FORM_string)"
+
+		set nr_dirs [llength $_line_include_dirs]
+		# For entry 0.
+		set nr_dirs [expr $nr_dirs + 1]
+		_op .byte $nr_dirs "directory_count"
+
+		# Entry 0.
+		set dirname [lindex $_line_include_dirs 0]
+		set _line_include_dirs \
+		    [concat [list $dirname] $_line_include_dirs]
+
+		foreach dirname $_line_include_dirs {
+		    _op .ascii [_quote $dirname]
+		}
+
+		_op .byte 2 "file_name_entry_format_count"
+		_op .uleb128 1 \
+		    "file_name_entry_format (content type code: DW_LNCT_path)"
+		_op .uleb128 0x08 \
+		    "file_name_entry_format (form: DW_FORM_string)"
+		_op .uleb128 2 \
+		    "file_name_entry_format (content type code: DW_LNCT_directory_index)"
+		_op .uleb128 0x0f \
+		    "file_name_entry_format (form: DW_FORM_udata)"
+
+		set nr_files [expr [llength $_line_file_names] / 2]
+		# For entry 0.
+		set nr_files [expr $nr_files + 1]
+		_op .byte $nr_files "file_names_count"
+
+		# Entry 0.
+		set filename [lindex $_line_file_names 0]
+		set diridx [lindex $_line_file_names 1]
+		set _line_file_names \
+		    [concat [list $filename $diridx] $_line_file_names]
+
+		foreach { filename diridx } $_line_file_names {
+		    _op .ascii [_quote $filename]
+		    _op .uleb128 $diridx
+		}
+	    } else {
 		foreach dirname $_line_include_dirs {
 		    _op .ascii [_quote $dirname]
 		}
-- 
2.26.2

[PATCH 7/8] [gdb/testsuite] Add target board dwarf64.exp

[Tom de Vries]

Add a new target board dwarf64.exp, that runs test with -gdwarf64.

Tested on x86_64-linux.
---
 gdb/testsuite/boards/dwarf64.exp | 23 +++++++++++++++++++++++
 1 file changed, 23 insertions(+)
 create mode 100644 gdb/testsuite/boards/dwarf64.exp

diff --git a/gdb/testsuite/boards/dwarf64.exp b/gdb/testsuite/boards/dwarf64.exp
new file mode 100644
index 00000000000..36acd7026b3
--- /dev/null
+++ b/gdb/testsuite/boards/dwarf64.exp
@@ -0,0 +1,23 @@
+# Copyright 2021 Free Software Foundation, Inc.
+
+# 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 <http://www.gnu.org/licenses/>.
+
+load_generic_config "unix"
+
+set_board_info compiler "[find_gcc]"
+
+set_board_info debug_flags "-gdwarf64 -g"
+
+# This is needed otherwise dejagnu tries to rsh to host "$boardname".
+load_board_description "local-board"
-- 
2.26.2

[PATCH 8/8] [gdb/symtab] Support .debug_line with DW_FORM_line_strp

[Tom de Vries]

I noticed a new gcc option -gdwarf64 and tried it out (using gcc 11.2.1).

With a test-case hello.c:
...
int
main (void)
{
  printf ("hello\n");
  return 0;
}
...
compiled like this:
...
$ gcc -g -gdwarf64 ~/hello.c
...
I ran into:
...
$ gdb -q -batch a.out
DW_FORM_line_strp pointing outside of .debug_line_str section \
  [in module a.out]
...

Debugging gdb revealed that the string offset is:
...
(gdb) up
    objfile=0x182ab70, str_offset=1378684502312,
    form_name=0xeae9b5 "DW_FORM_line_strp")
    at src/gdb/dwarf2/section.c:208
208         error (_("%s pointing outside of %s section [in module %s]"),
(gdb) p /x str_offset
$1 = 0x14100000128
(gdb)
...
which is read when parsing a .debug_line entry at 0x1e0.

Looking with readelf at the 0x1e0 entry, we have:
...
 The Directory Table (offset 0x202, lines 2, columns 1):
  Entry Name
  0     (indirect line string, offset: 0x128): /data/gdb_versions/devel
  1     (indirect line string, offset: 0x141): /home/vries
...
which in a hexdump looks like:
...
  0x00000200 1f022801 00004101 00000201 1f020f02
...

What happens is the following:
- readelf interprets the DW_FORM_line_strp reference to .debug_line_str as
  a 4 byte value, and sees entries 0x00000128 and 0x00000141.
- gdb instead interprets it as an 8 byte value, and sees as first entry
  0x0000014100000128, which is too big so it bails out.

AFAIU, gdb is wrong.  It assumes DW_FORM_line_strp is 8 bytes on the basis
that the corresponding CU is 64-bit DWARF.  However, the .debug_line
contribution has it's own initial_length field, and encodes there that it's
32-bit DWARF.

Fix this by using the correct offset size for DW_FORM_line_strp references
in .debug_line.

Note: the described test-case does trigger this complaint (both with and
without this patch):
...
$ gdb -q -batch -iex "set complaints 10" a.out
During symbol reading: intermixed 32-bit and 64-bit DWARF sections
...

The reason that the CU has 64-bit dwarf is because -gdwarf64 was passed to
gcc.  The reason that the .debug_line entry has 32-bit dwarf is because that's
what gas generates.  Perhaps this is complaint-worthy, but I don't think it
is wrong.

Tested on x86_64-linux, using native and target board dwarf64.exp.
---
 gdb/dwarf2/line-header.c               | 15 +++---
 gdb/dwarf2/read.c                      | 12 +++++
 gdb/dwarf2/read.h                      |  5 ++
 gdb/testsuite/gdb.dwarf2/dw2-lines.exp | 22 +++++---
 gdb/testsuite/lib/dwarf.exp            | 75 ++++++++++++++++++++++----
 5 files changed, 106 insertions(+), 23 deletions(-)

diff --git a/gdb/dwarf2/line-header.c b/gdb/dwarf2/line-header.c
index 15195764c89..852e2851e99 100644
--- a/gdb/dwarf2/line-header.c
+++ b/gdb/dwarf2/line-header.c
@@ -137,7 +137,7 @@ read_checked_initial_length_and_offset (bfd *abfd, const gdb_byte *buf,
 static void
 read_formatted_entries (dwarf2_per_objfile *per_objfile, bfd *abfd,
 			const gdb_byte **bufp, struct line_header *lh,
-			const struct comp_unit_head *cu_header,
+			unsigned int offset_size,
 			void (*callback) (struct line_header *lh,
 					  const char *name,
 					  dir_index d_index,
@@ -187,9 +187,12 @@ read_formatted_entries (dwarf2_per_objfile *per_objfile, bfd *abfd,
 	      break;
 
 	    case DW_FORM_line_strp:
-	      string.emplace
-		(per_objfile->read_line_string (buf, cu_header, &bytes_read));
-	      buf += bytes_read;
+	      {
+		const char *str
+		  = per_objfile->read_line_string (buf, offset_size);
+		string.emplace (str);
+		buf += offset_size;
+	      }
 	      break;
 
 	    case DW_FORM_data1:
@@ -372,7 +375,7 @@ dwarf_decode_line_header  (sect_offset sect_off, bool is_dwz,
     {
       /* Read directory table.  */
       read_formatted_entries (per_objfile, abfd, &line_ptr, lh.get (),
-			      cu_header,
+			      offset_size,
 			      [] (struct line_header *header, const char *name,
 				  dir_index d_index, unsigned int mod_time,
 				  unsigned int length)
@@ -382,7 +385,7 @@ dwarf_decode_line_header  (sect_offset sect_off, bool is_dwz,
 
       /* Read file name table.  */
       read_formatted_entries (per_objfile, abfd, &line_ptr, lh.get (),
-			      cu_header,
+			      offset_size,
 			      [] (struct line_header *header, const char *name,
 				  dir_index d_index, unsigned int mod_time,
 				  unsigned int length)
diff --git a/gdb/dwarf2/read.c b/gdb/dwarf2/read.c
index e456c37e193..a807f90568f 100644
--- a/gdb/dwarf2/read.c
+++ b/gdb/dwarf2/read.c
@@ -20286,6 +20286,18 @@ read_indirect_string (dwarf2_per_objfile *per_objfile, bfd *abfd,
 
 /* See read.h.  */
 
+const char *
+dwarf2_per_objfile::read_line_string (const gdb_byte *buf,
+				      unsigned int offset_size)
+{
+  bfd *abfd = objfile->obfd;
+  ULONGEST str_offset = read_offset (abfd, buf, offset_size);
+
+  return per_bfd->line_str.read_string (objfile, str_offset, "DW_FORM_line_strp");
+}
+
+/* See read.h.  */
+
 const char *
 dwarf2_per_objfile::read_line_string (const gdb_byte *buf,
 				      const struct comp_unit_head *cu_header,
diff --git a/gdb/dwarf2/read.h b/gdb/dwarf2/read.h
index 1638d8521c0..fe34e3f95ae 100644
--- a/gdb/dwarf2/read.h
+++ b/gdb/dwarf2/read.h
@@ -517,6 +517,11 @@ struct dwarf2_per_objfile
 				const struct comp_unit_head *cu_header,
 				unsigned int *bytes_read_ptr);
 
+  /* Return pointer to string at .debug_line_str offset as read from BUF.
+     The offset_size is OFFSET_SIZE.  */
+  const char *read_line_string (const gdb_byte *buf,
+				unsigned int offset_size);
+
   /* Return true if the symtab corresponding to PER_CU has been set,
      false otherwise.  */
   bool symtab_set_p (const dwarf2_per_cu_data *per_cu) const;
diff --git a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
index 27134af8f5d..9cc24955102 100644
--- a/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
+++ b/gdb/testsuite/gdb.dwarf2/dw2-lines.exp
@@ -37,18 +37,19 @@ proc line_for { l } {
 }
 
 # Execute test.
-proc test_1 { _cv _cdw64 _lv _ldw64 } {
+proc test_1 { _cv _cdw64 _lv _ldw64 {_string_form ""}} {
     global srcfile srcfile2 testfile
-    global cv cdw64 lv ldw64
+    global cv cdw64 lv ldw64 string_form
     set cv $_cv
     set cdw64 $_cdw64
     set lv $_lv
     set ldw64 $_ldw64
+    set string_form $_string_form
 
     set asm_file [standard_output_file $srcfile2]
     Dwarf::assemble $asm_file {
 	declare_labels Llines
-	global srcdir subdir srcfile cv cdw64 lv ldw64
+	global srcdir subdir srcfile cv cdw64 lv ldw64 string_form
 	global func_info_vars
 	foreach var $func_info_vars {
 	    global $var
@@ -75,7 +76,7 @@ proc test_1 { _cv _cdw64 _lv _ldw64 } {
 	    }
 	}
 
-	lines [list version $lv is_64 $ldw64] Llines {
+	lines [list version $lv is_64 $ldw64 string_form $string_form] Llines {
 	    include_dir "${srcdir}/${subdir}"
 	    file_name "$srcfile" 1
 
@@ -121,12 +122,18 @@ proc test_1 { _cv _cdw64 _lv _ldw64 } {
 
 
 # Add unique test prefix.
-proc test { cv cdw64 lv ldw64 } {
+proc test { cv cdw64 lv ldw64 {string_form ""}} {
     with_test_prefix cv=$cv {
 	with_test_prefix cdw=[expr $cdw64 ? 64 : 32] {
 	    with_test_prefix lv=$lv {
 		with_test_prefix ldw=[expr $ldw64 ? 64 : 32] {
-		    test_1 $cv $cdw64 $lv $ldw64
+		    if { $string_form == "" } {
+			test_1 $cv $cdw64 $lv $ldw64
+		    } else {
+			with_test_prefix string_form=$string_form {
+			    test_1 $cv $cdw64 $lv $ldw64 $string_form
+			}
+		    }
 		}
 	    }
 	}
@@ -157,6 +164,7 @@ for { set cv $cv_low } { $cv <= $cv_high } { incr cv } {
 
 foreach cdw64 { 0 1 } {
     foreach ldw64 { 0 1 } {
-	test 5 $cdw64 5 $ldw64
+	test 5 $cdw64 5 $ldw64 string
+	test 5 $cdw64 5 $ldw64 line_strp
     }
 }
diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp
index 76ba65df9fd..4e777e4cceb 100644
--- a/gdb/testsuite/lib/dwarf.exp
+++ b/gdb/testsuite/lib/dwarf.exp
@@ -2143,9 +2143,11 @@ namespace eval Dwarf {
 	variable _line_saw_program
 	variable _line_header_end_label
 	variable _line_unit_version
+	variable _line_is_64
+	variable _line_string_form
 
 	# Establish the defaults.
-	set is_64 0
+	set _line_is_64 0
 	set _line_unit_version 4
 	set _unit_addr_size default
 	set _line_saw_program 0
@@ -2155,14 +2157,17 @@ namespace eval Dwarf {
 	set _line_header_finalized 0
 	set _default_is_stmt 1
 	set _seg_sel_size 0
+	#set _line_string_form string
+	set _line_string_form line_strp
 
 	foreach { name value } $options {
 	    switch -exact -- $name {
-		is_64 { set is_64 $value }
+		is_64 { set _line_is_64 $value }
 		version { set _line_unit_version $value }
 		addr_size { set _unit_addr_size $value }
 		seg_sel_size { set _seg_sel_size $value }
 		default_is_stmt { set _default_is_stmt $value }
+		string_form { set $_line_string_form $value }
 		default { error "unknown option $name" }
 	    }
 	}
@@ -2189,7 +2194,7 @@ namespace eval Dwarf {
 	set header_len_label [_compute_label "line${_line_count}_header_start"]
 	set _line_header_end_label [_compute_label "line${_line_count}_header_end"]
 
-	if {$is_64} {
+	if {$_line_is_64} {
 	    _op .4byte 0xffffffff
 	    _op .8byte "$unit_end_label - $unit_len_label" "unit_length"
 	} else {
@@ -2206,7 +2211,7 @@ namespace eval Dwarf {
 	    _op .byte $_seg_sel_size "seg_sel_size"
 	}
 
-	if {$is_64} {
+	if {$_line_is_64} {
 	    _op .8byte "$_line_header_end_label - $header_len_label" "header_length"
 	} else {
 	    _op .4byte "$_line_header_end_label - $header_len_label" "header_length"
@@ -2264,12 +2269,22 @@ namespace eval Dwarf {
 	    variable _line_file_names
 
 	    variable _line_unit_version
+	    variable _line_is_64
+	    variable _line_string_form
 	    if { $_line_unit_version >= 5 } {
 		_op .byte 1 "directory_entry_format_count"
 		_op .uleb128 1 \
 		    "directory_entry_format (content type code: DW_LNCT_path)"
-		_op .uleb128 0x08 \
-		    "directory_entry_format (form: DW_FORM_string)"
+		switch $_line_string_form {
+		    string {
+			_op .uleb128 0x08 \
+			    "directory_entry_format (form: DW_FORM_string)"
+		    }
+		    line_strp {
+			_op .uleb128 0x1f \
+			    "directory_entry_format (form: DW_FORM_line_strp)"
+		    }
+		}
 
 		set nr_dirs [llength $_line_include_dirs]
 		# For entry 0.
@@ -2282,14 +2297,38 @@ namespace eval Dwarf {
 		    [concat [list $dirname] $_line_include_dirs]
 
 		foreach dirname $_line_include_dirs {
-		    _op .ascii [_quote $dirname]
+		    switch $_line_string_form {
+			string {
+			    _op .ascii [_quote $dirname]
+			}
+			line_strp {
+			    declare_labels string_ptr
+			    _defer_output .debug_line_str {
+				string_ptr:
+				_op .ascii [_quote $dirname]
+			    }
+			    if { $_line_is_64 } {
+				_op .8byte $string_ptr
+			    } else {
+				_op .4byte $string_ptr
+			    }
+			}
+		    }
 		}
 
 		_op .byte 2 "file_name_entry_format_count"
 		_op .uleb128 1 \
 		    "file_name_entry_format (content type code: DW_LNCT_path)"
-		_op .uleb128 0x08 \
-		    "file_name_entry_format (form: DW_FORM_string)"
+		switch $_line_string_form {
+		    string {
+			_op .uleb128 0x08 \
+			    "directory_entry_format (form: DW_FORM_string)"
+		    }
+		    line_strp {
+			_op .uleb128 0x1f \
+			    "directory_entry_format (form: DW_FORM_line_strp)"
+		    }
+		}
 		_op .uleb128 2 \
 		    "file_name_entry_format (content type code: DW_LNCT_directory_index)"
 		_op .uleb128 0x0f \
@@ -2307,7 +2346,23 @@ namespace eval Dwarf {
 		    [concat [list $filename $diridx] $_line_file_names]
 
 		foreach { filename diridx } $_line_file_names {
-		    _op .ascii [_quote $filename]
+		    switch $_line_string_form {
+			string {
+			    _op .ascii [_quote $filename]
+			}
+			line_strp {
+			    declare_labels string_ptr
+			    _defer_output .debug_line_str {
+				string_ptr:
+				_op .ascii [_quote $filename]
+			    }
+			    if { $_line_is_64 } {
+				_op .8byte $string_ptr
+			    } else {
+				_op .4byte $string_ptr
+			    }
+			}
+		    }
 		    _op .uleb128 $diridx
 		}
 	    } else {
-- 
2.26.2

[PING][PATCH 1/8] [gdb/testsuite] Factor out proc finally

[Tom de Vries]

Ping (for the entire series).

Thanks,
- Tom

On 10/25/21 12:29 PM, Tom de Vries via Gdb-patches wrote:
> There's a common pattern in the tcl procs to run cleanup code, emulating
> the 'finally' functionality:
> ...
>     set code [catch {
>       # Try.
>       ...
>     } result]
> 
>     # Finally.
>     ...
> 
>     # Return as appropriate.
>     if { $code == 1 } {
>         global errorInfo errorCode
>         return -code error -errorinfo $errorInfo -errorcode $errorCode $result
> 
>     } elseif { $code > 1 } {
>         return -code $code $result
>     }
> 
>     <use> $result
> ...
> 
> Factor this out into a new proc 'finally', such that we can simply write:
> ...
>     finally {
>         # Try.
>         ...
>     } {
>         # Finally.
>     	...
>     }
> ...
> 
> Note: to factor this out into a proc, we have to bump the
> implicit "-level 1" here to:
> ...
>     } elseif { $code > 1 } {
>         return -code $code -level 2 $result
>     }
> ...
> 
> Note: a normal 'finally' implementation would for this example:
> ...
> proc bar {} {
>     puts "bar: entry"
>     finally {
>         puts "bar: body"
>         return
>     } {
>         puts "bar: finally"
>     }
>     puts "bar: exit"
> }
> 
> proc foo {} {
>     puts "foo: entry"
>     bar
>     puts "foo: exit"
> }
> 
> puts"toplevel: entry"
> foo
> puts "toplevel: exit"
> ...
> have this output:
> ...
> toplevel: entry
> foo: entry
> bar: entry
> bar: body
> bar: finally
> foo: exit
> toplevel: exit
> ...
> 
> But our implementation also skips "foo: exit".  That seems to be something
> some test-cases rely upon, which should probably be fixed.
> 
> Tested on x86_64-linux.
> ---
>  gdb/testsuite/lib/gdb.exp | 268 ++++++++++++++++----------------------
>  1 file changed, 114 insertions(+), 154 deletions(-)
> 
> diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
> index 7f02504262d..e5d247de36f 100644
> --- a/gdb/testsuite/lib/gdb.exp
> +++ b/gdb/testsuite/lib/gdb.exp
> @@ -51,6 +51,27 @@ proc gdb_persistent_global_no_decl { args } {
>      }
>  }
>  
> +# Execute BODY, then FINALLY, even if an exception is thrown in BODY.
> +
> +proc finally { body finally } {
> +    # Execute body.
> +    set code [catch {uplevel 1 $body} result]
> +
> +    uplevel 1 $finally
> +
> +    # Return as appropriate.
> +    if { $code == 1 } {
> +        global errorInfo errorCode
> +        return -code error -errorinfo $errorInfo -errorcode $errorCode $result
> +    } elseif { $code > 1 } {
> +	# FIXME: Should have "-level 1" here, to emulate actual
> +	# finally behaviour.
> +        return -code $code -level 2 $result
> +    }
> +
> +    return $result
> +}
> +
>  # Override proc load_lib.
>  rename load_lib saved_load_lib
>  # Run the runtest version of load_lib, and mark all variables that were
> @@ -61,22 +82,15 @@ proc load_lib { file } {
>         set known_globals($varname) 1
>      }
>  
> -    set code [catch "saved_load_lib $file" result]
> -
> -    foreach varname [info globals] {
> -       if { ![info exists known_globals($varname)] } {
> -           gdb_persistent_global_no_decl $varname
> -       }
> -    }
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code error -errorinfo $errorInfo -errorcode $errorCode $result
> -    } elseif {$code > 1} {
> -	return -code $code $result
> +    finally {
> +	saved_load_lib $file
> +    } {
> +	foreach varname [info globals] {
> +	    if { ![info exists known_globals($varname)] } {
> +		gdb_persistent_global_no_decl $varname
> +	    }
> +	}
>      }
> -
> -    return $result
>  }
>  
>  load_lib libgloss.exp
> @@ -1224,25 +1238,20 @@ proc gdb_test_multiple { command message args } {
>      }
>      set gdb_test_name "$message"
>  
> -    set result 0
> -    set code [catch {gdb_expect $code} string]
> -
> -    # Clean up the gdb_test_name variable.  If we had a
> -    # previous value then restore it, otherwise, delete the variable
> -    # from the parent scope.
> -    if { [info exists gdb_test_name_old] } {
> -	set gdb_test_name "$gdb_test_name_old"
> -    } else {
> -	unset gdb_test_name
> +    finally {
> +	gdb_expect $code
> +    } {
> +	# Clean up the gdb_test_name variable.  If we had a
> +	# previous value then restore it, otherwise, delete the variable
> +	# from the parent scope.
> +	if { [info exists gdb_test_name_old] } {
> +	    set gdb_test_name "$gdb_test_name_old"
> +	} else {
> +	    unset gdb_test_name
> +	}
>      }
>  
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code error -errorinfo $errorInfo -errorcode $errorCode $string
> -    } elseif {$code > 1} {
> -	return -code $code $string
> -    }
> -    return $result
> +    return 0
>  }
>  
>  # Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ...
> @@ -2452,14 +2461,10 @@ proc with_test_prefix { prefix body } {
>  
>    set saved $pf_prefix
>    append pf_prefix " " $prefix ":"
> -  set code [catch {uplevel 1 $body} result]
> -  set pf_prefix $saved
> -
> -  if {$code == 1} {
> -      global errorInfo errorCode
> -      return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -  } else {
> -      return -code $code $result
> +  finally {
> +      uplevel 1 $body
> +  } {
> +      set pf_prefix $saved
>    }
>  }
>  
> @@ -2535,26 +2540,21 @@ proc save_vars { vars body } {
>  	}
>      }
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    foreach {var value} [array get saved_scalars] {
> -	uplevel 1 [list set $var $value]
> -    }
> -
> -    foreach {var value} [array get saved_arrays] {
> -	uplevel 1 [list unset $var]
> -	uplevel 1 [list array set $var $value]
> -    }
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	foreach {var value} [array get saved_scalars] {
> +	    uplevel 1 [list set $var $value]
> +	}
>  
> -    foreach var $unset_vars {
> -	uplevel 1 [list unset -nocomplain $var]
> -    }
> +	foreach {var value} [array get saved_arrays] {
> +	    uplevel 1 [list unset $var]
> +	    uplevel 1 [list array set $var $value]
> +	}
>  
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +	foreach var $unset_vars {
> +	    uplevel 1 [list unset -nocomplain $var]
> +	}
>      }
>  }
>  
> @@ -2586,22 +2586,18 @@ proc save_target_board_info { vars body } {
>  	}
>      }
>  
> -    set code [catch {uplevel 1 $body} result]
> +    finally {
> +	uplevel 1 $body
> +    } {
>  
> -    foreach {var value} [array get saved_target_board_info] {
> -	unset_board_info $var
> -	set_board_info $var $value
> -    }
> -
> -    foreach var $unset_target_board_info {
> -	unset_board_info $var
> -    }
> +	foreach {var value} [array get saved_target_board_info] {
> +	    unset_board_info $var
> +	    set_board_info $var $value
> +	}
>  
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +	foreach var $unset_target_board_info {
> +	    unset_board_info $var
> +	}
>      }
>  }
>  
> @@ -2617,16 +2613,11 @@ proc with_cwd { dir body } {
>      verbose -log "Switching to directory $dir (saved CWD: $saved_dir)."
>      cd $dir
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    verbose -log "Switching back to $saved_dir."
> -    cd $saved_dir
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	verbose -log "Switching back to $saved_dir."
> +	cd $saved_dir
>      }
>  }
>  
> @@ -2667,17 +2658,12 @@ proc with_gdb_prompt { prompt body } {
>      set gdb_prompt $prompt
>      gdb_test_no_output "set prompt $prompt " ""
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    verbose -log "Restoring gdb prompt to \"$saved \"."
> -    set gdb_prompt $saved
> -    gdb_test_no_output "set prompt $saved " ""
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	verbose -log "Restoring gdb prompt to \"$saved \"."
> +	set gdb_prompt $saved
> +	gdb_test_no_output "set prompt $saved " ""
>      }
>  }
>  
> @@ -2702,15 +2688,10 @@ proc with_target_charset { target_charset body } {
>  
>      gdb_test_no_output "set target-charset $target_charset" ""
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    gdb_test_no_output "set target-charset $saved" ""
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	gdb_test_no_output "set target-charset $saved" ""
>      }
>  }
>  
> @@ -2748,19 +2729,14 @@ proc with_spawn_id { spawn_id body } {
>  
>      switch_gdb_spawn_id $spawn_id
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    if [info exists saved_spawn_id] {
> -	switch_gdb_spawn_id $saved_spawn_id
> -    } else {
> -	clear_gdb_spawn_id
> -    }
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	if [info exists saved_spawn_id] {
> +	    switch_gdb_spawn_id $saved_spawn_id
> +	} else {
> +	    clear_gdb_spawn_id
> +	}
>      }
>  }
>  
> @@ -2801,14 +2777,10 @@ proc with_timeout_factor { factor body } {
>      set savedtimeout $timeout
>  
>      set timeout [expr [get_largest_timeout] * $factor]
> -    set code [catch {uplevel 1 $body} result]
> -
> -    set timeout $savedtimeout
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	set timeout $savedtimeout
>      }
>  }
>  
> @@ -5376,18 +5348,13 @@ proc with_complaints { n body } {
>  	gdb_test_no_output "set complaints $n" ""
>      }
>  
> -    set code [catch {uplevel 1 $body} result]
> -
> -    # Restore saved setting of complaints.
> -    if { $save != "" } {
> -	gdb_test_no_output "set complaints $save" ""
> -    }
> -
> -    if {$code == 1} {
> -	global errorInfo errorCode
> -	return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
> -    } else {
> -	return -code $code $result
> +    finally {
> +	uplevel 1 $body
> +    } {
> +	# Restore saved setting of complaints.
> +	if { $save != "" } {
> +	    gdb_test_no_output "set complaints $save" ""
> +	}
>      }
>  }
>  
> @@ -8035,30 +8002,23 @@ proc with_override { name override body } {
>  	set existed false
>      }
>  
> -    # Install the override.
>      set new_args [info args $override]
>      set new_body [info body $override]
> -    eval proc $name {$new_args} {$new_body}
>  
>      # Execute body.
> -    set code [catch {uplevel 1 $body} result]
> -
> -    # Restore old proc if it existed on entry, else delete it.
> -    if { $existed } {
> -	eval proc $name {$old_args} {$old_body}
> -    } else {
> -	rename $name ""
> -    }
> -
> -    # Return as appropriate.
> -    if { $code == 1 } {
> -        global errorInfo errorCode
> -        return -code error -errorinfo $errorInfo -errorcode $errorCode $result
> -    } elseif { $code > 1 } {
> -        return -code $code $result
> +    finally {
> +	# Install the override.
> +	eval proc $name {$new_args} {$new_body}
> +
> +	uplevel 1 $body
> +    } {
> +	# Restore old proc if it existed on entry, else delete it.
> +	if { $existed } {
> +	    eval proc $name {$old_args} {$old_body}
> +	} else {
> +	    rename $name ""
> +	}
>      }
> -
> -    return $result
>  }
>  
>  # Setup tuiterm.exp environment.  To be used in test-cases instead of
> 
> base-commit: 1ed0032b40063795d6c3ce89eab3101a8fd67569
> 

Re: [PATCH 1/8] [gdb/testsuite] Factor out proc finally

[Pedro Alves]

On 2021-10-25 11:29, Tom de Vries via Gdb-patches wrote:
> There's a common pattern in the tcl procs to run cleanup code, emulating
> the 'finally' functionality:
> ...
>     set code [catch {
>       # Try.
>       ...
>     } result]
> 
>     # Finally.
>     ...
> 
>     # Return as appropriate.
>     if { $code == 1 } {
>         global errorInfo errorCode
>         return -code error -errorinfo $errorInfo -errorcode $errorCode $result
> 
>     } elseif { $code > 1 } {
>         return -code $code $result
>     }
> 
>     <use> $result
> ...
> 
> Factor this out into a new proc 'finally', such that we can simply write:
> ...
>     finally {
>         # Try.
>         ...
>     } {
>         # Finally.
>     	...
>     }


The position of the "finally" seems super surprising to me.  I'd expect something like one of
the below:

try {
  # Try.
} finally {
  # Finally.
}

try {
  # Try.
} {
  # Finally.
}

try_finally {
  # Try.
} {
  # Finally.
}


Can we just use standard try/finally, though?

  https://wiki.tcl-lang.org/page/try

It looks exactly like the first example I give above.

It's available starting with TCL 8.6.  We could add some simple fallback implementation
similar to yours that only supports try/except if necessary, I think.

Re: [PATCH 1/8] [gdb/testsuite] Factor out proc finally

[Tom de Vries]

On 11/19/21 8:33 PM, Pedro Alves wrote:
> On 2021-10-25 11:29, Tom de Vries via Gdb-patches wrote:
>> There's a common pattern in the tcl procs to run cleanup code, emulating
>> the 'finally' functionality:
>> ...
>>     set code [catch {
>>       # Try.
>>       ...
>>     } result]
>>
>>     # Finally.
>>     ...
>>
>>     # Return as appropriate.
>>     if { $code == 1 } {
>>         global errorInfo errorCode
>>         return -code error -errorinfo $errorInfo -errorcode $errorCode $result
>>
>>     } elseif { $code > 1 } {
>>         return -code $code $result
>>     }
>>
>>     <use> $result
>> ...
>>
>> Factor this out into a new proc 'finally', such that we can simply write:
>> ...
>>     finally {
>>         # Try.
>>         ...
>>     } {
>>         # Finally.
>>     	...
>>     }
> 
> 
> The position of the "finally" seems super surprising to me.  I'd expect something like one of
> the below:
> 
> try {
>   # Try.
> } finally {
>   # Finally.
> }
> 
> try {
>   # Try.
> } {
>   # Finally.
> }
> 
> try_finally {
>   # Try.
> } {
>   # Finally.
> }
> 
> 
> Can we just use standard try/finally, though?
> 
>   https://wiki.tcl-lang.org/page/try
> 
> It looks exactly like the first example I give above.
> 
> It's available starting with TCL 8.6.  We could add some simple fallback implementation
> similar to yours that only supports try/except if necessary, I think.
> 

Well, the problem is that we have test-cases that rely on non-standard
'finally' behaviour.   I've tried to explain the difference to the
standard 'finally' implementation in the submission, see the notes.

So yes, we could use the tcl finally, if we fix those test-cases first.

Thanks,
- Tom

Re: [PATCH 2/8] [gdb/testsuite] Speed up MACRO_AT_* calls

[Tom de Vries]

On 10/25/21 12:29 PM, Tom de Vries via Gdb-patches wrote:
> Currently, for each MACRO_AT_range or MACRO_AT_func in dwarf assembly the
> following is done:
> - $srcdir/$subdir/$srcfile is compiled to an executable using
>   flags "debug"
> - a new gdb instance is started
> - the new executable is loaded.
> 
> This is inefficient, because the executable is identical within the same
> Dwarf::assemble call.
> 
> Share the gdb instance in the same Dwarf::assemble invocation, which speeds
> up a make check with RUNTESTFLAGS like this to catch all dwarf assembly
> test-cases:
> ...
> rtf=$(echo $(cd src/gdb/testsuite; find gdb.* -type f -name "*.exp" \
>       | xargs grep -l Dwarf::assemble))
> ...
> from:
> ...
> real    1m39.916s
> user    1m25.668s
> sys     0m21.377s
> ...
> to:
> ...
> real    1m29.512s
> user    1m17.316s
> sys     0m19.100s
> ...
> 

I've rewritten this patch to not use the finally proc introduced in 1/8,
and pushed the series starting this patch.

Thanks,
- Tom