[svn:parrot] r40920 - branches/pluggable_runcore/tools/dev
cotto at svn.parrot.org
cotto at svn.parrot.org
Wed Sep 2 10:45:13 UTC 2009
Author: cotto
Date: Wed Sep 2 10:45:10 2009
New Revision: 40920
URL: https://trac.parrot.org/parrot/changeset/40920
Log:
[profiling] initial refactor of (incomplete) postprocessing script
It doesn't produce anything that Callgrind can use quite yet, but it has most of what's needed.
Modified:
branches/pluggable_runcore/tools/dev/pprof2cg.pl
Modified: branches/pluggable_runcore/tools/dev/pprof2cg.pl
==============================================================================
--- branches/pluggable_runcore/tools/dev/pprof2cg.pl Wed Sep 2 08:16:36 2009 (r40919)
+++ branches/pluggable_runcore/tools/dev/pprof2cg.pl Wed Sep 2 10:45:10 2009 (r40920)
@@ -1,5 +1,9 @@
#!/usr/bin/perl
+# Copyright (C) 2009, Parrot Foundation.
+# $Id$
+
+
no warnings;
use v5.10.0;
use warnings;
@@ -7,132 +11,150 @@
use Data::Dumper;
-#what about throw and rethrow?
-my @call_ops = (qw{invoke invokecc callmethod callmethodcc});
-my @return_ops = (qw{yield returncc tailcall tailcallmethod});
-my @prof_stack = ();
+=head1 NAME
+
+tools/dev/pprof2cg.pl
+
+=head1 DESCRIPTION
+
+Convert the output of Parrot's profiling runcore to a Callgrind-compatible
+format.
+
+=head1 USAGE
+
+Generate a profile by passing C<-Rprofiling> to parrot, for example C<./parrot
+-Rprofiling perl6.pbc hello.p6>. Once execution completes, parrot will print a
+message specifying the location of profile. The profile will usually be named
+parrot.XXXX.pprof, where XXXX is the PID of the parrot process.
+
+=cut
+
+
+my @ctx_stack = ();
my %stats;
-my ($file, $func, $line, $op_seq, $op) = ('', '', 0, 0, 0);
-my ($call, $return) = (0,0);
-my $prev_func = '';
my $total_time = 0;
-my $func_num = 0;
-my ($prev_line, $new_line, $op_num) = (0,0,0);
+my $prev_line = 0;
+
-sub maybe_say(@) {
- say @_;
+sub split_vars{
+ my $href;
+ my $str = shift;
+ while ($str =~ /\G { ([^:]+) : (.*?) } /cxg) {
+ $href->{$1} = $2;
+ }
+ return $href;
+}
+
+sub store_stats {
+ my $stats_ref = shift;
+ my $locator = shift;
+ my $time = shift;
+ my $extra = shift;
+
+ my $file = $locator->{'file'};
+ my $ns = $locator->{'ns'};
+ my $line = $locator->{'line'};
+ my $op_num = $locator->{'op_num'};
+
+ if (exists $stats_ref->{$file}{$ns}{$line}[$op_num]) {
+ $stats_ref->{$file}{$ns}{$line}[$op_num]{'hits'}++
+ unless exists $extra->{no_hits};
+ $stats_ref->{$file}{$ns}{$line}[$op_num]{'time'} += $time;
+ }
+ else {
+ $stats_ref->{$file}{$ns}{$line}[$op_num]{'hits'} = 1;
+ $stats_ref->{$file}{$ns}{$line}[$op_num]{'time'} = $time;
+ for my $key (keys %{$extra}) {
+ $stats_ref->{$file}{$ns}{$line}[$op_num]{$key} = $extra->{$key};
+ }
+ }
}
+
while (<>) {
+
if (/^#/) {
- #comment: don't do anything
+ #comments are always ignored
}
- elsif (/^F:(.*)$/) {
- $file = $1;
- #maybe_say "found file $file";
- $stats{$file} = {} unless exists $stats{$file};
- }
- elsif (/S:(.*)$/) {
- $prev_func = $func;
- $func = $1;
- maybe_say "found func $func";
-
- $stats{$file}{$func} = {} unless exists $stats{$file}{$func};
-
- if ($return) {
- #pop the current func and op number off the stack
- #the func is there mainly for debugging
- unless (@prof_stack) {
- die "tried to pop off an empty stack when returning from $func";
- }
- for my $frame (@prof_stack) {
- my ($file, $func, $line, $op_num) = @{$frame};
- #maybe_say "($file,$func,$line,$op_num)";
- }
- ($file, $func, $line, $op_num) = @{pop @prof_stack};
- #maybe_say "popped func $func, op $op_num off the stack";
+ elsif (/^VERSION:(\d+)$/) {
+ my $version = $1;
+ if ($version != 1) {
+ die "profile was generated by an incompatible version of the profiling runcore.";
}
}
- elsif (/^ (\d+) : (\d+) : ([^)]*) (?: \( ([^)]+) \) )? \n$/x) {
- my ($line, $op_time, $op, $ns) = ($1, $2, $3, $4);
-
- $new_line = ($line != $prev_line);
- $call = defined $ns;
- $total_time += $op_time;
-
- $prev_line = $line;
+ #context switch
+ elsif (/^CS:(.*)$/) {
- if ($new_line && !$return) {
- $op_num = 0;
+ my $cs_hash = split_vars($1);
+ my $is_first = $#ctx_stack == -1;
+ my $is_redundant = !$is_first && ($ctx_stack[0]{'ctx'} eq $cs_hash->{'ctx'});
+ my $is_call = !scalar(grep {$_->{'ctx'} eq $cs_hash->{'ctx'}} @ctx_stack);
+
+ if ($is_first) {
+ $ctx_stack[0] = $cs_hash;
+ }
+ elsif ($is_redundant) {
+ #don't do anything
+ }
+ elsif ($is_call) {
+
+ $ctx_stack[0]{'op_num'}++;
+ my $extra = {
+ op_name => "CALL",
+ target => $cs_hash->{'ns'}
+ };
+ store_stats(\%stats, $ctx_stack[0], 0, $extra );
+ unshift @ctx_stack, $cs_hash;
}
else {
- $op_num++;
- }
-
- #maybe_say "$func line #$line, op #$op_num is $op";
-
- if ($new_line) {
- $stats{$file}{$func}{$line} = {line_calls_func => 0}
- unless exists $stats{$file}{$func}{$line};
+ shift @ctx_stack while ($ctx_stack[0]->{'ctx'} ne $cs_hash->{'ctx'});
}
+ print Dumper(\@ctx_stack);
+ }
+ elsif (/^OP:(.*)$/) {
+ my $op_hash = split_vars($1);
- if (!exists $stats{$file}{$func}{$line}{$op_num}) {
- $stats{$file}{$func}{$line}{$op_num} = {
- time => $op_time,
- hits => 1,
- op => $op,
- };
+ if (exists $ctx_stack[0]{'line'} && $op_hash->{'line'} == $ctx_stack[0]{'line'}) {
+ $ctx_stack[0]{'op_num'}++;
}
else {
- $stats{$file}{$func}{$line}{$op_num}{time} += $op_time;
- $stats{$file}{$func}{$line}{$op_num}{hits}++;
+ $ctx_stack[0]{'op_num'} = 0;
}
- maybe_say "calling a func" if $call;
- maybe_say "returning from a func" if $return;
+ $ctx_stack[0]{'line'} = $op_hash->{'line'};
+ my $extra = { op_name => $op_hash->{'op'} };
+ store_stats(\%stats, $ctx_stack[0], $op_hash->{'time'}, $extra);
- if ($call) {
+ $extra->{'no_hits'} = 1;
+ for my $frame (@ctx_stack[1 .. $#ctx_stack]) {
+ store_stats(\%stats, $frame, $op_hash->{'time'}, $extra);
+ }
+ }
+}
- #inject a fake op representing the function call
- $op_num++;
- if (!exists $stats{$file}{$func}{$line}{$op_num}) {
- $stats{$file}{$func}{$line}{$op_num} = {
- time => 0,
- hits => 1,
- op => "FUNCTION_CALL",
- func_name => $ns,
- };
- $func_num++;
- }
- else {
- $stats{$file}{$func}{$line}{$op_num}{hits}++;
- }
- maybe_say "pushed func $func, op $op_num onto the stack";
- push @prof_stack, [$file, $func, $line, $op_num];
- for my $frame (@prof_stack) {
- my ($file, $func, $line, $op_num) = @{$frame};
- #maybe_say "($file,$func,$line,$op_num)";
- }
- $stats{$file}{$func}{$line}{line_calls_func} = 1;
- }
- else {
- for my $fun (@prof_stack) {
- my ($file, $func, $line, $op_seq, $op) = @$fun;
- $stats{$file}{$func}{$line}{$op_seq}{time} += $op_time;
+if (1) {
+ for my $file (sort keys %stats) {
+ for my $ns (sort keys %{ $stats{$file} }) {
+ for my $line_num (sort {$a<=>$b} keys %{ $stats{$file}{$ns} }) {
+ for my $op_numbr (0 .. $#{$stats{$file}{$ns}{$line_num}}) {
+
+ print "$file $ns line:$line_num op:$op_numbr ";
+
+ for my $attr (sort keys %{ $stats{$file}{$ns}{$line_num}[$op_numbr] }) {
+ print "{ $attr => $stats{$file}{$ns}{$line_num}[$op_numbr]{$attr} } ";
+ }
+ say "";
+ }
}
+ say "";
}
- $return = ($op ~~ @return_ops);
}
}
-#print Dumper(%stats);
-say "done processing: stack size is ".scalar(@prof_stack);
-for my $frame (@prof_stack) {
- my ($file, $func, $line, $op_num) = @{$frame};
- maybe_say "($file,$func,$line,$op_num)";
-}
+
+=head1
open(OUT_FH, ">parrot.out") or die "couldn't open parrot.out for writing";
More information about the parrot-commits
mailing list