1 # Copyright (C) 2001-2023 Free Software Foundation, Inc.
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.
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.
13 # You should have received a copy of the GNU General Public License
14 # along with GCC; see the file COPYING3. If not see
15 # <http://www.gnu.org/licenses/>.
17 load_lib target-libpath.exp
21 load_lib target-utils.exp
24 # ${tool}_check_compile -- Reports and returns pass/fail for a compilation
27 proc ${tool}_check_compile {testcase option objname gcc_output} {
29 set fatal_signal "*cc: Internal compiler error: program*got fatal signal"
31 if [string match "$fatal_signal 6" $gcc_output] then {
32 ${tool}_fail $testcase "Got Signal 6, $option"
36 if [string match "$fatal_signal 11" $gcc_output] then {
37 ${tool}_fail $testcase "Got Signal 11, $option"
41 if [regexp -line -- "internal compiler error.*" $gcc_output ice] then {
42 ${tool}_fail $testcase "$option ($ice)"
46 # We shouldn't get these because of -w, but just in case.
47 if [string match "*cc:*warning:*" $gcc_output] then {
48 warning "$testcase: (with warnings) $option"
49 send_log "$gcc_output\n"
50 unresolved "$testcase, $option"
54 set gcc_output [prune_warnings $gcc_output]
56 if { [info proc ${tool}-dg-prune] != "" } {
58 set gcc_output [${tool}-dg-prune $target_triplet $gcc_output]
59 if [string match "*::unsupported::*" $gcc_output] then {
60 regsub -- "::unsupported::" $gcc_output "" gcc_output
61 unsupported "$testcase: $gcc_output"
65 set unsupported_message [${tool}_check_unsupported_p $gcc_output]
66 if { $unsupported_message != "" } {
67 unsupported "$testcase: $unsupported_message"
72 # remove any leftover LF/CR to make sure any output is legit
73 regsub -all -- "\[\r\n\]*" $gcc_output "" gcc_output
75 # If any message remains, we fail.
76 if ![string match "" $gcc_output] then {
77 ${tool}_fail $testcase $option
81 # fail if the desired object file doesn't exist.
82 # FIXME: there's no way of checking for existence on a remote host.
83 if {$objname != "" && ![is3way] && ![file exists $objname]} {
84 ${tool}_fail $testcase $option
88 ${tool}_pass $testcase $option
93 # ${tool}_pass -- utility to record a testcase passed
96 proc ${tool}_pass { testcase cflags } {
97 if { "$cflags" == "" } {
100 pass "$testcase, $cflags"
105 # ${tool}_fail -- utility to record a testcase failed
108 proc ${tool}_fail { testcase cflags } {
109 if { "$cflags" == "" } {
112 fail "$testcase, $cflags"
117 # ${tool}_finish -- called at the end of every script that calls ${tool}_init
119 # Hide all quirks of the testing environment from the testsuites. Also
120 # undo anything that ${tool}_init did that needs undoing.
123 proc ${tool}_finish { } {
124 # The testing harness apparently requires this.
127 if [info exists errorInfo] then {
131 # Might as well reset these (keeps our caller from wondering whether
132 # s/he has to or not).
133 global prms_id bug_id
139 # ${tool}_exit -- Does final cleanup when testing is complete
142 proc ${tool}_exit { } {
145 if [info exists gluefile] {
146 file_on_build delete $gluefile
152 # runtest_file_p -- Provide a definition for older dejagnu releases
153 # and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
154 # (delete after next dejagnu release).
157 if { [info procs runtest_file_p] == "" } then {
158 proc runtest_file_p { runtests testcase } {
159 if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
160 if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
170 if { [info exists env(GCC_RUNTEST_PARALLELIZE_DIR)] \
171 && [info procs runtest_file_p] != [list] \
172 && [info procs gcc_parallelize_saved_runtest_file_p] == [list] } then {
173 global gcc_runtest_parallelize_counter
174 global gcc_runtest_parallelize_counter_minor
175 global gcc_runtest_parallelize_enable
176 global gcc_runtest_parallelize_dir
177 global gcc_runtest_parallelize_last
179 # GCC testsuite is parallelised by starting N runtest processes -- each
180 # with its own test directory. These N runtest processes ALL go through
181 # the relevant .exp and ALL attempt to run every test. And they go
182 # through the tests the same order -- this is important, and if there is
183 # a bug that causes different runtest processes to enumerate the tests
184 # differently, then things will break and some tests will be skipped, while
185 # others will be ran several times.
186 # So, just before a runtest processes runs a specific test it asks
187 # "runtest_file_p" routine whether a particular test is part of
188 # the requested testsuite. We override this function so that it
189 # returns "yes" to the first-arrived runtest process, and "no" to all
190 # subsequent runtest processes -- this is implemented by creating a marker
191 # file, which persist till the end of the test run. We optimize this
192 # a bit by batching 10 tests and using a single marker file for the batch.
194 # Note that the runtest processes all race each other to get to the next
195 # test batch. This means that batch allocation between testsuite runs
196 # is very likely to change.
198 # To confirm or deny suspicion that tests are skipped or executed
199 # multiple times due to runtest processes enumerating tests differently ...
200 # 1. Uncomment the three below "verbose -log gcc_parallel_test_run_p ..."
202 # 2. Run the testsuite with "-v" added to RUNTESTFLAGS
203 # 3. Extract debug print-outs with something like:
204 # for i in $(find -name "*.log.sep"); do
205 # grep gcc_parallel_test_run_p $i \
206 # | sed -e "s/\([^ ]*\) \([^ ]*\) \([^ ]*\) \([^ ]*\)/\3 \2/" \
207 # | sed -e "s#\(/testsuite/[a-z+]*\)[0-9]*/#\1N/#" > $i.order
209 # 4. Compare debug print-outs produced by individual runtest processes:
210 # find -name "*.log.sep.order" | xargs md5sum | sort
211 # 5. Check that MD5 hashes of all .order files of the same testsuite match
212 # and investigate if they don't.
213 set gcc_runtest_parallelize_counter 0
214 set gcc_runtest_parallelize_counter_minor 0
215 set gcc_runtest_parallelize_enable 1
216 set gcc_runtest_parallelize_dir [getenv GCC_RUNTEST_PARALLELIZE_DIR]
217 set gcc_runtest_parallelize_last 0
219 proc gcc_parallel_test_run_p { testcase } {
220 global gcc_runtest_parallelize_counter
221 global gcc_runtest_parallelize_counter_minor
222 global gcc_runtest_parallelize_enable
223 global gcc_runtest_parallelize_dir
224 global gcc_runtest_parallelize_last
226 if { $gcc_runtest_parallelize_enable == 0 } {
230 # Only test the filesystem every 10th iteration
231 incr gcc_runtest_parallelize_counter_minor
232 if { $gcc_runtest_parallelize_counter_minor == 10 } {
233 set gcc_runtest_parallelize_counter_minor 0
235 if { $gcc_runtest_parallelize_counter_minor != 1 } {
236 #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter $gcc_runtest_parallelize_last"
237 return $gcc_runtest_parallelize_last
240 set path $gcc_runtest_parallelize_dir/$gcc_runtest_parallelize_counter
242 if {![catch {open $path {RDWR CREAT EXCL} 0600} fd]} {
244 set gcc_runtest_parallelize_last 1
245 #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 1"
246 incr gcc_runtest_parallelize_counter
249 set gcc_runtest_parallelize_last 0
250 #verbose -log "gcc_parallel_test_run_p $testcase $gcc_runtest_parallelize_counter 0"
251 incr gcc_runtest_parallelize_counter
255 proc gcc_parallel_test_enable { val } {
256 global gcc_runtest_parallelize_enable
257 set gcc_runtest_parallelize_enable $val
260 rename runtest_file_p gcc_parallelize_saved_runtest_file_p
261 proc runtest_file_p { runtests testcase } {
262 if ![gcc_parallelize_saved_runtest_file_p $runtests $testcase] {
265 return [gcc_parallel_test_run_p $testcase]
270 proc gcc_parallel_test_run_p { testcase } {
274 proc gcc_parallel_test_enable { val } {
279 # Like dg-options, but adds to the default options rather than replacing them.
281 proc dg-additional-options { args } {
282 upvar dg-extra-tool-flags extra-tool-flags
284 if { [llength $args] > 3 } {
285 error "[lindex $args 0]: too many arguments"
289 if { [llength $args] >= 3 } {
290 switch [dg-process-target [lindex $args 2]] {
291 "S" { eval lappend extra-tool-flags [lindex $args 1] }
293 "F" { error "[lindex $args 0]: `xfail' not allowed here" }
294 "P" { error "[lindex $args 0]: `xfail' not allowed here" }
297 eval lappend extra-tool-flags [lindex $args 1]
301 # Record additional sources files that must be compiled along with the
304 set additional_sources ""
305 set additional_sources_used ""
307 proc dg-additional-sources { args } {
308 global additional_sources
309 set additional_sources [lindex $args 1]
312 # Record additional files -- other than source files -- that must be
313 # present on the system where the compiler runs.
315 set additional_files ""
317 proc dg-additional-files { args } {
318 global additional_files
319 set additional_files [lindex $args 1]
322 set gcc_adjusted_linker_flags 0
324 # Add -Wl, before any file names in $opts. Return the modified list.
326 proc gcc_adjust_linker_flags_list { args } {
327 set opts [lindex $args 0]
330 foreach opt [split $opts " "] {
331 if { $opt == "" } then {
333 } elseif { $skip != "" } then {
335 } elseif { $opt == "-Xlinker" || $opt == "-T" } then {
337 } elseif { ![string match "-*" $opt] \
338 && [file isfile $opt] } {
346 # Add -Wl, before any file names in the target board's ldflags, libs,
347 # and ldscript, as well as in global testglue and wrap_flags, so that
348 # default object files or libraries do not change the names of gcc
351 proc gcc_adjust_linker_flags {} {
352 global gcc_adjusted_linker_flags
353 if {$gcc_adjusted_linker_flags} {
356 set gcc_adjusted_linker_flags 1
358 if {![is_remote host]} {
359 set dest [target_info name]
360 foreach i { ldflags libs ldscript } {
361 if {[board_info $dest exists $i]} {
362 set opts [board_info $dest $i]
363 set nopts [gcc_adjust_linker_flags_list $opts]
364 if { $nopts != $opts } {
365 unset_currtarget_info $i
366 set_currtarget_info $i "$nopts"
370 foreach i { gluefile wrap_flags } {
372 if {[info exists $i]} {
374 set nopts [gcc_adjust_linker_flags_list $opts]
375 if { $nopts != $opts } {
383 # Return an updated version of OPTIONS that mentions any additional
384 # source files registered with dg-additional-sources. SOURCE is the
385 # name of the test case.
387 proc dg-additional-files-options { options source } {
388 gcc_adjust_linker_flags
390 global additional_sources
391 global additional_sources_used
392 global additional_files
393 set to_download [list]
394 if { $additional_sources != "" } then {
395 if [is_remote host] {
396 lappend options "additional_flags=$additional_sources"
398 regsub -all "^| " $additional_sources " [file dirname $source]/" additional_sources
399 if ![is_remote host] {
400 lappend options "additional_flags=$additional_sources"
402 set to_download [concat $to_download $additional_sources]
403 set additional_sources_used "$additional_sources"
404 set additional_sources ""
405 # This option restores naming of aux and dump output files
406 # after input files when multiple input files are named,
407 # instead of getting them combined with the output name.
408 lappend options "additional_flags=-dumpbase \"\""
410 if { $additional_files != "" } then {
411 regsub -all "^| " $additional_files " [file dirname $source]/" additional_files
412 set to_download [concat $to_download $additional_files]
413 set additional_files ""
415 if [is_remote host] {
416 foreach file $to_download {
417 remote_download host $file
424 # Return a colon-separate list of directories to search for libraries
425 # for COMPILER, including multilib directories.
427 proc gcc-set-multilib-library-path { compiler } {
428 set shlib_ext [get_shlib_extension]
429 set options [lrange $compiler 1 end]
430 set compiler [lindex $compiler 0]
432 set libgcc_s_x [remote_exec host "$compiler" \
433 "$options -print-file-name=libgcc_s.${shlib_ext}"]
434 if { [lindex $libgcc_s_x 0] == 0 \
435 && [set libgcc_s_dir [file dirname [lindex $libgcc_s_x 1]]] != "" } {
436 set libpath ":${libgcc_s_dir}"
441 set multi_dir_x [remote_exec host "$compiler" \
442 "$options -print-multi-directory"]
443 set multi_lib_x [remote_exec host "$compiler" \
444 "$options -print-multi-lib"]
445 if { [lindex $multi_dir_x 0] == 0 && [lindex $multi_lib_x 0] == 0 } {
446 set multi_dir [string trim [lindex $multi_dir_x 1]]
447 set multi_lib [string trim [lindex $multi_lib_x 1]]
448 if { "$multi_dir" == "." } {
449 set multi_root "$libgcc_s_dir"
451 set multi_match [string last "/$multi_dir" "$libgcc_s_dir"]
452 if { "$multi_match" < 0 } {
455 set multi_root [string range "$libgcc_s_dir" \
456 0 [expr $multi_match - 1]]
458 foreach i "$multi_lib" {
460 regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir
461 set mldir [string trimright $mldir "\;@"]
462 if { "$mldir" == "$multi_dir" } {
465 append libpath ":${multi_root}/${mldir}"
472 # A list of all uses of dg-regexp, each entry of the form:
474 # This is cleared at the end of each test by gcc-dg.exp's wrapper for dg-test.
475 set freeform_regexps []
477 # Directive for looking for a regexp, without any line numbers or other
480 proc dg-regexp { args } {
481 verbose "dg-regexp: args: $args" 2
483 global freeform_regexps
484 lappend freeform_regexps $args
487 # Hook to be called by prune.exp's prune_gcc_output to
488 # look for the expected dg-regexp expressions, pruning them,
489 # reporting PASS for those that are found, and FAIL for
490 # those that weren't found.
492 # It returns a pruned version of its output.
494 proc handle-dg-regexps { text } {
495 global freeform_regexps
496 global testname_with_flags
498 foreach entry $freeform_regexps {
499 verbose " entry: $entry" 3
501 set linenum [lindex $entry 0]
502 set rexp [lindex $entry 1]
504 # Escape newlines in $rexp so that we can print them in
506 set escaped_regex [string map {"\n" "\\n"} $rexp]
507 verbose "escaped_regex: ${escaped_regex}" 4
509 set title "$testname_with_flags dg-regexp $linenum"
511 # Use "regsub" to attempt to prune the pattern from $text
512 if {[regsub -line $rexp $text "" text]} {
513 # Success; the multiline pattern was pruned.
514 pass "$title was found: \"$escaped_regex\""
516 fail "$title not found: \"$escaped_regex\""
523 # Verify that the initial arg is a valid .dot file
524 # (by running dot -Tpng on it, and verifying the exit code is 0).
526 proc dg-check-dot { args } {
527 verbose "dg-check-dot: args: $args" 2
529 set testcase [testname-for-summary]
531 set dotfile [lindex $args 0]
532 verbose " dotfile: $dotfile" 2
534 set status [remote_exec host "dot" "-O -Tpng $dotfile"]
535 verbose " status: $status" 2
536 if { [lindex $status 0] != 0 } {
537 fail "$testcase dg-check-dot $dotfile"
541 pass "$testcase dg-check-dot $dotfile"
544 # Used by aarch64-with-arch-dg-options to intercept dg-options and make
545 # the changes required. See there for details.
546 proc aarch64-arch-dg-options { args } {
547 upvar dg-do-what do_what
548 global aarch64_default_testing_arch
552 set checks_output [string equal [lindex $do_what 0] "compile"]
553 set options [lindex $args 1]
555 foreach option [split $options] {
556 switch -glob -- $option {
557 -march=* { set add_arch 0 }
558 -mcpu=* { set add_arch 0; set add_tune 0 }
559 -mtune=* { set add_tune 0 }
560 -moverride=* { set add_tune 0 }
561 -save-temps { set checks_output 1 }
562 --save-temps { set checks_output 1 }
563 -fdump* { set checks_output 1 }
567 if { $add_arch && ![string equal $aarch64_default_testing_arch ""] } {
568 # Force SVE if we're not testing it already.
569 append options " $aarch64_default_testing_arch"
572 if { $add_tune && $checks_output } {
573 # Turn off any default tuning and codegen tweaks.
574 append options " -mtune=generic -moverride=tune=none"
577 uplevel 1 aarch64-old-dg-options [lreplace $args 1 1 $options]
580 # Run Tcl code CODE with dg-options modified to work better for some
581 # AArch64 tests. In particular:
583 # - If the dg-options do not specify an -march or -mcpu option,
584 # use the architecture options in ARCH (which might be empty).
586 # - If the dg-options do not specify an -mcpu, -mtune or -moverride option,
587 # and if the test appears to be checking assembly or dump output,
588 # force the test to use generic tuning.
590 # The idea is to handle toolchains that are configured with a default
591 # CPU or architecture that's different from the norm.
592 proc aarch64-with-arch-dg-options { arch code } {
593 global aarch64_default_testing_arch
595 set aarch64_default_testing_arch $arch
597 rename dg-options aarch64-old-dg-options
598 rename aarch64-arch-dg-options dg-options
602 rename dg-options aarch64-arch-dg-options
603 rename aarch64-old-dg-options dg-options