aboutsummaryrefslogtreecommitdiffstats
path: root/tools/perf/util/trace-event-perl.c
diff options
context:
space:
mode:
Diffstat (limited to 'tools/perf/util/trace-event-perl.c')
-rw-r--r--tools/perf/util/trace-event-perl.c552
1 files changed, 552 insertions, 0 deletions
diff --git a/tools/perf/util/trace-event-perl.c b/tools/perf/util/trace-event-perl.c
new file mode 100644
index 000000000000..c56b08d704da
--- /dev/null
+++ b/tools/perf/util/trace-event-perl.c
@@ -0,0 +1,552 @@
1/*
2 * trace-event-perl. Feed perf trace events to an embedded Perl interpreter.
3 *
4 * Copyright (C) 2009 Tom Zanussi <tzanussi@gmail.com>
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 *
20 */
21
22#include <stdio.h>
23#include <stdlib.h>
24#include <string.h>
25#include <ctype.h>
26#include <errno.h>
27
28#include "../perf.h"
29#include "util.h"
30#include "trace-event.h"
31#include "trace-event-perl.h"
32
33INTERP my_perl;
34
35#define FTRACE_MAX_EVENT \
36 ((1 << (sizeof(unsigned short) * 8)) - 1)
37
38struct event *events[FTRACE_MAX_EVENT];
39
40static struct scripting_context *scripting_context;
41
42static char *cur_field_name;
43static int zero_flag_atom;
44
45static void define_symbolic_value(const char *ev_name,
46 const char *field_name,
47 const char *field_value,
48 const char *field_str)
49{
50 unsigned long long value;
51 dSP;
52
53 value = eval_flag(field_value);
54
55 ENTER;
56 SAVETMPS;
57 PUSHMARK(SP);
58
59 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
60 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
61 XPUSHs(sv_2mortal(newSVuv(value)));
62 XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
63
64 PUTBACK;
65 if (get_cv("main::define_symbolic_value", 0))
66 call_pv("main::define_symbolic_value", G_SCALAR);
67 SPAGAIN;
68 PUTBACK;
69 FREETMPS;
70 LEAVE;
71}
72
73static void define_symbolic_values(struct print_flag_sym *field,
74 const char *ev_name,
75 const char *field_name)
76{
77 define_symbolic_value(ev_name, field_name, field->value, field->str);
78 if (field->next)
79 define_symbolic_values(field->next, ev_name, field_name);
80}
81
82static void define_symbolic_field(const char *ev_name,
83 const char *field_name)
84{
85 dSP;
86
87 ENTER;
88 SAVETMPS;
89 PUSHMARK(SP);
90
91 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
92 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
93
94 PUTBACK;
95 if (get_cv("main::define_symbolic_field", 0))
96 call_pv("main::define_symbolic_field", G_SCALAR);
97 SPAGAIN;
98 PUTBACK;
99 FREETMPS;
100 LEAVE;
101}
102
103static void define_flag_value(const char *ev_name,
104 const char *field_name,
105 const char *field_value,
106 const char *field_str)
107{
108 unsigned long long value;
109 dSP;
110
111 value = eval_flag(field_value);
112
113 ENTER;
114 SAVETMPS;
115 PUSHMARK(SP);
116
117 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
118 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
119 XPUSHs(sv_2mortal(newSVuv(value)));
120 XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
121
122 PUTBACK;
123 if (get_cv("main::define_flag_value", 0))
124 call_pv("main::define_flag_value", G_SCALAR);
125 SPAGAIN;
126 PUTBACK;
127 FREETMPS;
128 LEAVE;
129}
130
131static void define_flag_values(struct print_flag_sym *field,
132 const char *ev_name,
133 const char *field_name)
134{
135 define_flag_value(ev_name, field_name, field->value, field->str);
136 if (field->next)
137 define_flag_values(field->next, ev_name, field_name);
138}
139
140static void define_flag_field(const char *ev_name,
141 const char *field_name,
142 const char *delim)
143{
144 dSP;
145
146 ENTER;
147 SAVETMPS;
148 PUSHMARK(SP);
149
150 XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
151 XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
152 XPUSHs(sv_2mortal(newSVpv(delim, 0)));
153
154 PUTBACK;
155 if (get_cv("main::define_flag_field", 0))
156 call_pv("main::define_flag_field", G_SCALAR);
157 SPAGAIN;
158 PUTBACK;
159 FREETMPS;
160 LEAVE;
161}
162
163static void define_event_symbols(struct event *event,
164 const char *ev_name,
165 struct print_arg *args)
166{
167 switch (args->type) {
168 case PRINT_NULL:
169 break;
170 case PRINT_ATOM:
171 define_flag_value(ev_name, cur_field_name, "0",
172 args->atom.atom);
173 zero_flag_atom = 0;
174 break;
175 case PRINT_FIELD:
176 if (cur_field_name)
177 free(cur_field_name);
178 cur_field_name = strdup(args->field.name);
179 break;
180 case PRINT_FLAGS:
181 define_event_symbols(event, ev_name, args->flags.field);
182 define_flag_field(ev_name, cur_field_name, args->flags.delim);
183 define_flag_values(args->flags.flags, ev_name, cur_field_name);
184 break;
185 case PRINT_SYMBOL:
186 define_event_symbols(event, ev_name, args->symbol.field);
187 define_symbolic_field(ev_name, cur_field_name);
188 define_symbolic_values(args->symbol.symbols, ev_name,
189 cur_field_name);
190 break;
191 case PRINT_STRING:
192 break;
193 case PRINT_TYPE:
194 define_event_symbols(event, ev_name, args->typecast.item);
195 break;
196 case PRINT_OP:
197 if (strcmp(args->op.op, ":") == 0)
198 zero_flag_atom = 1;
199 define_event_symbols(event, ev_name, args->op.left);
200 define_event_symbols(event, ev_name, args->op.right);
201 break;
202 default:
203 /* we should warn... */
204 return;
205 }
206
207 if (args->next)
208 define_event_symbols(event, ev_name, args->next);
209}
210
211static inline struct event *find_cache_event(int type)
212{
213 static char ev_name[256];
214 struct event *event;
215
216 if (events[type])
217 return events[type];
218
219 events[type] = event = trace_find_event(type);
220 if (!event)
221 return NULL;
222
223 sprintf(ev_name, "%s::%s", event->system, event->name);
224
225 define_event_symbols(event, ev_name, event->print_fmt.args);
226
227 return event;
228}
229
230static void perl_process_event(int cpu, void *data,
231 int size __attribute((unused)),
232 unsigned long long nsecs, char *comm)
233{
234 struct format_field *field;
235 static char handler[256];
236 unsigned long long val;
237 unsigned long s, ns;
238 struct event *event;
239 int type;
240 int pid;
241
242 dSP;
243
244 type = trace_parse_common_type(data);
245
246 event = find_cache_event(type);
247 if (!event)
248 die("ug! no event found for type %d", type);
249
250 pid = trace_parse_common_pid(data);
251
252 sprintf(handler, "%s::%s", event->system, event->name);
253
254 s = nsecs / NSECS_PER_SEC;
255 ns = nsecs - s * NSECS_PER_SEC;
256
257 scripting_context->event_data = data;
258
259 ENTER;
260 SAVETMPS;
261 PUSHMARK(SP);
262
263 XPUSHs(sv_2mortal(newSVpv(handler, 0)));
264 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
265 XPUSHs(sv_2mortal(newSVuv(cpu)));
266 XPUSHs(sv_2mortal(newSVuv(s)));
267 XPUSHs(sv_2mortal(newSVuv(ns)));
268 XPUSHs(sv_2mortal(newSViv(pid)));
269 XPUSHs(sv_2mortal(newSVpv(comm, 0)));
270
271 /* common fields other than pid can be accessed via xsub fns */
272
273 for (field = event->format.fields; field; field = field->next) {
274 if (field->flags & FIELD_IS_STRING) {
275 int offset;
276 if (field->flags & FIELD_IS_DYNAMIC) {
277 offset = *(int *)(data + field->offset);
278 offset &= 0xffff;
279 } else
280 offset = field->offset;
281 XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0)));
282 } else { /* FIELD_IS_NUMERIC */
283 val = read_size(data + field->offset, field->size);
284 if (field->flags & FIELD_IS_SIGNED) {
285 XPUSHs(sv_2mortal(newSViv(val)));
286 } else {
287 XPUSHs(sv_2mortal(newSVuv(val)));
288 }
289 }
290 }
291
292 PUTBACK;
293 if (get_cv(handler, 0))
294 call_pv(handler, G_SCALAR);
295 else if (get_cv("main::trace_unhandled", 0)) {
296 XPUSHs(sv_2mortal(newSVpv(handler, 0)));
297 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
298 XPUSHs(sv_2mortal(newSVuv(cpu)));
299 XPUSHs(sv_2mortal(newSVuv(nsecs)));
300 XPUSHs(sv_2mortal(newSViv(pid)));
301 XPUSHs(sv_2mortal(newSVpv(comm, 0)));
302 call_pv("main::trace_unhandled", G_SCALAR);
303 }
304 SPAGAIN;
305 PUTBACK;
306 FREETMPS;
307 LEAVE;
308}
309
310static void run_start_sub(void)
311{
312 dSP; /* access to Perl stack */
313 PUSHMARK(SP);
314
315 if (get_cv("main::trace_begin", 0))
316 call_pv("main::trace_begin", G_DISCARD | G_NOARGS);
317}
318
319/*
320 * Start trace script
321 */
322static int perl_start_script(const char *script)
323{
324 const char *command_line[2] = { "", NULL };
325
326 command_line[1] = script;
327
328 my_perl = perl_alloc();
329 perl_construct(my_perl);
330
331 if (perl_parse(my_perl, NULL, 2, (char **)command_line, (char **)NULL))
332 return -1;
333
334 perl_run(my_perl);
335 if (SvTRUE(ERRSV))
336 return -1;
337
338 run_start_sub();
339
340 fprintf(stderr, "perf trace started with Perl script %s\n\n", script);
341
342 return 0;
343}
344
345/*
346 * Stop trace script
347 */
348static int perl_stop_script(void)
349{
350 dSP; /* access to Perl stack */
351 PUSHMARK(SP);
352
353 if (get_cv("main::trace_end", 0))
354 call_pv("main::trace_end", G_DISCARD | G_NOARGS);
355
356 perl_destruct(my_perl);
357 perl_free(my_perl);
358
359 fprintf(stderr, "\nperf trace Perl script stopped\n");
360
361 return 0;
362}
363
364static int perl_generate_script(const char *outfile)
365{
366 struct event *event = NULL;
367 struct format_field *f;
368 char fname[PATH_MAX];
369 int not_first, count;
370 FILE *ofp;
371
372 sprintf(fname, "%s.pl", outfile);
373 ofp = fopen(fname, "w");
374 if (ofp == NULL) {
375 fprintf(stderr, "couldn't open %s\n", fname);
376 return -1;
377 }
378
379 fprintf(ofp, "# perf trace event handlers, "
380 "generated by perf trace -g perl\n");
381
382 fprintf(ofp, "# Licensed under the terms of the GNU GPL"
383 " License version 2\n\n");
384
385 fprintf(ofp, "# The common_* event handler fields are the most useful "
386 "fields common to\n");
387
388 fprintf(ofp, "# all events. They don't necessarily correspond to "
389 "the 'common_*' fields\n");
390
391 fprintf(ofp, "# in the format files. Those fields not available as "
392 "handler params can\n");
393
394 fprintf(ofp, "# be retrieved using Perl functions of the form "
395 "common_*($context).\n");
396
397 fprintf(ofp, "# See Context.pm for the list of available "
398 "functions.\n\n");
399
400 fprintf(ofp, "use lib \"$ENV{'PERF_EXEC_PATH'}/scripts/perl/"
401 "Perf-Trace-Util/lib\";\n");
402
403 fprintf(ofp, "use lib \"./Perf-Trace-Util/lib\";\n");
404 fprintf(ofp, "use Perf::Trace::Core;\n");
405 fprintf(ofp, "use Perf::Trace::Context;\n");
406 fprintf(ofp, "use Perf::Trace::Util;\n\n");
407
408 fprintf(ofp, "sub trace_begin\n{\n\t# optional\n}\n\n");
409 fprintf(ofp, "sub trace_end\n{\n\t# optional\n}\n\n");
410
411 while ((event = trace_find_next_event(event))) {
412 fprintf(ofp, "sub %s::%s\n{\n", event->system, event->name);
413 fprintf(ofp, "\tmy (");
414
415 fprintf(ofp, "$event_name, ");
416 fprintf(ofp, "$context, ");
417 fprintf(ofp, "$common_cpu, ");
418 fprintf(ofp, "$common_secs, ");
419 fprintf(ofp, "$common_nsecs,\n");
420 fprintf(ofp, "\t $common_pid, ");
421 fprintf(ofp, "$common_comm,\n\t ");
422
423 not_first = 0;
424 count = 0;
425
426 for (f = event->format.fields; f; f = f->next) {
427 if (not_first++)
428 fprintf(ofp, ", ");
429 if (++count % 5 == 0)
430 fprintf(ofp, "\n\t ");
431
432 fprintf(ofp, "$%s", f->name);
433 }
434 fprintf(ofp, ") = @_;\n\n");
435
436 fprintf(ofp, "\tprint_header($event_name, $common_cpu, "
437 "$common_secs, $common_nsecs,\n\t "
438 "$common_pid, $common_comm);\n\n");
439
440 fprintf(ofp, "\tprintf(\"");
441
442 not_first = 0;
443 count = 0;
444
445 for (f = event->format.fields; f; f = f->next) {
446 if (not_first++)
447 fprintf(ofp, ", ");
448 if (count && count % 4 == 0) {
449 fprintf(ofp, "\".\n\t \"");
450 }
451 count++;
452
453 fprintf(ofp, "%s=", f->name);
454 if (f->flags & FIELD_IS_STRING ||
455 f->flags & FIELD_IS_FLAG ||
456 f->flags & FIELD_IS_SYMBOLIC)
457 fprintf(ofp, "%%s");
458 else if (f->flags & FIELD_IS_SIGNED)
459 fprintf(ofp, "%%d");
460 else
461 fprintf(ofp, "%%u");
462 }
463
464 fprintf(ofp, "\\n\",\n\t ");
465
466 not_first = 0;
467 count = 0;
468
469 for (f = event->format.fields; f; f = f->next) {
470 if (not_first++)
471 fprintf(ofp, ", ");
472
473 if (++count % 5 == 0)
474 fprintf(ofp, "\n\t ");
475
476 if (f->flags & FIELD_IS_FLAG) {
477 if ((count - 1) % 5 != 0) {
478 fprintf(ofp, "\n\t ");
479 count = 4;
480 }
481 fprintf(ofp, "flag_str(\"");
482 fprintf(ofp, "%s::%s\", ", event->system,
483 event->name);
484 fprintf(ofp, "\"%s\", $%s)", f->name,
485 f->name);
486 } else if (f->flags & FIELD_IS_SYMBOLIC) {
487 if ((count - 1) % 5 != 0) {
488 fprintf(ofp, "\n\t ");
489 count = 4;
490 }
491 fprintf(ofp, "symbol_str(\"");
492 fprintf(ofp, "%s::%s\", ", event->system,
493 event->name);
494 fprintf(ofp, "\"%s\", $%s)", f->name,
495 f->name);
496 } else
497 fprintf(ofp, "$%s", f->name);
498 }
499
500 fprintf(ofp, ");\n");
501 fprintf(ofp, "}\n\n");
502 }
503
504 fprintf(ofp, "sub trace_unhandled\n{\n\tmy ($event_name, $context, "
505 "$common_cpu, $common_secs, $common_nsecs,\n\t "
506 "$common_pid, $common_comm) = @_;\n\n");
507
508 fprintf(ofp, "\tprint_header($event_name, $common_cpu, "
509 "$common_secs, $common_nsecs,\n\t $common_pid, "
510 "$common_comm);\n}\n\n");
511
512 fprintf(ofp, "sub print_header\n{\n"
513 "\tmy ($event_name, $cpu, $secs, $nsecs, $pid, $comm) = @_;\n\n"
514 "\tprintf(\"%%-20s %%5u %%05u.%%09u %%8u %%-20s \",\n\t "
515 "$event_name, $cpu, $secs, $nsecs, $pid, $comm);\n}");
516
517 fclose(ofp);
518
519 fprintf(stderr, "generated Perl script: %s\n", fname);
520
521 return 0;
522}
523
524struct scripting_ops perl_scripting_ops = {
525 .name = "Perl",
526 .start_script = perl_start_script,
527 .stop_script = perl_stop_script,
528 .process_event = perl_process_event,
529 .generate_script = perl_generate_script,
530};
531
532#ifdef NO_LIBPERL
533void setup_perl_scripting(void)
534{
535 fprintf(stderr, "Perl scripting not supported."
536 " Install libperl-dev[el] and rebuild perf to get it.\n");
537}
538#else
539void setup_perl_scripting(void)
540{
541 int err;
542 err = script_spec_register("Perl", &perl_scripting_ops);
543 if (err)
544 die("error registering Perl script extension");
545
546 err = script_spec_register("pl", &perl_scripting_ops);
547 if (err)
548 die("error registering pl script extension");
549
550 scripting_context = malloc(sizeof(struct scripting_context));
551}
552#endif
generated by cgit v1.2.2 (git 2.25.0) at 2025-01-03 00:08:29 -0500