[thirdparty/binutils-gdb.git] / gdb / testsuite / gdb.base / gdb-caching-proc.exp

#   Copyright 2018-2019 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/>.

# When caching a proc using gdb_caching_proc, it will become less likely to
# be executed, and consequently it's going to be harder to detect that the
# proc is racy.  OTOH, in general the proc is easy to rerun.  So, run all
# uncached gdb_caching_procs a number of times and detect inconsistent results.
# The purpose of caching is to reduce runtime, so rerunning is somewhat
# counter-productive in that aspect, but it's better than uncached, because the
# number of reruns is constant-bounded, and the increase in runtime is bound to
# this test-case, and could be disabled on slow targets.

# Test gdb_caching_proc NAME
proc test_proc { name } {
    set real_name gdb_real__$name

    set resultlist [list]

    set first [$real_name]
    lappend resultlist $first

    # Ten repetitions was enough to trigger target_supports_scheduler_locking,
    # and costs about 20 seconds on an i7-6600U.
    set repeat 10

    set racy 0
    for {set i 0} {$i < $repeat} {incr i} {
	set rerun [$real_name]
	lappend resultlist $rerun
	if { $rerun != $first } {
	    set racy 1
	}
    }

    if { $racy  == 0 } {
	pass "$name consistency"
    } else {
	fail "$name consistency"
	verbose -log "$name: $resultlist"
    }
}

# Test gdb_caching_procs in FILE
proc test_file { file } {
    upvar obj obj
    set procnames [list]

    set fp [open $file]
    while { [gets $fp line] >= 0 } {
	if [regexp -- "^gdb_caching_proc \[ \t\]*(\[^ \t\]*)" $line \
		match procname] {
	    lappend procnames $procname
	}
    }
    close $fp

    if { [llength $procnames] == 0 } {
	return
    }

    if { [file tail $file] == "gdb.exp" } {
	# Already loaded
    } else {
	load_lib [file tail $file]
    }

    foreach procname $procnames {
	switch $procname {
	    "is_address_zero_readable" { set setup_gdb 1 }
	    "target_is_gdbserver" { set setup_gdb 1 }
	    default {set setup_gdb 0 }
	}

	if { $setup_gdb } {
	    clean_restart $obj
	}

	test_proc $procname

	if { $setup_gdb } {
	    gdb_exit
	}
    }
}

# Init
set me "gdb_caching_proc"
set src { int main() { return 0; } }
if { ![gdb_simple_compile $me $src executable] } {
    return 0
}

# Test gdb_caching_procs in gdb/testsuite/lib/*.exp
set files [eval glob -types f $srcdir/lib/*.exp]
foreach file $files {
    test_file $file
}

# Cleanup
remote_file build delete $obj
Commit	Line	Data
42a4f53d	1	# Copyright 2018-2019 Free Software Foundation, Inc.
64d27cfc TV	2
	3	# This program is free software; you can redistribute it and/or modify
	4	# it under the terms of the GNU General Public License as published by
	5	# the Free Software Foundation; either version 3 of the License, or
	6	# (at your option) any later version.
	7	#
	8	# This program is distributed in the hope that it will be useful,
	9	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	# GNU General Public License for more details.
	12	#
	13	# You should have received a copy of the GNU General Public License
	14	# along with this program. If not, see <http://www.gnu.org/licenses/>.
	15
	16	# When caching a proc using gdb_caching_proc, it will become less likely to
	17	# be executed, and consequently it's going to be harder to detect that the
	18	# proc is racy. OTOH, in general the proc is easy to rerun. So, run all
	19	# uncached gdb_caching_procs a number of times and detect inconsistent results.
	20	# The purpose of caching is to reduce runtime, so rerunning is somewhat
	21	# counter-productive in that aspect, but it's better than uncached, because the
	22	# number of reruns is constant-bounded, and the increase in runtime is bound to
	23	# this test-case, and could be disabled on slow targets.
	24
	25	# Test gdb_caching_proc NAME
	26	proc test_proc { name } {
	27	set real_name gdb_real__$name
	28
	29	set resultlist [list]
	30
	31	set first [$real_name]
	32	lappend resultlist $first
	33
	34	# Ten repetitions was enough to trigger target_supports_scheduler_locking,
	35	# and costs about 20 seconds on an i7-6600U.
	36	set repeat 10
	37
	38	set racy 0
	39	for {set i 0} {$i < $repeat} {incr i} {
	40	set rerun [$real_name]
	41	lappend resultlist $rerun
	42	if { $rerun != $first } {
	43	set racy 1
	44	}
	45	}
	46
	47	if { $racy == 0 } {
	48	pass "$name consistency"
	49	} else {
	50	fail "$name consistency"
	51	verbose -log "$name: $resultlist"
	52	}
	53	}
	54
	55	# Test gdb_caching_procs in FILE
	56	proc test_file { file } {
	57	upvar obj obj
	58	set procnames [list]
	59
	60	set fp [open $file]
	61	while { [gets $fp line] >= 0 } {
	62	if [regexp -- "^gdb_caching_proc \[ \t\](\[^ \t\])" $line \
	63	match procname] {
	64	lappend procnames $procname
	65	}
66	}
67	close $fp
68
69	if { [llength $procnames] == 0 } {
70	return
71	}
72
73	if { [file tail $file] == "gdb.exp" } {
74	# Already loaded
75	} else {
76	load_lib [file tail $file]
77	}
78
79	foreach procname $procnames {
80	switch $procname {
81	"is_address_zero_readable" { set setup_gdb 1 }
82	"target_is_gdbserver" { set setup_gdb 1 }
83	default {set setup_gdb 0 }
84	}
85
86	if { $setup_gdb } {
87	clean_restart $obj
88	}
89
90	test_proc $procname
91
92	if { $setup_gdb } {
93	gdb_exit
94	}
95	}
96	}
97
98	# Init
99	set me "gdb_caching_proc"
100	set src { int main() { return 0; } }
101	if { ![gdb_simple_compile $me $src executable] } {
102	return 0
103	}
104
105	# Test gdb_caching_procs in gdb/testsuite/lib/*.exp
106	set files [eval glob -types f $srcdir/lib/*.exp]
107	foreach file $files {
108	test_file $file
109	}
110
111	# Cleanup
112	remote_file build delete $obj