start with 0 bits, hence the start of this array will be hot, and the
end unused. So put the flags next to the hot end. */
void *tracking[256];
+ NV start_time_nv;
int min_recurse_threshold;
/* callback hooks and data */
int (*add_attr_cb)(struct state *st, npath_node_t *npath_node, UV attr_type, const char *name, UV value);
#endif
};
+static NV
+gettimeofday_nv(void)
+{
+#ifdef HAS_GETTIMEOFDAY
+ struct timeval when;
+ gettimeofday(&when, (struct timezone *) 0);
+ return when.tv_sec + (when.tv_usec / 1000000.0);
+#else
+ if (u2time) {
+ UV time_of_day[2];
+ (*u2time)(aTHX_ &time_of_day);
+ return time_of_day[0] + (time_of_day[1] / 1000000.0);
+ }
+ return (NV)time();
+#endif
+}
+
+
int
np_print_node_name(FILE *fp, npath_node_t *npath_node)
{
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",
+ getpid(), gettimeofday_nv()-st->start_time_nv, "unnamed");
if (*st->node_stream_name == '|') {
if (pclose(st->node_stream_fh))
warn("%s exited with an error status\n", st->node_stream_name);
if (NULL != (warn_flag = perl_get_sv("Devel::Size::dangle", FALSE))) {
st->dangle_whine = SvIV(warn_flag) ? TRUE : FALSE;
}
+ st->start_time_nv = gettimeofday_nv();
check_new(st, &PL_sv_undef);
check_new(st, &PL_sv_no);
check_new(st, &PL_sv_yes);
st->node_stream_fh = fopen(st->node_stream_name, "wb");
if (!st->node_stream_fh)
croak("Can't open '%s' for writing: %s", st->node_stream_name, strerror(errno));
- setlinebuf(st->node_stream_fh); /* XXX temporary for debugging */
+ 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",
+ getpid(), st->start_time_nv, "unnamed");
}
else
st->add_attr_cb = np_dump_node_path_info;
use JSON::XS;
use Devel::Dwarn;
use HTML::Entities qw(encode_entities);;
-
+use Data::Dumper;
use Getopt::Long;
+use Carp qw(carp croak confess);
# XXX import these from the XS code
use constant NPtype_NAME => 0x01;
'showid!' => \my $opt_showid,
) or exit 1;
+$| = 1 if $opt_debug;
my $run_size = 0;
my $total_size = 0;
RaiseError => 1, PrintError => 0, AutoCommit => 0
});
$dbh->do("PRAGMA synchronous = OFF");
- $dbh->do("DROP TABLE IF EXISTS node");
- $dbh->do(q{
- CREATE TABLE node (
- id integer primary key,
- name text,
- title text,
- type integer,
- depth integer,
- parent_id integer,
-
- self_size integer,
- kids_size integer,
- kids_node_count integer,
- child_ids text,
- attr_json text,
- leaves_json text
- )
- });
- $node_ins_sth = $dbh->prepare(q{
- INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
- });
}
my @stack;
my $dot_fh;
-if ($opt_dot) {
- open $dot_fh, ">$opt_dot";
- print $dot_fh "digraph {\n"; # }
- print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
-}
sub fmt_size {
my $size = shift;
sub enter_node {
my $x = shift;
+ warn "enter_node $x->{id}\n" if $opt_debug;
my $parent = $stack[-1];
if ($parent) {
sub leave_node {
my $x = shift;
+ confess unless defined $x->{id};
+ warn "leave_node $x->{id}\n" if $opt_debug;
delete $seqn2node{$x->{id}};
my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
my $pending_pre_attr = {};
while (<>) {
+ warn $_ if $opt_debug;
chomp;
my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
}
die "panic: stack already has item at depth $val"
if $stack[$val];
+ die "Depth out of sync\n" if $val != @stack;
my $node = enter_node({
id => $id, type => $type, name => $name, extra => $extra,
attr => { %$pending_pre_attr },
warn "Invalid attribute type '$type' on line $. ($_)";
}
}
+ elsif ($type eq 'S') { # start of a run
+ die "Unexpected start token" if @stack;
+ if ($opt_dot) {
+ open $dot_fh, ">$opt_dot";
+ print $dot_fh "digraph {\n"; # }
+ print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
+ }
+ if ($dbh) {
+ # XXX add a size_run table records each run
+ # XXX pick a table name to store the run nodes in
+ #$run_ins_sth->execute(
+ my $table = "node";
+ $dbh->do("DROP TABLE IF EXISTS $table");
+ $dbh->do(qq{
+ CREATE TABLE $table (
+ id integer primary key,
+ name text,
+ title text,
+ type integer,
+ depth integer,
+ parent_id integer,
+
+ self_size integer,
+ kids_size integer,
+ kids_node_count integer,
+ child_ids text,
+ attr_json text,
+ leaves_json text
+ )
+ });
+ $node_ins_sth = $dbh->prepare(qq{
+ INSERT INTO $table VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
+ });
+ }
+ }
+ elsif ($type eq 'E') { # end of a run
+
+ my $top = $stack[0]; # grab top node before we pop all the nodes
+ leave_node(pop @stack) while @stack;
+ my $top_size = $top->{self_size}+$top->{kids_size};
+
+ printf "Stored %d nodes sizing %s (%d)\n",
+ $top->{kids_node_count}, fmt_size($top_size), $top_size;
+
+ if ($opt_verbose or $run_size != $top_size) {
+ warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n";
+ warn Dumper($top);
+ }
+ die "panic: seqn2node should be empty ". Dumper(\%seqn2node)
+ if %seqn2node;
+ %$pending_pre_attr = ();
+
+ if ($dot_fh) {
+ print $dot_fh "}\n";
+ close $dot_fh;
+ system("open -a Graphviz $opt_dot") if $^O eq 'darwin'; # OSX
+ }
+
+ $dbh->commit if $dbh;
+ }
else {
warn "Invalid type '$type' on line $. ($_)";
next;
$dbh->commit if $dbh and $id % 10_000 == 0;
}
-my $top = $stack[0]; # grab top node before we pop all the nodes
-leave_node(pop @stack) while @stack;
-my $top_size = $top->{self_size}+$top->{kids_size};
-
-printf "Stored %d nodes recording %s (%d)\n",
- $top->{kids_node_count}, fmt_size($top_size), $top_size;
-
-if ($opt_verbose or $run_size != $top_size) {
- warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n";
- warn Dumper($top);
-}
-
-if ($dot_fh) {
- print $dot_fh "}\n";
- close $dot_fh;
- system("open -a Graphviz $opt_dot") if $^O eq 'darwin'; # OSX
-}
-
-$dbh->commit if $dbh;
+die "EOF without end token" if @stack;
-use Data::Dumper;
-warn Dumper(\%seqn2node) if %seqn2node; # should be empty
=for This is out of date but gives you an idea of the data and stream
projects / p5sagit/Devel-Size.git / commitdiff