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