[svn:parrot] r42803 - in trunk: . tools/dev

cotto at svn.parrot.org cotto at svn.parrot.org
Wed Nov 25 08:11:18 UTC 2009


Author: cotto
Date: Wed Nov 25 08:11:16 2009
New Revision: 42803
URL: https://trac.parrot.org/parrot/changeset/42803

Log:
[pprof2cg] add an initial (not-quite-working) nqp port of pprof2cg

Added:
   trunk/tools/dev/pprof2cg.nqp   (contents, props changed)
Modified:
   trunk/MANIFEST
   trunk/tools/dev/pprof2cg.pl

Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST	Wed Nov 25 05:30:51 2009	(r42802)
+++ trunk/MANIFEST	Wed Nov 25 08:11:16 2009	(r42803)
@@ -1,7 +1,7 @@
 # ex: set ro:
 # $Id$
 #
-# generated by tools/dev/mk_manifest_and_skip.pl Fri Nov 20 00:17:56 2009 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Wed Nov 25 08:07:07 2009 UT
 #
 # See below for documentation on the format of this file.
 #
@@ -2188,6 +2188,7 @@
 tools/dev/pbc_to_exe.pir                                    [devel]
 tools/dev/pmcrenumber.pl                                    []
 tools/dev/pmctree.pl                                        []
+tools/dev/pprof2cg.nqp                                      []
 tools/dev/pprof2cg.pl                                       []
 tools/dev/reconfigure.pl                                    [devel]
 tools/dev/search-ops.pl                                     []

