From: Tim Bunce Date: Sun, 30 Sep 2012 09:09:10 +0000 (+0900) Subject: Rework AV index labels to avoid using NPattr_PRE_ATTR X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09c6d3bb3c80e322275bf243b021563d6d004bff;p=p5sagit%2FDevel-Size.git Rework AV index labels to avoid using NPattr_PRE_ATTR --- diff --git a/Memory.xs b/Memory.xs index 4c6d9ff..d3634a4 100644 --- a/Memory.xs +++ b/Memory.xs @@ -174,10 +174,11 @@ struct state { #define NPattr_PADNAME 0x03 #define NPattr_PADTMP 0x04 #define NPattr_NOTE 0x05 -#define NPattr_PRE_ATTR 0x06 +#define NPattr_PRE_ATTR 0x06 /* deprecated */ #define _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, np) (st->add_attr_cb && st->add_attr_cb(st, np, attr_type, attr_name, attr_value)) #define ADD_ATTR(st, attr_type, attr_name, attr_value) _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP-1) +#define ADD_LINK_ATTR(st, attr_type, attr_name, attr_value) (assert(NP->seqn), _ADD_ATTR_NP(st, attr_type, attr_name, attr_value, NP)) #define ADD_PRE_ATTR(st, attr_type, attr_name, attr_value) (assert(!attr_type), _ADD_ATTR_NP(st, NPattr_PRE_ATTR, attr_name, attr_value, NP-1)) #define _NPathLink(np, nid, ntype) (((np)->id=nid), ((np)->type=ntype), ((np)->seqn=0)) @@ -1085,8 +1086,8 @@ sv_size(pTHX_ struct state *const st, pPATH, const SV * const orig_thing, SSize_t i = AvFILLp(thing) + 1; while (i--) { - ADD_PRE_ATTR(st, 0, "index", i); - sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse); + if (sv_size(aTHX_ st, NPathLink("AVelem"), AvARRAY(thing)[i], recurse)) + ADD_LINK_ATTR(st, NPattr_NOTE, "i", i); } } } @@ -1308,7 +1309,7 @@ static void free_memnode_state(pTHX_ struct state *st) { if (st->node_stream_fh && st->node_stream_name && *st->node_stream_name) { - fprintf(st->node_stream_fh, "E %lu %f %s\n", + fprintf(st->node_stream_fh, "E %d %f %s\n", getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed"); if (*st->node_stream_name == '|') { if (pclose(st->node_stream_fh)) @@ -1357,7 +1358,7 @@ new_state(pTHX) croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno)); if(0)setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */ st->add_attr_cb = np_stream_node_path_info; - fprintf(st->node_stream_fh, "S %lu %f %s\n", + fprintf(st->node_stream_fh, "S %d %f %s\n", getpid(), st->start_time_nv, "unnamed"); } else diff --git a/bin/sizeme_store.pl b/bin/sizeme_store.pl index b74776d..b66ac38 100755 --- a/bin/sizeme_store.pl +++ b/bin/sizeme_store.pl @@ -41,6 +41,7 @@ use constant NPattr_PADNAME => 0x03; use constant NPattr_PADTMP => 0x04; use constant NPattr_NOTE => 0x05; use constant NPattr_PRE_ATTR => 0x06; +my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE PREATTR)); # XXX get from XS in some way GetOptions( @@ -89,13 +90,15 @@ sub fmt_size { sub enter_node { my $x = shift; - warn "enter_node $x->{id}\n" if $opt_debug; + warn ">> enter_node $x->{id}\n" if $opt_debug; my $parent = $stack[-1]; if ($parent) { if ($x->{name} eq 'AVelem' and $parent->{name} eq 'SV(PVAV)') { - my $index = $x->{attr}{index}; + my $index = $x->{attr}{+NPattr_NOTE}{i}; + Dwarn $x->{attr}; + Dwarn $index; # If node is an AVelem of a CvPADLIST propagate pad name to AVelem if (@stack >= 4 and (my $cvpl = $stack[-4])->{name} eq 'CvPADLIST') { my $padnames = $cvpl->{_cached}{padnames} ||= do { @@ -111,6 +114,7 @@ sub enter_node { $x->{name} = "[$index]" if defined $index; } } + } return $x; @@ -120,12 +124,17 @@ sub enter_node { sub leave_node { my $x = shift; confess unless defined $x->{id}; - warn "leave_node $x->{id}\n" if $opt_debug; + warn "<< leave_node $x->{id}\n" if $opt_debug; delete $seqn2node{$x->{id}}; my $self_size = 0; $self_size += $_ for values %{$x->{leaves}}; $x->{self_size} = $self_size; + if ($x->{name} eq 'AVelem') { + my $index = $x->{attr}{+NPattr_NOTE}{i}; + $x->{name} = "[$index]" if defined $index; + } + my $parent = $stack[-1]; if ($parent) { # link to parent @@ -143,6 +152,7 @@ sub leave_node { $parent ? $parent->{id} : "", $parent ? $parent->{type} : "" if 0; + if ($x->{type} != NPtype_LINK) { my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name}; @@ -158,20 +168,20 @@ sub leave_node { sprintf("label=%s", $dotnode->($name)), "id=$x->{id}", ); - my @link_attr; - #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; } - if ($parent) { # probably a link - my $parent_id = $parent->{id}; - my @link_attr = ("id=$parent_id"); - if ($parent->{type} == NPtype_LINK) { # link - (my $link_name = $parent->{name}) =~ s/->$//; - push @link_attr, (sprintf "label=%s", $dotnode->($link_name)); - $parent_id = ($stack[-2]||die "panic")->{id}; - } + printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr); + } + else { # NPtype_LINK + my @kids = @{$x->{child_id}}; + die "panic: NPtype_LINK has more than one child: @kids" + if @kids > 1; + for my $child_id (@kids) { # wouldn't work right, eg id= attr + #die Dwarn $x; + my @link_attr = ("id=$x->{id}"); + (my $link_name = $x->{name}) =~ s/->$//; + push @link_attr, (sprintf "label=%s", $dotnode->($link_name)); printf $dot_fh qq{n%d -> n%d [%s];\n}, - $parent_id, $x->{id}, join(",", @link_attr); + $x->{parent_id}, $child_id, join(",", @link_attr); } - printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr); } } @@ -191,11 +201,10 @@ sub leave_node { } my $indent = ": "; -my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE)); # XXX get from XS in some way my $pending_pre_attr = {}; while (<>) { - warn $_ if $opt_debug; + warn "== $_" if $opt_debug; chomp; my ($type, $id, $val, $name, $extra) = split / /, $_, 5; @@ -250,8 +259,9 @@ while (<>) { if $opt_text; warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n" if exists $attr->{$type}{$name}; - $attr->{$type}{$name} = $val || $id; - $node->{title} = $name if $type == 1 and !$val; + $attr->{$type}{$name} = $val; + Dwarn $attr; + $node->{title} = $name if $type == NPattr_NAME and !$val; # XXX hack } # attributes where the number is a key (or always zero) elsif (NPattr_PADFAKE==$type or NPattr_PADTMP==$type or NPattr_PADNAME==$type) { diff --git a/lib/Devel/SizeMe.pm b/lib/Devel/SizeMe.pm index abc6742..81e4a88 100644 --- a/lib/Devel/SizeMe.pm +++ b/lib/Devel/SizeMe.pm @@ -3,7 +3,9 @@ package Devel::SizeMe; require Devel::Memory; my $gz = (0) ? "gzip -c | gzip -dc |" : ""; # currently saves ~3% -$ENV{SIZEME} = "| $gz sizeme_store.pl --db sizeme.db"; +$ENV{SIZEME} = "| $gz sizeme_store.pl -d --text --dot=sizeme.dot --showid --db=sizeme.db"; + +my $do_size_at_end = 0; # set true below for "perl -d:SizeMe ..." # It's handy to say "perl -d:SizeMe" but has side effects # currently we simple disable the debugger (as best we can) @@ -16,10 +18,11 @@ $ENV{SIZEME} = "| $gz sizeme_store.pl --db sizeme.db"; if ($^P) { # default is 0x73f warn "Note: Devel::SizeMe currently disables perl debugger mode\n"; $^P = 0; + $do_size_at_end = 1; } END { - Devel::Memory::perl_size(); + Devel::Memory::perl_size() if $do_size_at_end; } 1;