Rework AV index labels to avoid using NPattr_PRE_ATTR

diff --git a/Memory.xs b/Memory.xs
index 4c6d9ff..d3634a4 100644 (file)
--- 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 (executable)
--- 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 (file)
--- 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;