Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # ========== Copyright Header Begin ========================================== |
2 | # | |
3 | # OpenSPARC T2 Processor File: AnalyzeDiag.pm | |
4 | # Copyright (C) 1995-2007 Sun Microsystems, Inc. All Rights Reserved | |
5 | # 4150 Network Circle, Santa Clara, California 95054, U.S.A. | |
6 | # | |
7 | # * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. | |
8 | # | |
9 | # This program is free software; you can redistribute it and/or modify | |
10 | # it under the terms of the GNU General Public License as published by | |
11 | # the Free Software Foundation; version 2 of the License. | |
12 | # | |
13 | # This program is distributed in the hope that it will be useful, | |
14 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | # GNU General Public License for more details. | |
17 | # | |
18 | # You should have received a copy of the GNU General Public License | |
19 | # along with this program; if not, write to the Free Software | |
20 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
21 | # | |
22 | # For the avoidance of doubt, and except that if any non-GPL license | |
23 | # choice is available it will apply instead, Sun elects to use only | |
24 | # the General Public License version 2 (GPLv2) at this time for any | |
25 | # software where a choice of GPL license versions is made | |
26 | # available with the language indicating that GPLv2 or any later version | |
27 | # may be used, or where a choice of which version of the GPL is applied is | |
28 | # otherwise unspecified. | |
29 | # | |
30 | # Please contact Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, | |
31 | # CA 95054 USA or visit www.sun.com if you need additional information or | |
32 | # have any questions. | |
33 | # | |
34 | # ========== Copyright Header End ============================================ | |
35 | package AnalyzeDiag; | |
36 | ||
37 | use 5.008; | |
38 | use strict; | |
39 | use warnings; | |
40 | ||
41 | use AnalyzeDiag::Output; | |
42 | use AnalyzeDiag::Measurement; | |
43 | use AnalyzeDiag::Analyzer; | |
44 | require Exporter; | |
45 | ||
46 | our @ISA = qw(Exporter); | |
47 | ||
48 | # Items to export into callers namespace by default. Note: do not export | |
49 | # names by default without a very good reason. Use EXPORT_OK instead. | |
50 | # Do not simply export all your public functions/methods/constants. | |
51 | ||
52 | # This allows declaration use AnalyzeDiag ':all'; | |
53 | # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | |
54 | # will save memory. | |
55 | our %EXPORT_TAGS = ( 'all' => [ qw( | |
56 | ||
57 | ) ] ); | |
58 | ||
59 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | |
60 | ||
61 | our @EXPORT = (qw( | |
62 | pattern_match | |
63 | ), @AnalyzeDiag::Output::EXPORT); | |
64 | ||
65 | our $VERSION = '1.07'; | |
66 | ||
67 | ############################################################################### | |
68 | ||
69 | sub pattern_match { | |
70 | my $filename = shift; | |
71 | my $href = shift; | |
72 | ||
73 | my %enable_patterns; | |
74 | my %match_patterns; | |
75 | ||
76 | foreach my $pat (keys %$href) { | |
77 | if(ref $href->{$pat} eq 'HASH') { | |
78 | $enable_patterns{$pat} = $href->{$pat}{enable}; | |
79 | $match_patterns{$pat} = $href->{$pat}{match}; | |
80 | } else { | |
81 | $match_patterns{$pat} = $href->{$pat}; | |
82 | } | |
83 | } | |
84 | ||
85 | my %results = map { $_ => [] } keys %match_patterns; | |
86 | my $fh = IO::File->new("<$filename") or | |
87 | script_die "Can't open '$filename': $!\n"; | |
88 | ||
89 | my @enabled_patterns = grep { not exists $enable_patterns{$_} } | |
90 | keys %match_patterns; | |
91 | ||
92 | while(<$fh>) { | |
93 | foreach my $pat_name (keys %enable_patterns) { | |
94 | if(/$enable_patterns{$pat_name}/) { | |
95 | push @enabled_patterns, $pat_name; | |
96 | delete $enable_patterns{$pat_name}; | |
97 | } | |
98 | } | |
99 | ||
100 | foreach my $pat_name (@enabled_patterns) { | |
101 | my $pat = $match_patterns{$pat_name}; | |
102 | my @matchlist = /$pat/; | |
103 | push @{$results{$pat_name}}, \@matchlist if @matchlist; | |
104 | } | |
105 | } | |
106 | ||
107 | undef $fh; | |
108 | ||
109 | return \%results; | |
110 | } | |
111 | ||
112 | ||
113 | ############################################################################### | |
114 | ############################################################################### | |
115 | ||
116 | ||
117 | 1; | |
118 | __END__ | |
119 | # Below is stub documentation for your module. You'd better edit it! | |
120 | ||
121 | =head1 NAME | |
122 | ||
123 | AnalyzeDiag - Perl module for analyzing diag log files | |
124 | ||
125 | =head1 SYNOPSIS | |
126 | ||
127 | use AnalyzeDiag; | |
128 | ||
129 | my $dir = '.'; | |
130 | my $analyzer = AnalyzeDiag::Analyzer->new(dir => $dir); | |
131 | ||
132 | $analyzer->add_measurements | |
133 | ( | |
134 | AnalyzeDiag::Measurement->new(name => 'PointerChase', | |
135 | start => 'chase_start', | |
136 | end => 'chase_end') | |
137 | ); | |
138 | my %results = $analyzer->analyze(); | |
139 | ||
140 | my @times = @{ $Results{PointerChase} }; | |
141 | ||
142 | # Do something with times | |
143 | ||
144 | script_exit; | |
145 | ||
146 | =head1 ABSTRACT | |
147 | ||
148 | This module exports some functions that analyze diag log | |
149 | files. It is intended to be used by diags that write | |
150 | their own post-processing scripts. | |
151 | ||
152 | =head1 DESCRIPTION | |
153 | ||
154 | The AnalyzeDiag module contains two user-accessible classes: | |
155 | AnalyzeDiag::Analyzer and AnalyzeDiag::Measurement. | |
156 | ||
157 | The general usage is to create an AnalyzeDiag::Analyzer diag, given a | |
158 | directory argument (see the example in the previous section). You | |
159 | then add AnalyzeDiag::Measurement objects to the analyzer. Finally, | |
160 | the call to the analyze method will produce a hash where the keys are | |
161 | names of measurements and the values are arrays of times (in cycles) | |
162 | for those measurements. | |
163 | ||
164 | The AnalyzeDiag::Measurement object has a contructor called 'new'. | |
165 | Its argument is a hash with keys 'name', 'start', and 'end'. The name | |
166 | field is used to identify the measurement. The 'start' and 'end' | |
167 | values define PCs at which the measurement should start and end. They | |
168 | may be virtual addresses (hex numbers without 0x) or labels. | |
169 | ||
170 | =head2 EXPORT | |
171 | ||
172 | =over 4 | |
173 | ||
174 | =item verbose( [$level] ) | |
175 | ||
176 | If $level is specified, set verbose level to that. Returns verbosity | |
177 | level. | |
178 | ||
179 | =item script_say(@msg) | |
180 | ||
181 | Print the message always. | |
182 | ||
183 | =item chat(@msg) | |
184 | ||
185 | Print the message if verbose level >= 1. | |
186 | ||
187 | =item debug(@msg) | |
188 | ||
189 | Print the message if verbose level >= 2. | |
190 | ||
191 | =item script_warning(@msg) | |
192 | ||
193 | Print a warning message. | |
194 | ||
195 | =item script_die(@msg) | |
196 | ||
197 | Print an error message, print a stack backtrace, and exit with status | |
198 | 2. | |
199 | ||
200 | =item diag_ok( $bool, $name ) | |
201 | ||
202 | Perform a test named '$name'. Test passes if $bool evaluates to true | |
203 | and fails otherwise. | |
204 | ||
205 | =item diag_is($got, $expected, $name) | |
206 | ||
207 | Perform a test called '$name'. Test passes if $got eq $expected (yes, | |
208 | that is a string comparison) and fails otherwise. This is a special | |
209 | case of $diag_ok, but it produces much better output since the | |
210 | function actually knows what is being compared. | |
211 | ||
212 | =item diag_is_numeric($got, $expected, $name, [$tolerance]) | |
213 | ||
214 | Same as diag_is except the comparison is numeric. If $tolerance is | |
215 | specified, the test passes if $got is within $tolerance of $expected. | |
216 | ||
217 | =item script_exit | |
218 | ||
219 | Prints the exit status and exits with that status. Exit status will | |
220 | be 0 unless one or more tests have failed, in which case it will be 1. | |
221 | ||
222 | =back | |
223 | ||
224 | ||
225 | =head1 SEE ALSO | |
226 | ||
227 | perl(1). | |
228 | ||
229 | =cut |