1# Copyright (C) 2013-2021 Free Software Foundation, Inc.
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
16namespace eval PerfTest {
17    # The name of python file on build.
18    variable remote_python_file
19
20    # A private method to set up GDB for performance testing.
21    proc _setup_perftest {} {
22	variable remote_python_file
23	global srcdir subdir testfile
24
25	set remote_python_file [gdb_remote_download host ${srcdir}/${subdir}/${testfile}.py]
26
27	# Set sys.path for module perftest.
28	gdb_test_no_output "python import os, sys"
29	gdb_test_no_output "python sys.path.insert\(0, os.path.abspath\(\"${srcdir}/${subdir}/lib\"\)\)"
30	gdb_test_no_output "python exec (open ('${remote_python_file}').read ())"
31    }
32
33    # A private method to do some cleanups when performance test is
34    # finished.
35    proc _teardown_perftest {} {
36	variable remote_python_file
37
38	remote_file host delete $remote_python_file
39    }
40
41    # Compile source files of test case.  BODY is the tcl code to do
42    # actual compilation.  Return zero if compilation is successful,
43    # otherwise return non-zero.
44    proc compile {body} {
45	return [uplevel 2 $body]
46    }
47
48    # Run the startup code.  Return zero if startup is successful,
49    # otherwise return non-zero.
50    proc startup {body} {
51	return [uplevel 2 $body]
52    }
53
54    # Start up GDB.
55    proc startup_gdb {body} {
56	uplevel 2 $body
57    }
58
59    # Run the performance test.  Return zero if the run is successful,
60    # otherwise return non-zero.
61    proc run {body} {
62	global timeout
63	global GDB_PERFTEST_TIMEOUT
64
65	set oldtimeout $timeout
66	if { [info exists GDB_PERFTEST_TIMEOUT] } {
67	    set timeout $GDB_PERFTEST_TIMEOUT
68	} else {
69	    set timeout 3000
70	}
71	set result [uplevel 2 $body]
72
73	set timeout $oldtimeout
74	return $result
75    }
76
77    # The top-level interface to PerfTest.
78    # COMPILE is the tcl code to generate and compile source files.
79    # STARTUP is the tcl code to start up GDB.
80    # RUN is the tcl code to drive GDB to do some operations.
81    # Each of COMPILE, STARTUP, and RUN return zero if successful, and
82    # non-zero if there's a failure.
83
84    proc assemble {compile startup run} {
85	global GDB_PERFTEST_MODE
86
87	if ![info exists GDB_PERFTEST_MODE] {
88	    return
89	}
90
91	if { [string compare $GDB_PERFTEST_MODE "run"] != 0 } {
92	    if { [eval compile {$compile}] } {
93		untested "failed to compile"
94		return
95	    }
96	}
97
98	# Don't execute the run if GDB_PERFTEST_MODE=compile.
99	if { [string compare $GDB_PERFTEST_MODE "compile"] == 0} {
100	    return
101	}
102
103	verbose -log "PerfTest::assemble, startup ..."
104
105	if [eval startup {$startup}] {
106	    fail "startup"
107	    return
108	}
109
110	verbose -log "PerfTest::assemble, done startup"
111
112	_setup_perftest
113
114	verbose -log "PerfTest::assemble, run ..."
115
116	if [eval run {$run}] {
117	    fail "run"
118	}
119
120	verbose -log "PerfTest::assemble, run complete."
121
122	_teardown_perftest
123    }
124}
125
126# Return true if performance tests are skipped.
127
128proc skip_perf_tests { } {
129    global GDB_PERFTEST_MODE
130
131    if [info exists GDB_PERFTEST_MODE] {
132	if { "$GDB_PERFTEST_MODE" != "compile"
133	     && "$GDB_PERFTEST_MODE" != "run"
134	     && "$GDB_PERFTEST_MODE" != "both" } {
135	    error "Unknown value of GDB_PERFTEST_MODE."
136	    return 1
137	}
138
139	return 0
140    }
141
142    return 1
143}
144
145# Given a list of tcl strings, return the same list as the text form of a
146# python list.
147
148proc tcl_string_list_to_python_list { l } {
149    proc quote { text } {
150	return "\"$text\""
151    }
152    set quoted_list ""
153    foreach elm $l {
154	lappend quoted_list [quote $elm]
155    }
156    return "([join $quoted_list {, }])"
157}
158