mirror of
https://sourceware.org/git/binutils-gdb.git
synced 2024-12-09 04:21:49 +08:00
b452b96c1e
This changes the DAP code to explicitly request that gdb exit. Previously this could cause crashes, but with the previous cleanups, this should no longer happen. This also adds a tests that ensures that gdb exits with status 0.
502 lines
14 KiB
Plaintext
502 lines
14 KiB
Plaintext
# Copyright 2022-2024 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/>.
|
|
|
|
# The JSON parser.
|
|
load_lib ton.tcl
|
|
|
|
# The sequence number for the currently-executing instance of gdb
|
|
# launched via dap_gdb_start. This is used for log-file checking
|
|
# after the run is complete. Zero means gdb hasn't started yet.
|
|
set dap_gdb_instance 0
|
|
|
|
# The sequence number for the next DAP request. This is used by the
|
|
# automatic sequence-counting code below. It is reset each time GDB
|
|
# is restarted.
|
|
set dap_seq 1
|
|
|
|
# Return the current DAP log file.
|
|
proc current_dap_log_file {} {
|
|
global dap_gdb_instance
|
|
return [standard_output_file "dap.log.$dap_gdb_instance"]
|
|
}
|
|
|
|
# Return a new DAP log file.
|
|
proc new_dap_log_file {} {
|
|
global dap_gdb_instance
|
|
incr dap_gdb_instance
|
|
return [current_dap_log_file]
|
|
}
|
|
|
|
# Start gdb using the DAP interpreter.
|
|
proc dap_gdb_start {} {
|
|
# Keep track of the number of times GDB has been launched.
|
|
global gdb_instances
|
|
incr gdb_instances
|
|
|
|
gdb_stdin_log_init
|
|
|
|
global GDBFLAGS stty_init
|
|
save_vars { GDBFLAGS stty_init } {
|
|
set stty_init "-echo raw"
|
|
set logfile [new_dap_log_file]
|
|
append GDBFLAGS " -iex \"set debug dap-log-file $logfile\" -q -i=dap"
|
|
set res [gdb_spawn]
|
|
if {$res != 0} {
|
|
return $res
|
|
}
|
|
}
|
|
|
|
# Reset the counter.
|
|
set ::dap_seq 1
|
|
|
|
return 0
|
|
}
|
|
|
|
# A helper for dap_to_ton that decides if the list L is a JSON object
|
|
# or if it is an array.
|
|
proc _dap_is_obj {l} {
|
|
if {[llength $l] % 2 != 0} {
|
|
return 0
|
|
}
|
|
foreach {key value} $l {
|
|
if {![string is alpha $key]} {
|
|
return 0
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
|
|
# The "TON" format is a bit of a pain to write by hand, so this proc
|
|
# can be used to convert an ordinary Tcl list into TON by guessing at
|
|
# the correct forms to use. This can't be used in all cases, because
|
|
# Tcl can't really differentiate between literal forms. For example,
|
|
# there's no way to decide if "true" should be a string or the literal
|
|
# true.
|
|
#
|
|
# JSON objects must be passed in a particular form here -- as a list
|
|
# with an even number of elements, alternating keys and values. Each
|
|
# key must consist only of letters, no digits or other non-letter
|
|
# characters. Note that this is compatible with the Tcl 'dict'
|
|
# representation.
|
|
proc dap_to_ton {obj} {
|
|
if {[string is list $obj] && [llength $obj] > 1} {
|
|
if {[_dap_is_obj $obj]} {
|
|
set result o
|
|
foreach {key value} $obj {
|
|
lappend result $key \[[dap_to_ton $value]\]
|
|
}
|
|
} else {
|
|
set result a
|
|
foreach val $obj {
|
|
lappend result \[[dap_to_ton $val]\]
|
|
}
|
|
}
|
|
} elseif {[string is entier $obj]} {
|
|
set result [list i $obj]
|
|
} elseif {[string is double $obj]} {
|
|
set result [list d $obj]
|
|
} elseif {$obj == "true" || $obj == "false" || $obj == "null"} {
|
|
set result [list l $obj]
|
|
} else {
|
|
set result [list s $obj]
|
|
}
|
|
return $result
|
|
}
|
|
|
|
# Format the object OBJ, in TON format, as JSON and send it to gdb.
|
|
proc _dap_send_ton {obj} {
|
|
set json [namespace eval ton::2json $obj]
|
|
# FIXME this is wrong for non-ASCII characters.
|
|
set len [string length $json]
|
|
verbose -log ">>> $json"
|
|
send_gdb "Content-Length: $len\r\n\r\n$json"
|
|
}
|
|
|
|
# Send a DAP request to gdb. COMMAND is the request's "command"
|
|
# field, and OBJ is the "arguments" field. If OBJ is empty, it is
|
|
# omitted. The sequence number of the request is automatically added,
|
|
# and this is also the return value. OBJ is assumed to already be in
|
|
# TON form.
|
|
proc dap_send_request {command {obj {}}} {
|
|
# We can construct this directly as a TON object.
|
|
set result $::dap_seq
|
|
incr ::dap_seq
|
|
set req [format {o seq [i %d] type [s request] command [%s]} \
|
|
$result [list s $command]]
|
|
if {$obj != ""} {
|
|
append req " arguments \[$obj\]"
|
|
}
|
|
_dap_send_ton $req
|
|
return $result
|
|
}
|
|
|
|
# Read a JSON response from gdb. This will return a dict on
|
|
# success, or throw an exception on error. On success, the global
|
|
# "last_ton" will be set to the TON form of the result.
|
|
proc _dap_read_json {} {
|
|
set length ""
|
|
set seen_timeout 0
|
|
set seen_eof 0
|
|
gdb_expect {
|
|
-re "^Content-Length: (\[0-9\]+)\r\n" {
|
|
set length $expect_out(1,string)
|
|
exp_continue
|
|
}
|
|
-re "^(\[^\r\n\]+)\r\n" {
|
|
# Any other header field.
|
|
exp_continue
|
|
}
|
|
-re "^\r\n" {
|
|
# Done.
|
|
}
|
|
timeout {
|
|
set seen_timeout 1
|
|
}
|
|
eof {
|
|
set seen_eof 1
|
|
}
|
|
}
|
|
|
|
if {$seen_timeout} {
|
|
error "timeout reading json header"
|
|
}
|
|
if {$seen_eof} {
|
|
error "eof reading json header"
|
|
}
|
|
|
|
if {$length == ""} {
|
|
error "didn't find content-length"
|
|
}
|
|
|
|
set json ""
|
|
while {$length > 0} {
|
|
# Tcl only allows up to 255 characters in a {} expression in a
|
|
# regexp, so we may need to read in chunks.
|
|
set this_len [expr {min ($length, 255)}]
|
|
set seen_timeout 0
|
|
set seen_eof 0
|
|
gdb_expect {
|
|
-re "^.{$this_len}" {
|
|
append json $expect_out(0,string)
|
|
}
|
|
timeout {
|
|
set seen_timeout 1
|
|
}
|
|
eof {
|
|
set seen_eof 1
|
|
}
|
|
}
|
|
|
|
if {$seen_timeout} {
|
|
error "timeout reading json header"
|
|
}
|
|
if {$seen_eof} {
|
|
error "eof reading json header"
|
|
}
|
|
|
|
incr length -$this_len
|
|
}
|
|
|
|
global last_ton
|
|
set last_ton [ton::json2ton $json]
|
|
return [namespace eval ton::2dict $last_ton]
|
|
}
|
|
|
|
# Read a sequence of JSON objects from gdb, until a response object is
|
|
# seen. If the response object has the request sequence number NUM,
|
|
# and is for command CMD, return a list of two elements: the response
|
|
# object and a list of any preceding events, in the order they were
|
|
# emitted. The objects are dicts. If a response object is seen but
|
|
# has the wrong sequence number or command, throw an exception If a
|
|
# response is seen, this leaves the global "last_ton" set to the TON
|
|
# for the response.
|
|
|
|
proc dap_read_response {cmd num} {
|
|
set result {}
|
|
while 1 {
|
|
set d [_dap_read_json]
|
|
if {[dict get $d type] == "response"} {
|
|
if {[dict get $d request_seq] != $num} {
|
|
error "saw wrong request_seq in $obj"
|
|
} elseif {[dict get $d command] != $cmd} {
|
|
error "saw wrong command in $obj"
|
|
} else {
|
|
return [list $d $result]
|
|
}
|
|
} else {
|
|
lappend result $d
|
|
}
|
|
}
|
|
}
|
|
|
|
# A wrapper for dap_send_request and dap_read_response. This sends a
|
|
# request to gdb and returns the response as a dict.
|
|
proc dap_request_and_response {command {obj {}}} {
|
|
set seq [dap_send_request $command $obj]
|
|
return [dap_read_response $command $seq]
|
|
}
|
|
|
|
# Like dap_request_and_response, but also checks that the response
|
|
# indicates success. NAME is used to issue a test result.
|
|
proc dap_check_request_and_response {name command {obj {}}} {
|
|
set response_and_events [dap_request_and_response $command $obj]
|
|
set response [lindex $response_and_events 0]
|
|
if {[dict get $response success] != "true"} {
|
|
verbose "request failure: $response"
|
|
fail "$name success"
|
|
return ""
|
|
}
|
|
pass "$name success"
|
|
return $response_and_events
|
|
}
|
|
|
|
# Start gdb, send a DAP initialization request and return the
|
|
# response. This approach lets the caller check the feature list, if
|
|
# desired. Returns the empty string on failure. NAME is used as the
|
|
# test name.
|
|
proc dap_initialize {{name "initialize"}} {
|
|
if {[dap_gdb_start]} {
|
|
return ""
|
|
}
|
|
return [dap_check_request_and_response $name initialize \
|
|
{o clientID [s "gdb testsuite"] \
|
|
supportsVariableType [l true] \
|
|
supportsVariablePaging [l true] \
|
|
supportsMemoryReferences [l true]}]
|
|
}
|
|
|
|
# Send a launch request specifying FILE as the program to use for the
|
|
# inferior. Returns the empty string on failure, or the response
|
|
# object from the launch request. If specified, ARGS is a dictionary
|
|
# of key-value pairs, each passed to the launch request. Valid keys
|
|
# are:
|
|
#
|
|
# * arguments - value is a list of strings passed as command-line
|
|
# arguments to the inferior
|
|
# * env - value is a list of pairs of the form {VAR VALUE} that is
|
|
# used to populate the inferior's environment.
|
|
# * stop_at_main - value is ignored, the presence of this means that
|
|
# "stopAtBeginningOfMainSubprogram" will be passed to the launch
|
|
# request.
|
|
# * cwd - value is the working directory to use.
|
|
#
|
|
# After this proc is called, gdb will be ready to accept breakpoint
|
|
# requests.
|
|
proc dap_launch {file {args {}}} {
|
|
set params "o program"
|
|
append params " [format {[%s]} [list s [standard_output_file $file]]]"
|
|
|
|
foreach {key value} $args {
|
|
switch -exact -- $key {
|
|
arguments {
|
|
append params " args"
|
|
set arglist ""
|
|
foreach arg $value {
|
|
append arglist " \[s [list $arg]\]"
|
|
}
|
|
append params " \[a $arglist\]"
|
|
}
|
|
|
|
env {
|
|
append params " env"
|
|
set envlist ""
|
|
foreach pair $value {
|
|
lassign $pair var value
|
|
append envlist " $var"
|
|
append envlist " [format {[%s]} [list s $value]]"
|
|
}
|
|
append params " \[o $envlist\]"
|
|
}
|
|
|
|
stop_at_main {
|
|
append params { stopAtBeginningOfMainSubprogram [l true]}
|
|
}
|
|
|
|
cwd {
|
|
append envlist " cwd [format {[%s]} [list s $value]]"
|
|
}
|
|
|
|
default {
|
|
error "unrecognized parameter $key"
|
|
}
|
|
}
|
|
}
|
|
|
|
return [dap_check_request_and_response "startup - launch" launch $params]
|
|
}
|
|
|
|
# Start gdb, send a DAP initialize request, and then an attach request
|
|
# specifying PID as the inferior process ID. Returns the empty string
|
|
# on failure, or the response object from the attach request.
|
|
proc dap_attach {pid {prog ""}} {
|
|
if {[dap_initialize "startup - initialize"] == ""} {
|
|
return ""
|
|
}
|
|
|
|
set args [format {o pid [i %s]} $pid]
|
|
if {$prog != ""} {
|
|
append args [format { program [s %s]} $prog]
|
|
}
|
|
|
|
return [dap_check_request_and_response "startup - attach" attach $args]
|
|
}
|
|
|
|
# Start gdb, send a DAP initialize request, and then an attach request
|
|
# specifying TARGET as the remote target. Returns the empty string on
|
|
# failure, or the response object from the attach request.
|
|
proc dap_target_remote {target} {
|
|
if {[dap_initialize "startup - initialize"] == ""} {
|
|
return ""
|
|
}
|
|
return [dap_check_request_and_response "startup - target" attach \
|
|
[format {o target [s %s]} $target]]
|
|
}
|
|
|
|
# Read the most recent DAP log file and check it for exceptions.
|
|
proc dap_check_log_file {} {
|
|
set fd [open [current_dap_log_file]]
|
|
set contents [read $fd]
|
|
close $fd
|
|
|
|
set ok 1
|
|
foreach line [split $contents "\n"] {
|
|
if {[regexp "^Traceback" $line]} {
|
|
set ok 0
|
|
break
|
|
}
|
|
}
|
|
|
|
if {$ok} {
|
|
pass "exceptions in log file"
|
|
} else {
|
|
verbose -log -- "--- DAP LOG START ---"
|
|
verbose -log -- $contents
|
|
verbose -log -- "--- DAP LOG END ---"
|
|
fail "exceptions in log file"
|
|
}
|
|
}
|
|
|
|
# Read the most recent DAP log file and check that regexp RE matches.
|
|
proc dap_check_log_file_re { re } {
|
|
set fd [open [current_dap_log_file]]
|
|
set contents [read $fd]
|
|
close $fd
|
|
|
|
set ok [regexp $re $contents]
|
|
gdb_assert {$ok} "log file matched $re"
|
|
}
|
|
|
|
# Cleanly shut down gdb. TERMINATE is passed as the terminateDebuggee
|
|
# parameter to the request.
|
|
proc dap_shutdown {{terminate false}} {
|
|
dap_check_request_and_response "shutdown" disconnect \
|
|
[format {o terminateDebuggee [l %s]} $terminate]
|
|
|
|
# Check gdb's exit status.
|
|
global gdb_spawn_id
|
|
set result [wait -i $gdb_spawn_id]
|
|
gdb_assert {[lindex $result 2] == 0}
|
|
gdb_assert {[lindex $result 3] == 0}
|
|
|
|
clear_gdb_spawn_id
|
|
|
|
dap_check_log_file
|
|
}
|
|
|
|
# Search the event list EVENTS for an output event matching the regexp
|
|
# RX. Pass the test NAME if found, fail if not.
|
|
proc dap_search_output {name rx events} {
|
|
foreach d $events {
|
|
if {[dict get $d type] != "event"
|
|
|| [dict get $d event] != "output"} {
|
|
continue
|
|
}
|
|
if {[regexp $rx [dict get $d body output]]} {
|
|
pass $name
|
|
return
|
|
}
|
|
}
|
|
fail $name
|
|
}
|
|
|
|
# Check that D (a dict object) has values that match the
|
|
# key/value pairs given in ARGS. NAME is used as the test name.
|
|
proc dap_match_values {name d args} {
|
|
foreach {key value} $args {
|
|
if {[eval dict get [list $d] $key] != $value} {
|
|
fail "$name (checking $key)"
|
|
return ""
|
|
}
|
|
}
|
|
pass $name
|
|
}
|
|
|
|
# A helper for dap_wait_for_event_and_check that reads events, looking for one
|
|
# matching TYPE.
|
|
#
|
|
# Return a list of two items:
|
|
#
|
|
# - the matched event
|
|
# - a list of any JSON objects (events or others) seen before the matched
|
|
# event.
|
|
proc _dap_wait_for_event { {type ""} } {
|
|
set preceding [list]
|
|
|
|
while 1 {
|
|
# We don't do any extra error checking here for the time
|
|
# being; we'll just get a timeout thrown instead.
|
|
set d [_dap_read_json]
|
|
if {[dict get $d type] == "event"
|
|
&& ($type == "" || [dict get $d event] == $type)} {
|
|
return [list $d $preceding]
|
|
}
|
|
|
|
lappend preceding $d
|
|
}
|
|
}
|
|
|
|
# Read JSON objects looking for an event whose "event" field is TYPE.
|
|
#
|
|
# NAME is used as the test name; it defaults to TYPE. Extra arguments
|
|
# are used to check fields of the event; the arguments alternate
|
|
# between a field name (in "dict get" form) and its expected value.
|
|
#
|
|
# Return a list of two items:
|
|
#
|
|
# - the matched event (regardless of whether it passed the field validation or
|
|
# not)
|
|
# - a list of any JSON objects (events or others) seen before the matched
|
|
# event.
|
|
proc dap_wait_for_event_and_check {name type args} {
|
|
if {$name == ""} {
|
|
set name $type
|
|
}
|
|
|
|
set result [_dap_wait_for_event $type]
|
|
set event [lindex $result 0]
|
|
eval dap_match_values [list $name $event] $args
|
|
|
|
return $result
|
|
}
|
|
|
|
# A convenience function to extract the breakpoint number when a new
|
|
# breakpoint is created. OBJ is an object as returned by
|
|
# dap_check_request_and_response.
|
|
proc dap_get_breakpoint_number {obj} {
|
|
set d [lindex $obj 0]
|
|
set bplist [dict get $d body breakpoints]
|
|
return [dict get [lindex $bplist 0] id]
|
|
}
|