bin/sizeme_store.pl

   1 #!/usr/bin/env perl
   2
   3 =head1 NAME
   4
   5 sizeme_store.pl - process and store the raw data stream from Devel::SizeMe
   6
   7 =head1 SYNOPSIS
   8
   9     sizeme_store.pl [--text] [--dot=sizeme.dot] [--db=sizeme.db]
  10
  11 Typically used with Devel::SizeMe via the C<SIZEME> env var:
  12
  13     export SIZEME='|./sizeme_store.pl --text'
  14     export SIZEME='|./sizeme_store.pl --dot=sizeme.dot'
  15     export SIZEME='|./sizeme_store.pl --db=sizeme.db'
  16
  17 =head1 DESCRIPTION
  18
  19 Reads the raw memory data from Devel::SizeMe and processes the tree
  20 via a stack, propagating data such as totals, up the tree nodes
  21 as the data streams through.  Output completed nodes in the request formats.
  22
  23 The --text output is similar to the textual representation output by the module
  24 when the SIZEME env var is set to an empty string.
  25
  26 The --dot output is suitable for feeding to Graphviz. (On OSX the Graphviz
  27 application will be started automatically.)
  28
  29 The --db output is a SQLite database. The db schema is very subject to change.
  30 This output is destined to be the primary one. The other output types will
  31 probably become separate programs that read the db.
  32
  33 =head1 TODO
  34
  35 Current implementation is all very alpha and rather hackish.
  36
  37 Refactor to separate the core code into a module.
  38
  39 Move the output formats into separate modules, which should probably read from
  40 the db so the db becomes the canonical source of data.
  41
  42 Import constants from XS.
  43
  44 =cut
  45
  46 # Needs to be generalized to support pluggable output formats.
  47 # Actually it needs to be split so sizeme_store.pl only does the store
  48 # and another program drives the output with plugins.
  49 # Making nodes into (lightweight fast) objects would be smart.
  50 # Tests would be even smarter!
  51 #
  52 # When working on this code it's important to have a sense of the flow.
  53 # Specifically the way that depth drives the completion of nodes.
  54 # It's a depth-first stream processing machine, which only ever holds
  55 # a single stack of the currently incomplete nodes, which is always the same as
  56 # the current depth. I.e., when a node of depth N arrives, all nodes >N are
  57 # popped off the stack and 'completed', each rippling data up to its parent.
  58
  59 use strict;
  60 use warnings;
  61 use autodie;
  62
  63 use DBI qw(looks_like_number);
  64 use DBD::SQLite;
  65 use JSON::XS;
  66 use Devel::Dwarn;
  67 use HTML::Entities qw(encode_entities);;
  68 use Data::Dumper;
  69 use Getopt::Long;
  70 use Carp qw(carp croak confess);
  71
  72 # XXX import these from the XS code
  73 use constant NPtype_NAME     => 0x01;
  74 use constant NPtype_LINK     => 0x02;
  75 use constant NPtype_SV       => 0x03;
  76 use constant NPtype_MAGIC    => 0x04;
  77 use constant NPtype_OP       => 0x05;
  78
  79 use constant NPattr_LEAFSIZE => 0x00;
  80 use constant NPattr_NAME     => 0x01;
  81 use constant NPattr_PADFAKE  => 0x02;
  82 use constant NPattr_PADNAME  => 0x03;
  83 use constant NPattr_PADTMP   => 0x04;
  84 use constant NPattr_NOTE     => 0x05;
  85 use constant NPattr_PRE_ATTR => 0x06;
  86 my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE PREATTR)); # XXX get from XS in some way
  87
  88
  89 GetOptions(
  90     'text!' => \my $opt_text,
  91     'dot=s' => \my $opt_dot,
  92     'db=s'  => \my $opt_db,
  93     'verbose|v!' => \my $opt_verbose,
  94     'debug|d!' => \my $opt_debug,
  95     'showid!' => \my $opt_showid,
  96 ) or exit 1;
  97
  98 $| = 1 if $opt_debug;
  99 my $run_size = 0;
 100 my $total_size = 0;
 101
 102 my $j = JSON::XS->new->ascii->pretty(0);
 103
 104 my ($dbh, $node_ins_sth);
 105 if ($opt_db) {
 106     $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
 107         RaiseError => 1, PrintError => 0, AutoCommit => 0
 108     });
 109     $dbh->do("PRAGMA synchronous = OFF");
 110 }
 111
 112 my @stack;
 113 my %seqn2node;
 114
 115 my $dotnode = sub {
 116     my $name = encode_entities(shift);
 117     $name =~ s/"/\\"/g;
 118     return '"'.$name.'"';
 119 };
 120
 121
 122 my $dot_fh;
 123
 124 sub fmt_size {
 125     my $size = shift;
 126     my $kb = $size / 1024;
 127     return $size if $kb < 5;
 128     return sprintf "%.1fKb", $kb if $kb < 1000;
 129     return sprintf "%.1fMb", $kb/1024;
 130 }
 131
 132
 133 sub enter_node {
 134     my $x = shift;
 135     warn ">> enter_node $x->{id}\n" if $opt_debug;
 136
 137     my $parent = $stack[-1];
 138     if ($parent) {
 139
 140         if ($x->{name} eq 'AVelem' and $parent->{name} eq 'SV(PVAV)') {
 141             my $index = $x->{attr}{+NPattr_NOTE}{i};
 142             #Dwarn $x->{attr};
 143             #Dwarn $index;
 144             # If node is an AVelem of a CvPADLIST propagate pad name to AVelem
 145             if (@stack >= 4 and (my $cvpl = $stack[-4])->{name} eq 'CvPADLIST') {
 146                 my $padnames = $cvpl->{_cached}{padnames} ||= do {
 147                     my @names = @{ $cvpl->{attr}{+NPattr_PADNAME} || []};
 148                     $_ = "my(".($_||'').")" for @names;
 149                     $names[0] = '@_';
 150                     \@names;
 151                 };
 152                 $x->{name} = (defined $index and $padnames->[$index]) || "?";
 153                 $x->{name} =~ s/my\(SVs_PADTMP\)/PADTMP/; # XXX hack for neatness
 154             }
 155             else {
 156                 $x->{name} = "[$index]" if defined $index;
 157             }
 158         }
 159
 160     }
 161
 162     return $x;
 163 }
 164
 165
 166 sub leave_node {
 167     my $x = shift;
 168     confess unless defined $x->{id};
 169     warn "<< leave_node $x->{id}\n" if $opt_debug;
 170     delete $seqn2node{$x->{id}};
 171
 172     my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
 173     $x->{self_size} = $self_size;
 174
 175     if ($x->{name} eq 'AVelem') {
 176         my $index = $x->{attr}{+NPattr_NOTE}{i};
 177         $x->{name} = "[$index]" if defined $index;
 178     }
 179
 180     my $parent = $stack[-1];
 181     if ($parent) {
 182         # link to parent
 183         $x->{parent_id} = $parent->{id};
 184         # accumulate into parent
 185         $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
 186         $parent->{kids_size} += $self_size + $x->{kids_size};
 187         push @{$parent->{child_id}}, $x->{id};
 188     }
 189     else {
 190         $x->{kids_node_count} ||= 0;
 191     }
 192
 193     # output
 194     # ...
 195     if ($opt_dot) {
 196         printf "// n%d parent=%s(type=%s)\n", $x->{id},
 197                 $parent ? $parent->{id} : "",
 198                 $parent ? $parent->{type} : ""
 199             if 0;
 200
 201         if ($x->{type} != NPtype_LINK) {
 202             my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
 203
 204             if ($x->{kids_size}) {
 205                 $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
 206             }
 207             else {
 208                 $name .= sprintf " +%s", fmt_size($x->{self_size});
 209             }
 210             $name .= " #$x->{id}" if $opt_showid;
 211
 212             my @node_attr = (
 213                 sprintf("label=%s", $dotnode->($name)),
 214                 "id=$x->{id}",
 215             );
 216             printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
 217         }
 218         else { # NPtype_LINK
 219             my @kids = @{$x->{child_id}||[]};
 220             die "panic: NPtype_LINK has more than one child: @kids"
 221                 if @kids > 1;
 222             for my $child_id (@kids) { # wouldn't work right, eg id= attr
 223                 #die Dwarn $x;
 224                 my @link_attr = ("id=$x->{id}");
 225                 (my $link_name = $x->{name}) =~ s/->$//;
 226                 $link_name .= " #$x->{id}" if $opt_showid;
 227                 push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
 228                 printf $dot_fh qq{n%d -> n%d [%s];\n},
 229                     $x->{parent_id}, $child_id, join(",", @link_attr);
 230             }
 231         }
 232
 233     }
 234     if ($dbh) {
 235         my $attr_json = $j->encode($x->{attr});
 236         my $leaves_json = $j->encode($x->{leaves});
 237         $node_ins_sth->execute(
 238             $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
 239             $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
 240             $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
 241             $attr_json, $leaves_json,
 242         );
 243         # XXX attribs
 244     }
 245
 246     return $x;
 247 }
 248
 249 my $indent = ":   ";
 250
 251 while (<>) {
 252     warn "\t\t\t\t== $_" if $opt_debug;
 253     chomp;
 254
 255     my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
 256
 257     if ($type =~ s/^-//) {     # Node type ($val is depth)
 258
 259         printf "%s%s%s %s [#%d @%d]\n", $indent x $val, $name,
 260                 ($type == NPtype_LINK) ? "->" : "",
 261                 $extra||'', $id, $val
 262             if $opt_text;
 263
 264         # this is the core driving logic
 265         while ($val < @stack) {
 266             my $x = leave_node(pop @stack);
 267             warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
 268                 if $opt_verbose;
 269         }
 270         die "panic: stack already has item at depth $val"
 271             if $stack[$val];
 272         die "Depth out of sync\n" if $val != @stack;
 273         my $node = enter_node({
 274             id => $id, type => $type, name => $name, extra => $extra,
 275             attr => { }, leaves => {}, depth => $val, self_size=>0, kids_size=>0
 276         });
 277         $stack[$val] = $node;
 278         $seqn2node{$id} = $node;
 279     }
 280
 281     # --- Leaf name and memory size
 282     elsif ($type eq "L") {
 283         my $node = $seqn2node{$id} || die;
 284         $node->{leaves}{$name} += $val;
 285         $run_size += $val;
 286         printf "%s+%d=%d %s\n", $indent x ($node->{depth}+1), $val, $run_size, $name
 287             if $opt_text;
 288     }
 289
 290     # --- Attribute type, name and value (all rather hackish)
 291     elsif (looks_like_number($type)) {
 292         my $node = $seqn2node{$id} || die;
 293         my $attr = $node->{attr} || die;
 294
 295         # attributes where the string is a key (or always empty and the type is the key)
 296         if ($type == NPattr_NAME or $type == NPattr_NOTE) {
 297             printf "%s~%s(%s) %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
 298                 if $opt_text;
 299             warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
 300                 if exists $attr->{$type}{$name};
 301             $attr->{$type}{$name} = $val;
 302             #Dwarn $attr;
 303             $node->{title} = $name if $type == NPattr_NAME and !$val; # XXX hack
 304         }
 305         # attributes where the number is a key (or always zero)
 306         elsif (NPattr_PADFAKE==$type or NPattr_PADTMP==$type or NPattr_PADNAME==$type) {
 307             printf "%s~%s('%s') %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
 308                 if $opt_text;
 309             warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
 310                 if defined $attr->{$type}[$val];
 311             $attr->{+NPattr_PADNAME}[$val] = $name; # store all as NPattr_PADNAME
 312         }
 313         else {
 314             printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
 315                 if $opt_text;
 316             warn "Invalid attribute type '$type' on line $. ($_)";
 317         }
 318     }
 319     elsif ($type eq 'S') { # start of a run
 320         die "Unexpected start token" if @stack;
 321         if ($opt_dot) {
 322             open $dot_fh, ">$opt_dot";
 323             print $dot_fh "digraph {\n"; # }
 324             print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
 325         }
 326         if ($dbh) {
 327             # XXX add a size_run table records each run
 328             # XXX pick a table name to store the run nodes in
 329             #$run_ins_sth->execute(
 330             my $table = "node";
 331             $dbh->do("DROP TABLE IF EXISTS $table");
 332             $dbh->do(qq{
 333                 CREATE TABLE $table (
 334                     id integer primary key,
 335                     name text,
 336                     title text,
 337                     type integer,
 338                     depth integer,
 339                     parent_id integer,
 340
 341                     self_size integer,
 342                     kids_size integer,
 343                     kids_node_count integer,
 344                     child_ids text,
 345                     attr_json text,
 346                     leaves_json text
 347                 )
 348             });
 349             $node_ins_sth = $dbh->prepare(qq{
 350                 INSERT INTO $table VALUES (?,?,?,?,?,?,  ?,?,?,?,?,?)
 351             });
 352         }
 353     }
 354     elsif ($type eq 'E') { # end of a run
 355
 356         my $top = $stack[0]; # grab top node before we pop all the nodes
 357         leave_node(pop @stack) while @stack;
 358
 359         # if nothing output (ie size(undef))
 360         $top ||= { self_size=>0, kids_size=>0, kids_node_count=>0 };
 361
 362         my $top_size = $top->{self_size}+$top->{kids_size};
 363
 364         printf "Stored %d nodes totalling %s [lines=%d size=%d write=%.2fs]\n",
 365             1+$top->{kids_node_count}, fmt_size($top_size),
 366             $., $top_size, $val;
 367         # the duration here ($val) is from Devel::SizeMe perspective
 368         # ie doesn't include time to read file/pipe and commit to database.
 369
 370         if ($opt_verbose or $run_size != $top_size) {
 371             warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n";
 372             warn Dumper($top);
 373         }
 374         die "panic: seqn2node should be empty ". Dumper(\%seqn2node)
 375             if %seqn2node;
 376
 377         if ($dot_fh) {
 378             print $dot_fh "}\n";
 379             close $dot_fh;
 380             system("open -a Graphviz $opt_dot") if $^O eq 'darwin'; # OSX
 381         }
 382
 383         $dbh->commit if $dbh;
 384     }
 385     else {
 386         warn "Invalid type '$type' on line $. ($_)";
 387         next;
 388     }
 389
 390     $dbh->commit if $dbh and $id % 10_000 == 0;
 391 }
 392 die "EOF without end token" if @stack;
 393
 394
 395 =for This is out of date but gives you an idea of the data and stream
 396
 397 SV(PVAV) fill=1/1       [#1 @0]
 398 :   +64 sv =64
 399 :   +16 av_max =80
 400 :   AVelem->        [#2 @1]
 401 :   :   SV(RV)      [#3 @2]
 402 :   :   :   +24 sv =104
 403 :   :   :   RV->        [#4 @3]
 404 :   :   :   :   SV(PVAV) fill=-1/-1     [#5 @4]
 405 :   :   :   :   :   +64 sv =168
 406 :   AVelem->        [#6 @1]
 407 :   :   SV(IV)      [#7 @2]
 408 :   :   :   +24 sv =192
 409 192 at -e line 1.
 410 =cut
 411 __DATA__
 412 N 1 0 SV(PVAV) fill=1/1
 413 L 1 64 sv
 414 L 1 16 av_max
 415 N 2 1 AVelem->
 416 N 3 2 SV(RV)
 417 L 3 24 sv
 418 N 4 3 RV->
 419 N 5 4 SV(PVAV) fill=-1/-1
 420 L 5 64 sv
 421 N 6 1 AVelem->
 422 N 7 2 SV(IV)
 423 L 7 24 sv