From: Tim Bunce Date: Thu, 20 Sep 2012 17:09:58 +0000 (+0100) Subject: Lots of progress. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e8f4c50603f32973f72728a5e5c18a3c465d9753;p=p5sagit%2FDevel-Size.git Lots of progress. Reworked attribute pipeline. Added title concept. Added logarea (incomplete) --- diff --git a/Size.xs b/Size.xs index 03d3032..64bb92d 100644 --- a/Size.xs +++ b/Size.xs @@ -108,7 +108,6 @@ struct state { #define PATH_TRACKING #ifdef PATH_TRACKING -#define NPathAddSizeCb(st, name, bytes) (st->add_attr_cb && st->add_attr_cb(st, NP-1, 0, (name), (bytes))), #define pPATH npath_node_t *NPathArg /* A subtle point here is that dNPathNodes and NPathPushNode leaves NP pointing @@ -149,8 +148,15 @@ struct state { #define NPtype_MAGIC 0x04 #define NPtype_OP 0x05 +#define NPattr_LEAFSIZE 0x00 +#define NPattr_NAME 0x01 +#define NPattr_PADFAKE 0x02 +#define NPattr_PADNAME 0x03 +#define NPattr_PADTMP 0x04 + #define NPathLink(nodeid) ((NP->id = nodeid), (NP->type = NPtype_LINK), (NP->seqn = 0), NP) #define NPathOpLink (NPathArg) +#define NPathAddSizeCb(st, name, bytes) (st->add_attr_cb && st->add_attr_cb(st, NP-1, NPattr_LEAFSIZE, (name), (bytes))), #define ADD_ATTR(st, attr_type, attr_name, attr_value) (st->add_attr_cb && st->add_attr_cb(st, NP-1, attr_type, attr_name, attr_value)) #else @@ -307,11 +313,11 @@ np_stream_node_path_info(struct state *st, npath_node_t *npath_node, UV attr_typ if (!attr_type && !attr_value) return 0; /* ignore zero sized leaf items */ np_walk_new_nodes(st, npath_node, NULL, np_stream_formatted_node); - if (attr_type) { - fprintf(st->node_stream, "A %lu ", npath_node->seqn); /* Attribute name and value */ + if (attr_type) { /* Attribute type, name and value */ + fprintf(st->node_stream, "%lu %lu ", attr_type, npath_node->seqn); } - else { - fprintf(st->node_stream, "L %lu ", npath_node->seqn); /* Leaf name and memory size */ + else { /* Leaf name and memory size */ + fprintf(st->node_stream, "L %lu ", npath_node->seqn); } fprintf(st->node_stream, "%lu %s\n", attr_value, attr_name); return 0; @@ -946,12 +952,12 @@ padlist_size(pTHX_ struct state *const st, pPATH, PADLIST *padlist, } if (namesv) { if (SvFAKE(namesv)) - ADD_ATTR(st, 1, SvPVX_const(namesv), ix); + ADD_ATTR(st, NPattr_PADFAKE, SvPVX_const(namesv), ix); else - ADD_ATTR(st, 1, SvPVX_const(namesv), ix); + ADD_ATTR(st, NPattr_PADNAME, SvPVX_const(namesv), ix); } else { - ADD_ATTR(st, 1, "SVs_PADTMP", ix); + ADD_ATTR(st, NPattr_PADTMP, "SVs_PADTMP", ix); } } @@ -1028,7 +1034,7 @@ sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing, /* Now the array of buckets */ ADD_SIZE(st, "hv_max", (sizeof(HE *) * (HvMAX(thing) + 1))); if (HvENAME(thing)) { - ADD_ATTR(st, 1, HvENAME(thing), 0); + ADD_ATTR(st, NPattr_NAME, HvENAME(thing), 0); } /* Now walk the bucket chain */ if (HvARRAY(thing)) { @@ -1150,7 +1156,7 @@ if (PTR2UV(HeVAL(cur_entry)) > 0xFFF) #else ADD_SIZE(st, "GvNAMELEN", GvNAMELEN(thing)); #endif - ADD_ATTR(st, 1, GvNAME_get(thing), 0); + ADD_ATTR(st, NPattr_NAME, GvNAME_get(thing), 0); #ifdef GvFILE_HEK hek_size(aTHX_ st, GvFILE_HEK(thing), 1, NPathLink("GvFILE_HEK")); #elif defined(GvFILE) @@ -1267,7 +1273,7 @@ UV perl_size() CODE: { - dNPathNodes(1, NULL); + dNPathNodes(2, NULL); struct state *st = new_state(aTHX); NPathPushNode("perl_size", NPtype_NAME); /* provide a root node */ @@ -1275,6 +1281,8 @@ CODE: * this seems to include PL_defgv, PL_incgv etc but I've listed them anyway */ sv_size(aTHX_ st, NPathLink("PL_defstash"), (SV*)PL_defstash, TOTAL_SIZE_RECURSION); + + NPathPushNode("others", NPtype_NAME); /* group these (typically much smaller) items */ sv_size(aTHX_ st, NPathLink("PL_defgv"), (SV*)PL_defgv, TOTAL_SIZE_RECURSION); sv_size(aTHX_ st, NPathLink("PL_incgv"), (SV*)PL_incgv, TOTAL_SIZE_RECURSION); sv_size(aTHX_ st, NPathLink("PL_rs"), (SV*)PL_rs, TOTAL_SIZE_RECURSION); diff --git a/memnodes.pl b/memnodes.pl index 17b548f..cbe4936 100644 --- a/memnodes.pl +++ b/memnodes.pl @@ -3,7 +3,7 @@ use strict; use warnings; -use DBI; +use DBI qw(looks_like_number); use DBD::SQLite; use JSON::XS; @@ -12,6 +12,8 @@ use Getopt::Long; GetOptions( 'json!' => \my $opt_json, 'db=s' => \my $opt_db, + 'verbose|v!' => \my $opt_verbose, + 'debug|d!' => \my $opt_debug, ) or exit 1; my $j = JSON::XS->new->ascii->pretty(0); @@ -25,6 +27,7 @@ $dbh->do(q{ CREATE TABLE node ( id integer primary key, name text, + title text, depth integer, parent_id integer, @@ -37,7 +40,7 @@ $dbh->do(q{ ) }); my $node_ins_sth = $dbh->prepare(q{ - INSERT INTO node VALUES (?,?,?,?, ?,?,?,?,?,?) + INSERT INTO node VALUES (?,?,?,?,?, ?,?,?,?,?,?) }); my @stack; @@ -76,7 +79,7 @@ sub leave_node { my $attr_json = $j->encode($x->{attr}); my $leaves_json = $j->encode($x->{leaves}); $node_ins_sth->execute( - $x->{id}, $x->{name}, $x->{depth}, $x->{parent_id}, + $x->{id}, $x->{name}, $x->{title}, $x->{depth}, $x->{parent_id}, $x->{self_size}, $x->{kids_size}, $x->{kids_node_count}, $x->{child_id} ? join(",", @{$x->{child_id}}) : undef, $attr_json, $leaves_json, @@ -94,10 +97,11 @@ while (<>) { if ($type eq "N") { # Node ($val is depth) while ($val < @stack) { leave_node(my $x = pop @stack); - warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"; + warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n" + if $opt_verbose; } die 1 if $stack[$val]; - my $node = $stack[$val] = { id => $id, name => $name, extra => $extra, attr => [], leaves => {}, depth => $val, self_size=>0, kids_size=>0 }; + my $node = $stack[$val] = { id => $id, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 }; enter_node($node); $seqn2node{$id} = $node; } @@ -105,12 +109,28 @@ while (<>) { my $node = $seqn2node{$id} || die; $node->{leaves}{$name} += $val; } - elsif ($type eq "A") { # Attribute name and value + elsif (looks_like_number($type)) { # Attribute type, name and value my $node = $seqn2node{$id} || die; - push @{ $node->{attr} }, $name, $val; # pairs + my $attr = $node->{attr} || die; + if ($type == 1) { # NPattr_NAME + warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n" + if exists $attr->{$type}{$name}; + $attr->{$type}{$name} = $val || $id; + warn "A \@$id: '$name' $val\n"; + $node->{title} = $name if $type == 1 and !$val; + } + elsif (2 <= $type and $type <= 4) { # NPattr_PAD* + warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n" + if defined $attr->{$type}[$val]; + $attr->{$type}[$val] = $name; + } + else { + warn "Invalid attribute type '$type' on line $. ($_)"; + } } else { warn "Invalid type '$type' on line $. ($_)"; + next; } $dbh->commit if $dbh and $id % 10_000 == 0; } diff --git a/static/MemView.pl b/static/MemView.pl index 29eb2b3..d5b76be 100755 --- a/static/MemView.pl +++ b/static/MemView.pl @@ -5,6 +5,11 @@ use warnings; use JSON::XS; use Mojolicious::Lite; +use Getopt::Long; + +GetOptions( + 'db=s' => \(my $opt_db = '../x.db'), +) or exit 1; use ORLite { file => '../x.db', @@ -26,6 +31,8 @@ get '/' => sub { get '/jit_tree/:id/:depth' => sub { my $self = shift; + my $logarea = $self->param('logarea'); + my $id = $self->stash('id'); my $depth = $self->stash('depth'); warn "jit_tree $id $depth"; @@ -33,10 +40,11 @@ get '/jit_tree/:id/:depth' => sub { my $jit_tree = _transform_node_tree($node_tree, sub { my ($node) = @_; my $children = delete $node->{children}; # XXX edits the src tree - $node->{'$area'} = $node->{self_size}+$node->{kids_size}; + my $area = $node->{self_size}+$node->{kids_size}; + $node->{'$area'} = ($logarea) ? log($area) : $area; my $jit_node = { id => $node->{id}, - name => $node->{name}, + name => $node->{title} || $node->{name}, data => $node, }; $jit_node->{children} = $children if $children; @@ -55,8 +63,8 @@ sub _fetch_node_tree { my ($id, $depth) = @_; my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id) or die "Node '$id' not found"; - $node->{attr}{self} = $j->decode(delete $node->{attr_json}); $node->{leaves} = $j->decode(delete $node->{leaves_json}); + $node->{attr} = $j->decode(delete $node->{attr_json}); if ($node->{child_ids}) { my @child_ids = split /,/, $node->{child_ids}; @@ -69,7 +77,31 @@ sub _fetch_node_tree { $child->{name} = "$node->{name} + $child->{name}"; $child->{$_} += $node->{$_} for (qw(self_size)); $child->{$_} = $node->{$_} for (qw(parent_id)); - $child->{attr}{$node->{id}} = $node->{attr}; + + $child->{title} = join " + ", grep { defined && length } $child->{title}, $node->{title}; + warn "Titled $child->{title}" if $child->{title}; + + for my $attr_type (keys %{ $node->{attr} }) { + my $src = $node->{attr}{$attr_type}; + if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value + my $dst = $child->{attr}{$attr_type} ||= {}; + for my $k (keys %$src) { + warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n" + if defined $dst->{$k}; + $dst->{$k} = $src->{$k}; + } + } + else { # ARRAY eg NPattr_PADNAME: {attr}{2}[$val] = $name + my $dst = $child->{attr}{$attr_type} ||= []; + my $idx = @$src; + while (--$idx >= 0) { + warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n" + if defined $dst->[$idx]; + $dst->[$idx] = $src->[$idx]; + } + } + } + $child->{leaves}{$_} += $node->{leaves}{$_} for keys %{ $node->{leaves} }; @@ -138,6 +170,13 @@ Perl Memory TreeMap Go to Parent + +
+
+