| # Copyright (C) 2013-2014 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/>. |
| |
| namespace eval PerfTest { |
| # The name of python file on build. |
| variable remote_python_file |
| |
| # A private method to set up GDB for performance testing. |
| proc _setup_perftest {} { |
| variable remote_python_file |
| global srcdir subdir testfile |
| |
| set remote_python_file [gdb_remote_download host ${srcdir}/${subdir}/${testfile}.py] |
| |
| # Set sys.path for module perftest. |
| gdb_test_no_output "python import os, sys" |
| gdb_test_no_output "python sys.path.insert\(0, os.path.abspath\(\"${srcdir}/${subdir}/lib\"\)\)" |
| gdb_test_no_output "python exec (open ('${remote_python_file}').read ())" |
| } |
| |
| # A private method to do some cleanups when performance test is |
| # finished. |
| proc _teardown_perftest {} { |
| variable remote_python_file |
| |
| remote_file host delete $remote_python_file |
| } |
| |
| # Compile source files of test case. BODY is the tcl code to do |
| # actual compilation. Return zero if compilation is successful, |
| # otherwise return non-zero. |
| proc compile {body} { |
| global GDB_PERFTEST_MODE |
| |
| if { [info exists GDB_PERFTEST_MODE] |
| && [string compare $GDB_PERFTEST_MODE "run"] } { |
| return [uplevel 2 $body] |
| } |
| |
| return 0 |
| } |
| |
| # Start up GDB. |
| proc startup_gdb {body} { |
| uplevel 2 $body |
| } |
| |
| # Run the performance test. |
| proc run {body} { |
| global timeout |
| global GDB_PERFTEST_TIMEOUT |
| |
| set oldtimeout $timeout |
| if { [info exists GDB_PERFTEST_TIMEOUT] } { |
| set timeout $GDB_PERFTEST_TIMEOUT |
| } else { |
| set timeout 3000 |
| } |
| uplevel 2 $body |
| |
| set timeout $oldtimeout |
| } |
| |
| # The top-level interface to PerfTest. |
| # COMPILE is the tcl code to generate and compile source files. |
| # Return zero if compilation is successful, otherwise return |
| # non-zero. |
| # STARTUP is the tcl code to start up GDB. |
| # RUN is the tcl code to drive GDB to do some operations. |
| proc assemble {compile startup run} { |
| global GDB_PERFTEST_MODE |
| |
| if { [eval compile {$compile}] } { |
| untested "Could not compile source files." |
| return |
| } |
| |
| # Don't execute the run if GDB_PERFTEST_MODE=compile. |
| if { [info exists GDB_PERFTEST_MODE] |
| && [string compare $GDB_PERFTEST_MODE "compile"] == 0} { |
| return |
| } |
| |
| eval $startup |
| |
| _setup_perftest |
| |
| eval run {$run} |
| |
| _teardown_perftest |
| } |
| } |
| |
| # Return true if performance tests are skipped. |
| |
| proc skip_perf_tests { } { |
| global GDB_PERFTEST_MODE |
| |
| if [info exists GDB_PERFTEST_MODE] { |
| |
| if { "$GDB_PERFTEST_MODE" != "compile" |
| && "$GDB_PERFTEST_MODE" != "run" |
| && "$GDB_PERFTEST_MODE" != "both" } { |
| # GDB_PERFTEST_MODE=compile|run|both is allowed. |
| error "Unknown value of GDB_PERFTEST_MODE." |
| return 1 |
| } |
| |
| return 0 |
| } |
| |
| return 1 |
| } |