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