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