1# Copyright (C) 2003, 2005, 2008, 2009, 2010, 2011, 2014, 2019 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; see the file COPYING3. If not see 15# <http://www.gnu.org/licenses/>. 16 17proc load_gcc_lib { filename } { 18 global srcdir 19 load_file $srcdir/lib/$filename 20} 21 22load_lib dg.exp 23load_lib libgloss.exp 24load_gcc_lib target-libpath.exp 25load_gcc_lib wrapper.exp 26 27# Return 1 if the target matches the effective target 'arg', 0 otherwise. 28# This can be used with any check_* proc that takes no argument and 29# returns only 1 or 0. It could be used with check_* procs that take 30# arguments with keywords that pass particular arguments. 31 32proc is-effective-target { arg } { 33 global et_index 34 set selected 0 35 if { ![info exists et_index] } { 36 # Initialize the effective target index that is used in some 37 # check_effective_target_* procs. 38 set et_index 0 39 } 40 if { [info procs check_effective_target_${arg}] != [list] } { 41 set selected [check_effective_target_${arg}] 42 } else { 43 error "unknown effective target keyword `$arg'" 44 } 45 verbose "is-effective-target: $arg $selected" 2 46 return $selected 47} 48 49proc is-effective-target-keyword { arg } { 50 if { [info procs check_effective_target_${arg}] != [list] } { 51 return 1 52 } else { 53 return 0 54 } 55} 56 57# Intercept the call to the DejaGnu version of dg-process-target to 58# support use of an effective-target keyword in place of a list of 59# target triplets to xfail or skip a test. 60# 61# The argument to dg-process-target is the keyword "target" or "xfail" 62# followed by a selector: 63# target-triplet-1 ... 64# effective-target-keyword 65# selector-expression 66# 67# For a target list the result is "S" if the target is selected, "N" otherwise. 68# For an xfail list the result is "F" if the target is affected, "P" otherwise. 69 70# In contexts that allow either "target" or "xfail" the argument can be 71# target selector1 xfail selector2 72# which returns "N" if selector1 is not selected, otherwise the result of 73# "xfail selector2". 74# 75# A selector expression appears within curly braces and uses a single logical 76# operator: !, &&, or ||. An operand is another selector expression, an 77# effective-target keyword, or a list of target triplets within quotes or 78# curly braces. 79 80if { [info procs saved-dg-process-target] == [list] } { 81 rename dg-process-target saved-dg-process-target 82 83 # Evaluate an operand within a selector expression. 84 proc selector_opd { op } { 85 set selector "target" 86 lappend selector $op 87 set answer [ expr { [dg-process-target $selector] == "S" } ] 88 verbose "selector_opd: `$op' $answer" 2 89 return $answer 90 } 91 92 # Evaluate a target triplet list within a selector expression. 93 # Unlike other operands, this needs to be expanded from a list to 94 # the same string as "target". 95 proc selector_list { op } { 96 set selector "target [join $op]" 97 set answer [ expr { [dg-process-target $selector] == "S" } ] 98 verbose "selector_list: `$op' $answer" 2 99 return $answer 100 } 101 102 # Evaluate a selector expression. 103 proc selector_expression { exp } { 104 if { [llength $exp] == 2 } { 105 if [string match "!" [lindex $exp 0]] { 106 set op1 [lindex $exp 1] 107 set answer [expr { ! [selector_opd $op1] }] 108 } else { 109 # Assume it's a list of target triplets. 110 set answer [selector_list $exp] 111 } 112 } elseif { [llength $exp] == 3 } { 113 set op1 [lindex $exp 0] 114 set opr [lindex $exp 1] 115 set op2 [lindex $exp 2] 116 if [string match "&&" $opr] { 117 set answer [expr { [selector_opd $op1] && [selector_opd $op2] }] 118 } elseif [string match "||" $opr] { 119 set answer [expr { [selector_opd $op1] || [selector_opd $op2] }] 120 } else { 121 # Assume it's a list of target triplets. 122 set answer [selector_list $exp] 123 } 124 } else { 125 # Assume it's a list of target triplets. 126 set answer [selector_list $exp] 127 } 128 129 verbose "selector_expression: `$exp' $answer" 2 130 return $answer 131 } 132 133 # Evaluate "target selector" or "xfail selector". 134 135 proc dg-process-target-1 { args } { 136 verbose "dg-process-target-1: `$args'" 2 137 138 # Extract the 'what' keyword from the argument list. 139 set selector [string trim [lindex $args 0]] 140 if [regexp "^xfail " $selector] { 141 set what "xfail" 142 } elseif [regexp "^target " $selector] { 143 set what "target" 144 } else { 145 error "syntax error in target selector \"$selector\"" 146 } 147 148 # Extract the rest of the list, which might be a keyword. 149 regsub "^${what}" $selector "" rest 150 set rest [string trim $rest] 151 152 if [is-effective-target-keyword $rest] { 153 # The selector is an effective target keyword. 154 if [is-effective-target $rest] { 155 return [expr { $what == "xfail" ? "F" : "S" }] 156 } else { 157 return [expr { $what == "xfail" ? "P" : "N" }] 158 } 159 } 160 161 if [string match "{*}" $rest] { 162 if [selector_expression [lindex $rest 0]] { 163 return [expr { $what == "xfail" ? "F" : "S" }] 164 } else { 165 return [expr { $what == "xfail" ? "P" : "N" }] 166 } 167 } 168 169 # The selector is not an effective-target keyword, so process 170 # the list of target triplets. 171 return [saved-dg-process-target $selector] 172 } 173 174 # Intercept calls to the DejaGnu function. In addition to 175 # processing "target selector" or "xfail selector", handle 176 # "target selector1 xfail selector2". 177 178 proc dg-process-target { args } { 179 verbose "replacement dg-process-target: `$args'" 2 180 181 set selector [string trim [lindex $args 0]] 182 183 # If the argument list contains both 'target' and 'xfail', 184 # process 'target' and, if that succeeds, process 'xfail'. 185 if [regexp "^target .* xfail .*" $selector] { 186 set xfail_index [string first "xfail" $selector] 187 set xfail_selector [string range $selector $xfail_index end] 188 set target_selector [string range $selector 0 [expr $xfail_index-1]] 189 set target_selector [string trim $target_selector] 190 if { [dg-process-target-1 $target_selector] == "N" } { 191 return "N" 192 } 193 return [dg-process-target-1 $xfail_selector] 194 195 } 196 return [dg-process-target-1 $selector] 197 } 198} 199 200# Define libffi callbacks for dg.exp. 201 202proc libffi-dg-test-1 { target_compile prog do_what extra_tool_flags } { 203 204 # To get all \n in dg-output test strings to match printf output 205 # in a system that outputs it as \015\012 (i.e. not just \012), we 206 # need to change all \n into \r?\n. As there is no dejagnu flag 207 # or hook to do that, we simply change the text being tested. 208 # Unfortunately, we have to know that the variable is called 209 # dg-output-text and lives in the caller of libffi-dg-test, which 210 # is two calls up. Overriding proc dg-output would be longer and 211 # would necessarily have the same assumption. 212 upvar 2 dg-output-text output_match 213 214 if { [llength $output_match] > 1 } { 215 regsub -all "\n" [lindex $output_match 1] "\r?\n" x 216 set output_match [lreplace $output_match 1 1 $x] 217 } 218 219 # Set up the compiler flags, based on what we're going to do. 220 221 set options [list] 222 switch $do_what { 223 "compile" { 224 set compile_type "assembly" 225 set output_file "[file rootname [file tail $prog]].s" 226 } 227 "link" { 228 set compile_type "executable" 229 set output_file "[file rootname [file tail $prog]].exe" 230 # The following line is needed for targets like the i960 where 231 # the default output file is b.out. Sigh. 232 } 233 "run" { 234 set compile_type "executable" 235 # FIXME: "./" is to cope with "." not being in $PATH. 236 # Should this be handled elsewhere? 237 # YES. 238 set output_file "./[file rootname [file tail $prog]].exe" 239 # This is the only place where we care if an executable was 240 # created or not. If it was, dg.exp will try to run it. 241 remote_file build delete $output_file; 242 } 243 default { 244 perror "$do_what: not a valid dg-do keyword" 245 return "" 246 } 247 } 248 249 if { $extra_tool_flags != "" } { 250 lappend options "additional_flags=$extra_tool_flags" 251 } 252 253 set comp_output [libffi_target_compile "$prog" "$output_file" "$compile_type" $options]; 254 255 256 return [list $comp_output $output_file] 257} 258 259 260proc libffi-dg-test { prog do_what extra_tool_flags } { 261 return [libffi-dg-test-1 target_compile $prog $do_what $extra_tool_flags] 262} 263 264proc libffi-dg-prune { target_triplet text } { 265 # We get this with some qemu emulated systems (eg. ppc64le-linux-gnu) 266 regsub -all "(^|\n)\[^\n\]*unable to perform all requested operations" $text "" text 267 return $text 268} 269 270proc libffi-init { args } { 271 global gluefile wrap_flags; 272 global srcdir 273 global blddirffi 274 global objdir 275 global TOOL_OPTIONS 276 global tool 277 global libffi_include 278 global libffi_link_flags 279 global tool_root_dir 280 global ld_library_path 281 global compiler_vendor 282 283 if ![info exists blddirffi] { 284 set blddirffi [pwd]/.. 285 } 286 287 verbose "libffi $blddirffi" 288 289 # Which compiler are we building with? 290 set tmp [grep "$blddirffi/config.log" "^ax_cv_c_compiler_vendor.*$"] 291 regexp -- {^[^=]*=(.*)$} $tmp nil compiler_vendor 292 293 if { [string match $compiler_vendor "gnu"] } { 294 set gccdir [lookfor_file $tool_root_dir gcc/libgcc.a] 295 if {$gccdir != ""} { 296 set gccdir [file dirname $gccdir] 297 } 298 verbose "gccdir $gccdir" 299 300 set ld_library_path "." 301 append ld_library_path ":${gccdir}" 302 303 set compiler "${gccdir}/xgcc" 304 if { [is_remote host] == 0 && [which $compiler] != 0 } { 305 foreach i "[exec $compiler --print-multi-lib]" { 306 set mldir "" 307 regexp -- "\[a-z0-9=_/\.-\]*;" $i mldir 308 set mldir [string trimright $mldir "\;@"] 309 if { "$mldir" == "." } { 310 continue 311 } 312 if { [llength [glob -nocomplain ${gccdir}/${mldir}/libgcc_s*.so.*]] >= 1 } { 313 append ld_library_path ":${gccdir}/${mldir}" 314 } 315 } 316 } 317 } 318 319 # add the library path for libffi. 320 append ld_library_path ":${blddirffi}/.libs" 321 322 verbose "ld_library_path: $ld_library_path" 323 324 # Point to the Libffi headers in libffi. 325 set libffi_include "${blddirffi}/include" 326 verbose "libffi_include $libffi_include" 327 328 set libffi_dir "${blddirffi}/.libs" 329 verbose "libffi_dir $libffi_dir" 330 if { $libffi_dir != "" } { 331 set libffi_dir [file dirname ${libffi_dir}] 332 set libffi_link_flags "-L${libffi_dir}/.libs" 333 } 334 335 set_ld_library_path_env_vars 336 libffi_maybe_build_wrapper "${objdir}/testglue.o" 337} 338 339proc libffi_exit { } { 340 global gluefile; 341 342 if [info exists gluefile] { 343 file_on_build delete $gluefile; 344 unset gluefile; 345 } 346} 347 348proc libffi_target_compile { source dest type options } { 349 global gluefile wrap_flags; 350 global srcdir 351 global blddirffi 352 global TOOL_OPTIONS 353 global libffi_link_flags 354 global libffi_include 355 global target_triplet 356 global compiler_vendor 357 358 if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } { 359 lappend options "libs=${gluefile}" 360 lappend options "ldflags=$wrap_flags" 361 } 362 363 # TOOL_OPTIONS must come first, so that it doesn't override testcase 364 # specific options. 365 if [info exists TOOL_OPTIONS] { 366 lappend options "additional_flags=$TOOL_OPTIONS" 367 } 368 369 # search for ffi_mips.h in srcdir, too 370 lappend options "additional_flags=-I${libffi_include} -I${srcdir}/../include -I${libffi_include}/.." 371 lappend options "additional_flags=${libffi_link_flags}" 372 373 # Darwin needs a stack execution allowed flag. 374 375 if { [istarget "*-*-darwin9*"] || [istarget "*-*-darwin1*"] 376 || [istarget "*-*-darwin2*"] } { 377 lappend options "additional_flags=-Wl,-allow_stack_execute" 378 } 379 380 # If you're building the compiler with --prefix set to a place 381 # where it's not yet installed, then the linker won't be able to 382 # find the libgcc used by libffi.dylib. We could pass the 383 # -dylib_file option, but that's complicated, and it's much easier 384 # to just make the linker find libgcc using -L options. 385 if { [string match "*-*-darwin*" $target_triplet] } { 386 lappend options "libs= -shared-libgcc" 387 } 388 389 if { [string match "*-*-openbsd*" $target_triplet] } { 390 lappend options "libs= -lpthread" 391 } 392 393 lappend options "libs= -lffi" 394 395 if { [string match "aarch64*-*-linux*" $target_triplet] } { 396 lappend options "libs= -lpthread" 397 } 398 399 # this may be required for g++, but just confused clang. 400 if { [string match "*.cc" $source] } { 401 lappend options "c++" 402 } 403 404 if { [string match "arc*-*-linux*" $target_triplet] } { 405 lappend options "libs= -lpthread" 406 } 407 408 verbose "options: $options" 409 return [target_compile $source $dest $type $options] 410} 411 412# TEST should be a preprocessor condition. Returns true if it holds. 413proc libffi_feature_test { test } { 414 set src "ffitest[pid].c" 415 416 set f [open $src "w"] 417 puts $f "#include <ffi.h>" 418 puts $f $test 419 puts $f "/* OK */" 420 puts $f "#else" 421 puts $f "# error Failed $test" 422 puts $f "#endif" 423 close $f 424 425 set lines [libffi_target_compile $src /dev/null assembly ""] 426 file delete $src 427 428 return [string match "" $lines] 429} 430 431# Utility routines. 432 433# 434# search_for -- looks for a string match in a file 435# 436proc search_for { file pattern } { 437 set fd [open $file r] 438 while { [gets $fd cur_line]>=0 } { 439 if [string match "*$pattern*" $cur_line] then { 440 close $fd 441 return 1 442 } 443 } 444 close $fd 445 return 0 446} 447 448# Modified dg-runtest that can cycle through a list of optimization options 449# as c-torture does. 450proc libffi-dg-runtest { testcases default-extra-flags } { 451 global runtests 452 453 foreach test $testcases { 454 # If we're only testing specific files and this isn't one of 455 # them, skip it. 456 if ![runtest_file_p $runtests $test] { 457 continue 458 } 459 460 # Look for a loop within the source code - if we don't find one, 461 # don't pass -funroll[-all]-loops. 462 global torture_with_loops torture_without_loops 463 if [expr [search_for $test "for*("]+[search_for $test "while*("]] { 464 set option_list $torture_with_loops 465 } else { 466 set option_list $torture_without_loops 467 } 468 469 set nshort [file tail [file dirname $test]]/[file tail $test] 470 471 foreach flags $option_list { 472 verbose "Testing $nshort, $flags" 1 473 dg-test $test $flags ${default-extra-flags} 474 } 475 } 476} 477 478proc run-many-tests { testcases extra_flags } { 479 global compiler_vendor 480 global env 481 switch $compiler_vendor { 482 "clang" { 483 set common "-W -Wall" 484 if [info exists env(LIBFFI_TEST_OPTIMIZATION)] { 485 set optimizations [ list $env(LIBFFI_TEST_OPTIMIZATION) ] 486 } else { 487 set optimizations { "-O0" "-O2" } 488 } 489 } 490 "gnu" { 491 set common "-W -Wall -Wno-psabi" 492 if [info exists env(LIBFFI_TEST_OPTIMIZATION)] { 493 set optimizations [ list $env(LIBFFI_TEST_OPTIMIZATION) ] 494 } else { 495 set optimizations { "-O0" "-O2" } 496 } 497 } 498 default { 499 # Assume we are using the vendor compiler. 500 set common "" 501 if [info exists env(LIBFFI_TEST_OPTIMIZATION)] { 502 set optimizations [ list $env(LIBFFI_TEST_OPTIMIZATION) ] 503 } else { 504 set optimizations { "" } 505 } 506 } 507 } 508 509 info exists env(LD_LIBRARY_PATH) 510 511 set targetabis { "" } 512 if [string match $compiler_vendor "gnu"] { 513 if [libffi_feature_test "#ifdef __i386__"] { 514 set targetabis { 515 "" 516 "-DABI_NUM=FFI_STDCALL -DABI_ATTR=__STDCALL__" 517 "-DABI_NUM=FFI_THISCALL -DABI_ATTR=__THISCALL__" 518 "-DABI_NUM=FFI_FASTCALL -DABI_ATTR=__FASTCALL__" 519 } 520 } elseif { [istarget "x86_64-*-*"] \ 521 && [libffi_feature_test "#if !defined __ILP32__ \ 522 && !defined __i386__"] } { 523 set targetabis { 524 "" 525 "-DABI_NUM=FFI_GNUW64 -DABI_ATTR=__MSABI__" 526 } 527 } 528 } 529 530 set common [ concat $common $extra_flags ] 531 foreach test $testcases { 532 set testname [file tail $test] 533 if [search_for $test "ABI_NUM"] { 534 set abis $targetabis 535 } else { 536 set abis { "" } 537 } 538 foreach opt $optimizations { 539 foreach abi $abis { 540 set options [concat $common $opt $abi] 541 verbose "Testing $testname, $options" 1 542 dg-test $test $options "" 543 } 544 } 545 } 546} 547 548# Like check_conditional_xfail, but callable from a dg test. 549 550proc dg-xfail-if { args } { 551 set args [lreplace $args 0 0] 552 set selector "target [join [lindex $args 1]]" 553 if { [dg-process-target $selector] == "S" } { 554 global compiler_conditional_xfail_data 555 set compiler_conditional_xfail_data $args 556 } 557} 558 559proc check-flags { args } { 560 561 # The args are within another list; pull them out. 562 set args [lindex $args 0] 563 564 # The next two arguments are optional. If they were not specified, 565 # use the defaults. 566 if { [llength $args] == 2 } { 567 lappend $args [list "*"] 568 } 569 if { [llength $args] == 3 } { 570 lappend $args [list ""] 571 } 572 573 # If the option strings are the defaults, or the same as the 574 # defaults, there is no need to call check_conditional_xfail to 575 # compare them to the actual options. 576 if { [string compare [lindex $args 2] "*"] == 0 577 && [string compare [lindex $args 3] "" ] == 0 } { 578 set result 1 579 } else { 580 # The target list might be an effective-target keyword, so replace 581 # the original list with "*-*-*", since we already know it matches. 582 set result [check_conditional_xfail [lreplace $args 1 1 "*-*-*"]] 583 } 584 585 return $result 586} 587 588proc dg-skip-if { args } { 589 # Verify the number of arguments. The last two are optional. 590 set args [lreplace $args 0 0] 591 if { [llength $args] < 2 || [llength $args] > 4 } { 592 error "dg-skip-if 2: need 2, 3, or 4 arguments" 593 } 594 595 # Don't bother if we're already skipping the test. 596 upvar dg-do-what dg-do-what 597 if { [lindex ${dg-do-what} 1] == "N" } { 598 return 599 } 600 601 set selector [list target [lindex $args 1]] 602 if { [dg-process-target $selector] == "S" } { 603 if [check-flags $args] { 604 upvar dg-do-what dg-do-what 605 set dg-do-what [list [lindex ${dg-do-what} 0] "N" "P"] 606 } 607 } 608} 609 610# We need to make sure that additional_files and additional_sources 611# are both cleared out after every test. It is not enough to clear 612# them out *before* the next test run because gcc-target-compile gets 613# run directly from some .exp files (outside of any test). (Those 614# uses should eventually be eliminated.) 615 616# Because the DG framework doesn't provide a hook that is run at the 617# end of a test, we must replace dg-test with a wrapper. 618 619if { [info procs saved-dg-test] == [list] } { 620 rename dg-test saved-dg-test 621 622 proc dg-test { args } { 623 global additional_files 624 global additional_sources 625 global errorInfo 626 627 if { [ catch { eval saved-dg-test $args } errmsg ] } { 628 set saved_info $errorInfo 629 set additional_files "" 630 set additional_sources "" 631 error $errmsg $saved_info 632 } 633 set additional_files "" 634 set additional_sources "" 635 } 636} 637 638# Local Variables: 639# tcl-indent-level:4 640# End: 641