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