Added: trunk/tools/dev/pprof2cg.nqp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/tools/dev/pprof2cg.nqp	Wed Nov 25 08:11:16 2009	(r42803)
@@ -0,0 +1,282 @@
+#! parrot-nqp
+
+
+#XXX: can't do main with args yet, so fake it
+
+main();
+
+sub main() {
+
+    my $filename := pir::getinterp__P[2][1];
+    say("filename is $filename");
+
+    my %stats;
+    %stats<'global_stats'><'total_time'> := 0;
+
+    my $fh := pir::new__PP("FileHandle");
+    $fh.open($filename, "r");
+    
+    process_input($fh, %stats);
+
+    $fh.close();
+
+    #print_stats(%stats);
+
+    $filename := $filename ~ ".out";
+
+    $fh.open($filename, "w");
+    my @profile := get_cg_profile(%stats);
+    for @profile -> $line {
+        $fh.print($line ~ "\n");
+    }
+    $fh.close();
+    say("all done.");
+}
+
+sub process_input($fh, %stats) {
+    my @call_stack;
+    my $line := $fh.readline();
+
+    while (!$fh.eof()) {
+
+        my $type := pir::substr($line, 0, pir::index($line, ':'));
+        my $data := pir::substr($line, pir::index($line, ':')+1);
+        #say("data is '$data'");
+
+        if ($type eq "OP") {
+            #say("found an op line");
+            
+            my %op_hash := split_line($data);
+            my %cur_ctx := @call_stack[0];
+
+            if (pir::defined__IP(%cur_ctx<line>) && %op_hash<line> == %cur_ctx<line>) {
+                %cur_ctx<op_num>++;
+            }
+            else {
+                %cur_ctx<op_num> := 0;
+            }
+
+            my $op_time     := %op_hash<time>;
+            # += would be nice here
+            my $global_time := $op_time + %stats<global_stats><time>;
+            %cur_ctx<line>  := %op_hash<line>;
+            %stats<global_stats><time> := $global_time;
+            store_stats(%stats, %cur_ctx, $op_time, %op_hash<op>);
+
+            my $skip_first := 1;
+            for @call_stack {
+                if $skip_first {
+                    $skip_first--;
+                }
+                else {
+                    %stats{ $_<file> }{ $_<ns> }{ $_<line> }[ $_<op_num> ]<time> :=
+                      %stats{ $_<file> }{ $_<ns> }{ $_<line> }[ $_<op_num> ]<time> + $op_time;
+                }
+            }
+        }
+
+        elsif ($type eq "CS") {
+            #say("found a context switch line");
+
+            my %cs_hash := split_line($data);
+            if (@call_stack == 0) {
+                #say("ctx stack is empty");
+                @call_stack[0] := %cs_hash;
+            }
+            else {
+                my %cur_ctx      := @call_stack[0];
+                my $hash_ctx     := %cs_hash<ctx>;
+                my $is_redundant := %cur_ctx<ctx> eq $hash_ctx;
+                my $reused_ctx   := $is_redundant && %cur_ctx<sub> != %cs_hash<sub>;
+
+                if ($reused_ctx) {
+                    #say("is reused: $hash_ctx vs " ~ %cur_ctx<ctx>);
+                    %cur_ctx<ns>  := %cs_hash<ns>;
+                    %cur_ctx<sub> := %cs_hash<sub>;
+                }
+                
+                elsif $is_redundant {
+                    #say("is redundant: $hash_ctx vs " ~ %cur_ctx<ctx>);
+                }
+                else {
+                    my $found_ctx := 0;
+                    for @call_stack {
+                        #would be nice to exit early
+                        $found_ctx := $found_ctx || $_<ctx> eq $hash_ctx;
+                    }
+
+                    if $found_ctx {
+                        pir::shift(@call_stack) while @call_stack[0]<ctx> ne $hash_ctx
+                    }
+                    else {
+                        %cur_ctx<op_num>++;
+                        store_stats(%stats, @call_stack[0], 0, "CALL", :target(%cs_hash<ns>));
+                        pir::unshift(@call_stack, %cs_hash);
+                    }
+                }
+            }
+        }
+
+        elsif ($type eq "VERSION") {
+            my $version_num;
+            Q:PIR {
+                $P0 = find_lex "$data"
+                $I0 = $P0
+                $P0 = box $I0
+                store_lex "$version_num", $P0
+            };
+            #say("found a version line: '$version_num'");
+            if ($version_num != 1) {
+                say("pprof is from an incompatible Parrot version");
+                pir::exit(1);
+            }
+        }
+        elsif ($type eq "CLI") {
+            #say("found a CLI line");
+            %stats{'global_stats'}{'cli'} := $data;
+        }
+        elsif (pir::index($line, "END_OF_RUNLOOP") == 0) {
+            #say("found an end of runloop line");
+            @call_stack := ();
+        }
+        elsif (pir::index($line, "#") == 0) {
+            #say("found a comment line");
+        }
+        else {
+            say("don't know what to do with this line: \"$line\"");
+        }
+        $line := $fh.readline();
+    }
+}
+
+
+sub store_stats(%stats, %loc, $time, $op_name, :$target?) {
+
+    my %op_stats;
+    if pir::defined__IP( %stats{ %loc<file> }{ %loc<ns> }{ %loc<line> }[ %loc<op_num> ] ) {
+        %op_stats := %stats{ %loc<file> }{ %loc<ns> }{ %loc<line> }[ %loc<op_num> ];
+    }
+    else {
+        %op_stats := %stats{ %loc<file> }{ %loc<ns> }{ %loc<line> }[ %loc<op_num> ] := {};
+    }
+    say("storing stats in file " ~ ~%loc<file>);
+
+    if %op_stats<hits> {
+        %op_stats<hits>++;
+        %op_stats<time> := %op_stats<time> + $time;
+    }
+    else {
+        %op_stats<hits>    := 1;
+        %op_stats<time>    := $time;
+        %op_stats<op_name> := $op_name;
+        %op_stats<target>  := $target if pir::defined__IP($target);
+    }
+}
+
+sub print_stats(%stats) {
+#    for %stats -> $file {
+#        if $file ne 'global_stats' {
+#            for %stats{$file} -> $ns {
+#                for %stats{$file}{$ns} -> $line_num {
+#                    my $max_op := +%stats{$file}{$ns}{$line_num};
+#                    my $cur_op := 0;
+#                    while ($cur_op < $max_op) {
+#                        print("$file  $ns  line/op:$line_num/$cur_op");
+#                        for %stats{$file}{$ns}{$line_num}[$cur_op] -> $attr {
+#                            print(" $attr => " ~ ~%stats{$file}{$ns}{$line_num}[$cur_op]{$attr});
+#                        }
+#                        $cur_op++;
+#                        print("\n");
+#                    }
+#                }
+#                print("\n");
+#            }
+#        }
+#    }
+    pir::load_bytecode("./parrot/runtime/parrot/library/dumper.pbc");
+    _dumper(%stats);
+}
+
+
+sub get_cg_profile(%stats) {
+    my @output;
+    @output.push("version: 1");
+    @output.push("creator: PARROT IS AWESOME");
+    @output.push("pid: 5751");
+    @output.push("cmd: " ~ ~%stats<global_stats><cli>);
+    @output.push("");
+    @output.push("part: a");
+    @output.push("desc: I1 cache:");
+    @output.push("desc: D1 cache:");
+    @output.push("desc: L2 cache:");
+    @output.push("desc: Timerange: Basic block 0 - " ~ +%stats<global_stats><total_time>);
+    @output.push("desc: Trigger: Program termination");
+    @output.push("positions: line");
+    @output.push("events: Ir");
+    @output.push("summary: "~ %stats<global_stats><total_time>);
+    @output.push("");
+
+    for %stats -> $file {
+        unless $file eq "global_stats" {
+            @output.push("fl=$file");
+            for %stats{$file} -> $ns {
+                @output.push("\nfn=$ns");
+
+                #%stats{$file}{$ns}.sort();
+                for %stats{$file}{$ns} -> $line {
+                    my $curr_op    := 0;
+                    my @line_stats := %stats{$file}{$ns}{$line};
+                    my $op_count   := + at line_stats;
+                    my $op_time    := 0;
+
+                    while $curr_op < $op_count && @line_stats[$curr_op]<name> ne "CALL"  {
+                        $op_time := $op_time + @line_stats[$curr_op]<time>;
+                        $curr_op++;
+                    }
+                    @output.push(~$line ~ " " ~ ~$op_time);
+                    
+                    if $curr_op < $op_count && @line_stats[$curr_op]<name> eq "CALL" {
+                        my $hits   := @line_stats[$curr_op]<hits>;
+                        my $time   := @line_stats[$curr_op]<time>;
+                        my $target := @line_stats[$curr_op]<target>;
+                        @output.push("cfn=$target");
+                        @output.push("calls=$hits $time");
+                    }
+                    
+                    if $curr_op < $op_count {
+                        $op_time := 0;
+                        while $curr_op < $op_count {
+                            $op_time := $op_time + @line_stats[$curr_op]<time>;
+                            $curr_op++;
+                        }
+                        @output.push("$line $op_time");
+                    }
+                }
+            }
+        }
+    }
+    @output.push("totals: " ~ ~%stats<global_stats><total_time>);
+    @output;
+}
+
+
+sub split_line($line) {
+    my %values := {};
+
+    #take off the opening and closing {x{ and }x}
+    $line   := pir::substr($line, 3);
+    my $len := pir::length($line);
+    $len    := $len - 4;
+    $line   := pir::substr($line, 0, $len);
+
+    my @attrs := pir::split('}x}{x{', $line);
+
+    for @attrs {
+        my $idx       := pir::index($_, ":");
+        my $key       := pir::substr($_, 0, $idx);
+        my $value     := pir::substr($_, $idx+1);
+        %values{$key} := $value;
+        #say("key is $key, value is $value");
+    }
+    return %values;
+}

Modified: trunk/tools/dev/pprof2cg.pl
==============================================================================
--- trunk/tools/dev/pprof2cg.pl	Wed Nov 25 05:30:51 2009	(r42802)
+++ trunk/tools/dev/pprof2cg.pl	Wed Nov 25 08:11:16 2009	(r42803)
@@ -129,7 +129,7 @@
 
     close($in_fh) or die "couldn't close $filename: $!";
 
-    #print_stats($stats);
+    print_stats($stats);
 
     unless ($filename =~ s/pprof/out/) {
         $filename = "$filename.out";
@@ -238,7 +238,8 @@
             $stats->{'global_stats'}{'cli'} = $1;
         }
         elsif ($line =~ /^END_OF_RUNLOOP$/) {
-            #end of loop
+            # This is the end of an outermost runloop.  Several of these can
+            # occur during the execution of a script, e.g. for :init subs.
             @$call_stack = ();
         }
         elsif ($line =~ /^#/) {


More information about the parrot-commits mailing list