1/* 2 * trace-event-perl. Feed perf script 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 "../util.h" 29#include <EXTERN.h> 30#include <perl.h> 31 32#include "../../perf.h" 33#include "../thread.h" 34#include "../event.h" 35#include "../trace-event.h" 36#include "../evsel.h" 37 38void boot_Perf__Trace__Context(pTHX_ CV *cv); 39void boot_DynaLoader(pTHX_ CV *cv); 40typedef PerlInterpreter * INTERP; 41 42void xs_init(pTHX); 43 44void xs_init(pTHX) 45{ 46 const char *file = __FILE__; 47 dXSUB_SYS; 48 49 newXS("Perf::Trace::Context::bootstrap", boot_Perf__Trace__Context, 50 file); 51 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); 52} 53 54INTERP my_perl; 55 56#define FTRACE_MAX_EVENT \ 57 ((1 << (sizeof(unsigned short) * 8)) - 1) 58 59struct event_format *events[FTRACE_MAX_EVENT]; 60 61extern struct scripting_context *scripting_context; 62 63static char *cur_field_name; 64static int zero_flag_atom; 65 66static void define_symbolic_value(const char *ev_name, 67 const char *field_name, 68 const char *field_value, 69 const char *field_str) 70{ 71 unsigned long long value; 72 dSP; 73 74 value = eval_flag(field_value); 75 76 ENTER; 77 SAVETMPS; 78 PUSHMARK(SP); 79 80 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 81 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 82 XPUSHs(sv_2mortal(newSVuv(value))); 83 XPUSHs(sv_2mortal(newSVpv(field_str, 0))); 84 85 PUTBACK; 86 if (get_cv("main::define_symbolic_value", 0)) 87 call_pv("main::define_symbolic_value", G_SCALAR); 88 SPAGAIN; 89 PUTBACK; 90 FREETMPS; 91 LEAVE; 92} 93 94static void define_symbolic_values(struct print_flag_sym *field, 95 const char *ev_name, 96 const char *field_name) 97{ 98 define_symbolic_value(ev_name, field_name, field->value, field->str); 99 if (field->next) 100 define_symbolic_values(field->next, ev_name, field_name); 101} 102 103static void define_symbolic_field(const char *ev_name, 104 const char *field_name) 105{ 106 dSP; 107 108 ENTER; 109 SAVETMPS; 110 PUSHMARK(SP); 111 112 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 113 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 114 115 PUTBACK; 116 if (get_cv("main::define_symbolic_field", 0)) 117 call_pv("main::define_symbolic_field", G_SCALAR); 118 SPAGAIN; 119 PUTBACK; 120 FREETMPS; 121 LEAVE; 122} 123 124static void define_flag_value(const char *ev_name, 125 const char *field_name, 126 const char *field_value, 127 const char *field_str) 128{ 129 unsigned long long value; 130 dSP; 131 132 value = eval_flag(field_value); 133 134 ENTER; 135 SAVETMPS; 136 PUSHMARK(SP); 137 138 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 139 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 140 XPUSHs(sv_2mortal(newSVuv(value))); 141 XPUSHs(sv_2mortal(newSVpv(field_str, 0))); 142 143 PUTBACK; 144 if (get_cv("main::define_flag_value", 0)) 145 call_pv("main::define_flag_value", G_SCALAR); 146 SPAGAIN; 147 PUTBACK; 148 FREETMPS; 149 LEAVE; 150} 151 152static void define_flag_values(struct print_flag_sym *field, 153 const char *ev_name, 154 const char *field_name) 155{ 156 define_flag_value(ev_name, field_name, field->value, field->str); 157 if (field->next) 158 define_flag_values(field->next, ev_name, field_name); 159} 160 161static void define_flag_field(const char *ev_name, 162 const char *field_name, 163 const char *delim) 164{ 165 dSP; 166 167 ENTER; 168 SAVETMPS; 169 PUSHMARK(SP); 170 171 XPUSHs(sv_2mortal(newSVpv(ev_name, 0))); 172 XPUSHs(sv_2mortal(newSVpv(field_name, 0))); 173 XPUSHs(sv_2mortal(newSVpv(delim, 0))); 174 175 PUTBACK; 176 if (get_cv("main::define_flag_field", 0)) 177 call_pv("main::define_flag_field", G_SCALAR); 178 SPAGAIN; 179 PUTBACK; 180 FREETMPS; 181 LEAVE; 182} 183 184static void define_event_symbols(struct event_format *event, 185 const char *ev_name, 186 struct print_arg *args) 187{ 188 switch (args->type) { 189 case PRINT_NULL: 190 break; 191 case PRINT_ATOM: 192 define_flag_value(ev_name, cur_field_name, "0", 193 args->atom.atom); 194 zero_flag_atom = 0; 195 break; 196 case PRINT_FIELD: 197 if (cur_field_name) 198 free(cur_field_name); 199 cur_field_name = strdup(args->field.name); 200 break; 201 case PRINT_FLAGS: 202 define_event_symbols(event, ev_name, args->flags.field); 203 define_flag_field(ev_name, cur_field_name, args->flags.delim); 204 define_flag_values(args->flags.flags, ev_name, cur_field_name); 205 break; 206 case PRINT_SYMBOL: 207 define_event_symbols(event, ev_name, args->symbol.field); 208 define_symbolic_field(ev_name, cur_field_name); 209 define_symbolic_values(args->symbol.symbols, ev_name, 210 cur_field_name); 211 break; 212 case PRINT_HEX: 213 define_event_symbols(event, ev_name, args->hex.field); 214 define_event_symbols(event, ev_name, args->hex.size); 215 break; 216 case PRINT_BSTRING: 217 case PRINT_DYNAMIC_ARRAY: 218 case PRINT_STRING: 219 break; 220 case PRINT_TYPE: 221 define_event_symbols(event, ev_name, args->typecast.item); 222 break; 223 case PRINT_OP: 224 if (strcmp(args->op.op, ":") == 0) 225 zero_flag_atom = 1; 226 define_event_symbols(event, ev_name, args->op.left); 227 define_event_symbols(event, ev_name, args->op.right); 228 break; 229 case PRINT_FUNC: 230 default: 231 pr_err("Unsupported print arg type\n"); 232 /* we should warn... */ 233 return; 234 } 235 236 if (args->next) 237 define_event_symbols(event, ev_name, args->next); 238} 239 240static inline struct event_format *find_cache_event(struct perf_evsel *evsel) 241{ 242 static char ev_name[256]; 243 struct event_format *event; 244 int type = evsel->attr.config; 245 246 if (events[type]) 247 return events[type]; 248 249 events[type] = event = evsel->tp_format; 250 if (!event) 251 return NULL; 252 253 sprintf(ev_name, "%s::%s", event->system, event->name); 254 255 define_event_symbols(event, ev_name, event->print_fmt.args); 256 257 return event; 258} 259 260static void perl_process_tracepoint(union perf_event *perf_event __maybe_unused, 261 struct perf_sample *sample, 262 struct perf_evsel *evsel, 263 struct machine *machine __maybe_unused, 264 struct thread *thread, 265 struct addr_location *al) 266{ 267 struct format_field *field; 268 static char handler[256]; 269 unsigned long long val; 270 unsigned long s, ns; 271 struct event_format *event; 272 int pid; 273 int cpu = sample->cpu; 274 void *data = sample->raw_data; 275 unsigned long long nsecs = sample->time; 276 char *comm = thread->comm; 277 278 dSP; 279 280 if (evsel->attr.type != PERF_TYPE_TRACEPOINT) 281 return; 282 283 event = find_cache_event(evsel); 284 if (!event) 285 die("ug! no event found for type %" PRIu64, (u64)evsel->attr.config); 286 287 pid = raw_field_value(event, "common_pid", data); 288 289 sprintf(handler, "%s::%s", event->system, event->name); 290 291 s = nsecs / NSECS_PER_SEC; 292 ns = nsecs - s * NSECS_PER_SEC; 293 294 scripting_context->event_data = data; 295 scripting_context->pevent = evsel->tp_format->pevent; 296 297 ENTER; 298 SAVETMPS; 299 PUSHMARK(SP); 300 301 XPUSHs(sv_2mortal(newSVpv(handler, 0))); 302 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context)))); 303 XPUSHs(sv_2mortal(newSVuv(cpu))); 304 XPUSHs(sv_2mortal(newSVuv(s))); 305 XPUSHs(sv_2mortal(newSVuv(ns))); 306 XPUSHs(sv_2mortal(newSViv(pid))); 307 XPUSHs(sv_2mortal(newSVpv(comm, 0))); 308 309 /* common fields other than pid can be accessed via xsub fns */ 310 311 for (field = event->format.fields; field; field = field->next) { 312 if (field->flags & FIELD_IS_STRING) { 313 int offset; 314 if (field->flags & FIELD_IS_DYNAMIC) { 315 offset = *(int *)(data + field->offset); 316 offset &= 0xffff; 317 } else 318 offset = field->offset; 319 XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0))); 320 } else { /* FIELD_IS_NUMERIC */ 321 val = read_size(event, data + field->offset, 322 field->size); 323 if (field->flags & FIELD_IS_SIGNED) { 324 XPUSHs(sv_2mortal(newSViv(val))); 325 } else { 326 XPUSHs(sv_2mortal(newSVuv(val))); 327 } 328 } 329 } 330 331 PUTBACK; 332 333 if (get_cv(handler, 0)) 334 call_pv(handler, G_SCALAR); 335 else if (get_cv("main::trace_unhandled", 0)) { 336 XPUSHs(sv_2mortal(newSVpv(handler, 0))); 337 XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context)))); 338 XPUSHs(sv_2mortal(newSVuv(cpu))); 339 XPUSHs(sv_2mortal(newSVuv(nsecs))); 340 XPUSHs(sv_2mortal(newSViv(pid))); 341 XPUSHs(sv_2mortal(newSVpv(comm, 0))); 342 call_pv("main::trace_unhandled", G_SCALAR); 343 } 344 SPAGAIN; 345 PUTBACK; 346 FREETMPS; 347 LEAVE; 348} 349 350static void perl_process_event_generic(union perf_event *event, 351 struct perf_sample *sample, 352 struct perf_evsel *evsel, 353 struct machine *machine __maybe_unused, 354 struct thread *thread __maybe_unused, 355 struct addr_location *al __maybe_unused) 356{ 357 dSP; 358 359 if (!get_cv("process_event", 0)) 360 return; 361 362 ENTER; 363 SAVETMPS; 364 PUSHMARK(SP); 365 XPUSHs(sv_2mortal(newSVpvn((const char *)event, event->header.size))); 366 XPUSHs(sv_2mortal(newSVpvn((const char *)&evsel->attr, sizeof(evsel->attr)))); 367 XPUSHs(sv_2mortal(newSVpvn((const char *)sample, sizeof(*sample)))); 368 XPUSHs(sv_2mortal(newSVpvn((const char *)sample->raw_data, sample->raw_size))); 369 PUTBACK; 370 call_pv("process_event", G_SCALAR); 371 SPAGAIN; 372 PUTBACK; 373 FREETMPS; 374 LEAVE; 375} 376 377static void perl_process_event(union perf_event *event, 378 struct perf_sample *sample, 379 struct perf_evsel *evsel, 380 struct machine *machine, 381 struct thread *thread, 382 struct addr_location *al) 383{ 384 perl_process_tracepoint(event, sample, evsel, machine, thread, al); 385 perl_process_event_generic(event, sample, evsel, machine, thread, al); 386} 387 388static void run_start_sub(void) 389{ 390 dSP; /* access to Perl stack */ 391 PUSHMARK(SP); 392 393 if (get_cv("main::trace_begin", 0)) 394 call_pv("main::trace_begin", G_DISCARD | G_NOARGS); 395} 396 397/* 398 * Start trace script 399 */ 400static int perl_start_script(const char *script, int argc, const char **argv) 401{ 402 const char **command_line; 403 int i, err = 0; 404 405 command_line = malloc((argc + 2) * sizeof(const char *)); 406 command_line[0] = ""; 407 command_line[1] = script; 408 for (i = 2; i < argc + 2; i++) 409 command_line[i] = argv[i - 2]; 410 411 my_perl = perl_alloc(); 412 perl_construct(my_perl); 413 414 if (perl_parse(my_perl, xs_init, argc + 2, (char **)command_line, 415 (char **)NULL)) { 416 err = -1; 417 goto error; 418 } 419 420 if (perl_run(my_perl)) { 421 err = -1; 422 goto error; 423 } 424 425 if (SvTRUE(ERRSV)) { 426 err = -1; 427 goto error; 428 } 429 430 run_start_sub(); 431 432 free(command_line); 433 return 0; 434error: 435 perl_free(my_perl); 436 free(command_line); 437 438 return err; 439} 440 441/* 442 * Stop trace script 443 */ 444static int perl_stop_script(void) 445{ 446 dSP; /* access to Perl stack */ 447 PUSHMARK(SP); 448 449 if (get_cv("main::trace_end", 0)) 450 call_pv("main::trace_end", G_DISCARD | G_NOARGS); 451 452 perl_destruct(my_perl); 453 perl_free(my_perl); 454 455 return 0; 456} 457 458static int perl_generate_script(struct pevent *pevent, const char *outfile) 459{ 460 struct event_format *event = NULL; 461 struct format_field *f; 462 char fname[PATH_MAX]; 463 int not_first, count; 464 FILE *ofp; 465 466 sprintf(fname, "%s.pl", outfile); 467 ofp = fopen(fname, "w"); 468 if (ofp == NULL) { 469 fprintf(stderr, "couldn't open %s\n", fname); 470 return -1; 471 } 472 473 fprintf(ofp, "# perf script event handlers, " 474 "generated by perf script -g perl\n"); 475 476 fprintf(ofp, "# Licensed under the terms of the GNU GPL" 477 " License version 2\n\n"); 478 479 fprintf(ofp, "# The common_* event handler fields are the most useful " 480 "fields common to\n"); 481 482 fprintf(ofp, "# all events. They don't necessarily correspond to " 483 "the 'common_*' fields\n"); 484 485 fprintf(ofp, "# in the format files. Those fields not available as " 486 "handler params can\n"); 487 488 fprintf(ofp, "# be retrieved using Perl functions of the form " 489 "common_*($context).\n"); 490 491 fprintf(ofp, "# See Context.pm for the list of available " 492 "functions.\n\n"); 493 494 fprintf(ofp, "use lib \"$ENV{'PERF_EXEC_PATH'}/scripts/perl/" 495 "Perf-Trace-Util/lib\";\n"); 496 497 fprintf(ofp, "use lib \"./Perf-Trace-Util/lib\";\n"); 498 fprintf(ofp, "use Perf::Trace::Core;\n"); 499 fprintf(ofp, "use Perf::Trace::Context;\n"); 500 fprintf(ofp, "use Perf::Trace::Util;\n\n"); 501 502 fprintf(ofp, "sub trace_begin\n{\n\t# optional\n}\n\n"); 503 fprintf(ofp, "sub trace_end\n{\n\t# optional\n}\n\n"); 504 505 while ((event = trace_find_next_event(pevent, event))) { 506 fprintf(ofp, "sub %s::%s\n{\n", event->system, event->name); 507 fprintf(ofp, "\tmy ("); 508 509 fprintf(ofp, "$event_name, "); 510 fprintf(ofp, "$context, "); 511 fprintf(ofp, "$common_cpu, "); 512 fprintf(ofp, "$common_secs, "); 513 fprintf(ofp, "$common_nsecs,\n"); 514 fprintf(ofp, "\t $common_pid, "); 515 fprintf(ofp, "$common_comm,\n\t "); 516 517 not_first = 0; 518 count = 0; 519 520 for (f = event->format.fields; f; f = f->next) { 521 if (not_first++) 522 fprintf(ofp, ", "); 523 if (++count % 5 == 0) 524 fprintf(ofp, "\n\t "); 525 526 fprintf(ofp, "$%s", f->name); 527 } 528 fprintf(ofp, ") = @_;\n\n"); 529 530 fprintf(ofp, "\tprint_header($event_name, $common_cpu, " 531 "$common_secs, $common_nsecs,\n\t " 532 "$common_pid, $common_comm);\n\n"); 533 534 fprintf(ofp, "\tprintf(\""); 535 536 not_first = 0; 537 count = 0; 538 539 for (f = event->format.fields; f; f = f->next) { 540 if (not_first++) 541 fprintf(ofp, ", "); 542 if (count && count % 4 == 0) { 543 fprintf(ofp, "\".\n\t \""); 544 } 545 count++; 546 547 fprintf(ofp, "%s=", f->name); 548 if (f->flags & FIELD_IS_STRING || 549 f->flags & FIELD_IS_FLAG || 550 f->flags & FIELD_IS_SYMBOLIC) 551 fprintf(ofp, "%%s"); 552 else if (f->flags & FIELD_IS_SIGNED) 553 fprintf(ofp, "%%d"); 554 else 555 fprintf(ofp, "%%u"); 556 } 557 558 fprintf(ofp, "\\n\",\n\t "); 559 560 not_first = 0; 561 count = 0; 562 563 for (f = event->format.fields; f; f = f->next) { 564 if (not_first++) 565 fprintf(ofp, ", "); 566 567 if (++count % 5 == 0) 568 fprintf(ofp, "\n\t "); 569 570 if (f->flags & FIELD_IS_FLAG) { 571 if ((count - 1) % 5 != 0) { 572 fprintf(ofp, "\n\t "); 573 count = 4; 574 } 575 fprintf(ofp, "flag_str(\""); 576 fprintf(ofp, "%s::%s\", ", event->system, 577 event->name); 578 fprintf(ofp, "\"%s\", $%s)", f->name, 579 f->name); 580 } else if (f->flags & FIELD_IS_SYMBOLIC) { 581 if ((count - 1) % 5 != 0) { 582 fprintf(ofp, "\n\t "); 583 count = 4; 584 } 585 fprintf(ofp, "symbol_str(\""); 586 fprintf(ofp, "%s::%s\", ", event->system, 587 event->name); 588 fprintf(ofp, "\"%s\", $%s)", f->name, 589 f->name); 590 } else 591 fprintf(ofp, "$%s", f->name); 592 } 593 594 fprintf(ofp, ");\n"); 595 fprintf(ofp, "}\n\n"); 596 } 597 598 fprintf(ofp, "sub trace_unhandled\n{\n\tmy ($event_name, $context, " 599 "$common_cpu, $common_secs, $common_nsecs,\n\t " 600 "$common_pid, $common_comm) = @_;\n\n"); 601 602 fprintf(ofp, "\tprint_header($event_name, $common_cpu, " 603 "$common_secs, $common_nsecs,\n\t $common_pid, " 604 "$common_comm);\n}\n\n"); 605 606 fprintf(ofp, "sub print_header\n{\n" 607 "\tmy ($event_name, $cpu, $secs, $nsecs, $pid, $comm) = @_;\n\n" 608 "\tprintf(\"%%-20s %%5u %%05u.%%09u %%8u %%-20s \",\n\t " 609 "$event_name, $cpu, $secs, $nsecs, $pid, $comm);\n}\n"); 610 611 fprintf(ofp, 612 "\n# Packed byte string args of process_event():\n" 613 "#\n" 614 "# $event:\tunion perf_event\tutil/event.h\n" 615 "# $attr:\tstruct perf_event_attr\tlinux/perf_event.h\n" 616 "# $sample:\tstruct perf_sample\tutil/event.h\n" 617 "# $raw_data:\tperf_sample->raw_data\tutil/event.h\n" 618 "\n" 619 "sub process_event\n" 620 "{\n" 621 "\tmy ($event, $attr, $sample, $raw_data) = @_;\n" 622 "\n" 623 "\tmy @event\t= unpack(\"LSS\", $event);\n" 624 "\tmy @attr\t= unpack(\"LLQQQQQLLQQ\", $attr);\n" 625 "\tmy @sample\t= unpack(\"QLLQQQQQLL\", $sample);\n" 626 "\tmy @raw_data\t= unpack(\"C*\", $raw_data);\n" 627 "\n" 628 "\tuse Data::Dumper;\n" 629 "\tprint Dumper \\@event, \\@attr, \\@sample, \\@raw_data;\n" 630 "}\n"); 631 632 fclose(ofp); 633 634 fprintf(stderr, "generated Perl script: %s\n", fname); 635 636 return 0; 637} 638 639struct scripting_ops perl_scripting_ops = { 640 .name = "Perl", 641 .start_script = perl_start_script, 642 .stop_script = perl_stop_script, 643 .process_event = perl_process_event, 644 .generate_script = perl_generate_script, 645}; 646