1# Copyright 2012-2023 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 16 17# The in-memory cache. 18array set gdb_data_cache {} 19 20# Print pass message msg into gdb.log 21proc ignore_pass { msg } { 22 verbose -log "gdb_do_cache_wrap ignoring pass: $msg" 23} 24 25# Call proc real_name and return the result, while ignoring calls to pass. 26proc gdb_do_cache_wrap {real_name} { 27 if { [info procs save_pass] != "" } { 28 return [uplevel 2 $real_name] 29 } 30 31 rename pass save_pass 32 rename ignore_pass pass 33 34 set code [catch {uplevel 2 $real_name} result] 35 36 rename pass ignore_pass 37 rename save_pass pass 38 39 if {$code == 1} { 40 global errorInfo errorCode 41 return -code error -errorinfo $errorInfo -errorcode $errorCode $result 42 } elseif {$code > 1} { 43 return -code $code $result 44 } 45 46 return $result 47} 48 49# A helper for gdb_caching_proc that handles the caching. 50 51proc gdb_do_cache {name} { 52 global gdb_data_cache objdir 53 global GDB_PARALLEL 54 55 # Normally, if we have a cached value, we skip computation and return 56 # the cached value. If set to 1, instead don't skip computation and 57 # verify against the cached value. 58 set cache_verify 0 59 60 # Alternatively, set this to do cache_verify only for one proc. 61 set cache_verify_proc "" 62 if { $name == $cache_verify_proc } { 63 set cache_verify 1 64 } 65 66 # See if some other process wrote the cache file. Cache value per 67 # "board" to handle runs with multiple options 68 # (e.g. unix/{-m32,-64}) correctly. We use "file join" here 69 # because we later use this in a real filename. 70 set cache_name [file join [target_info name] $name] 71 72 set is_cached 0 73 if {[info exists gdb_data_cache($cache_name)]} { 74 set cached $gdb_data_cache($cache_name) 75 verbose "$name: returning '$cached' from cache" 2 76 if { $cache_verify == 0 } { 77 return $cached 78 } 79 set is_cached 1 80 } 81 82 if { $is_cached == 0 && [info exists GDB_PARALLEL] } { 83 set cache_filename [make_gdb_parallel_path cache $cache_name] 84 if {[file exists $cache_filename]} { 85 set fd [open $cache_filename] 86 set gdb_data_cache($cache_name) [read -nonewline $fd] 87 close $fd 88 set cached $gdb_data_cache($cache_name) 89 verbose "$name: returning '$cached' from file cache" 2 90 if { $cache_verify == 0 } { 91 return $cached 92 } 93 set is_cached 1 94 } 95 } 96 97 set real_name gdb_real__$name 98 set gdb_data_cache($cache_name) [gdb_do_cache_wrap $real_name] 99 if { $cache_verify == 1 && $is_cached == 1 } { 100 set computed $gdb_data_cache($cache_name) 101 if { $cached != $computed } { 102 error [join [list "Inconsistent results for $cache_name:" 103 "cached: $cached vs. computed: $computed"]] 104 } 105 } 106 107 if {[info exists GDB_PARALLEL]} { 108 verbose "$name: returning '$gdb_data_cache($cache_name)' and writing file" 2 109 file mkdir [file dirname $cache_filename] 110 # Make sure to write the results file atomically. 111 set fd [open $cache_filename.[pid] w] 112 puts $fd $gdb_data_cache($cache_name) 113 close $fd 114 file rename -force -- $cache_filename.[pid] $cache_filename 115 } 116 return $gdb_data_cache($cache_name) 117} 118 119# Define a new proc named NAME that takes no arguments. BODY is the 120# body of the proc. The proc will evaluate BODY and cache the 121# results, both in memory and, if GDB_PARALLEL is defined, in the 122# filesystem for use across invocations of dejagnu. 123 124proc gdb_caching_proc {name body} { 125 # Define the underlying proc that we'll call. 126 set real_name gdb_real__$name 127 proc $real_name {} $body 128 129 # Define the advertised proc. 130 proc $name {} [list gdb_do_cache $name] 131} 132