[p5sagit/Devel-Size.git] / memnodes.pl

#!/bin/env perl

use strict;
use warnings;

use DBI qw(looks_like_number);
use DBD::SQLite;
use JSON::XS;

use Getopt::Long;

GetOptions(
    'json!' => \my $opt_json,
    'dot!' => \my $opt_dot,
    'db=s'  => \my $opt_db,
    'verbose|v!' => \my $opt_verbose,
    'debug|d!' => \my $opt_debug,
    'showid!' => \my $opt_showid,
) or exit 1;

my $j = JSON::XS->new->ascii->pretty(0);

my ($dbh, $node_ins_sth);
if ($opt_db) {
    $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
        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 %seqn2node;

use HTML::Entities qw(encode_entities);;
my $dotnode = sub {
    my $name = encode_entities(shift);
    $name =~ s/"/\\"/g;
    return '"'.$name.'"';
};

print "memnodes = [" if $opt_json;

if ($opt_dot) {
    print "digraph {\n"; # }
    print "graph [overlap=false]\n"; # target="???", URL="???"
}

sub fmt_size {
    my $size = shift;
    my $kb = $size / 1024;
    return $size if $kb < 5;
    return sprintf "%.1fKb", $kb if $kb < 1000;
    return sprintf "%.1fMb", $kb/1024;
}


sub enter_node {
    my $x = shift;
    if ($opt_json) {
        print "    " x $x->{depth};
        print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
    }
    if ($opt_dot) {
        #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
        #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
    }
    return;
}

sub leave_node {
    my $x = shift;
    delete $seqn2node{$x->{id}};

    my $self_size = 0; $self_size += $_  for values %{$x->{leaves}};
    $x->{self_size} = $self_size;

    my $parent = $stack[-1];
    if ($parent) {
        # link to parent
        $x->{parent_id} = $parent->{id};
        # accumulate into parent
        $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
        $parent->{kids_size} += $self_size + $x->{kids_size};
        push @{$parent->{child_id}}, $x->{id};
    }
    # output
    # ...
    if ($opt_json) {
        print "\t" x $x->{depth};
        my $size = $self_size + $x->{kids_size};
        print qq(], "data":{ "\$area": $size } },\n);
    }
    if ($opt_dot) {
        printf "// n%d parent=%s(type=%s)\n", $x->{id},
                $parent ? $parent->{id} : "",
                $parent ? $parent->{type} : ""
            if 0;
        if ($x->{type} != 2) {
            my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};

            if ($x->{kids_size}) {
                $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
            }
            else {
                $name .= sprintf " +%s", fmt_size($x->{self_size});
            }
            $name .= " $x->{id}" if $opt_showid;

            my @node_attr = (
                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} == 2) { # link
                    (my $link_name = $parent->{name}) =~ s/->$//;
                    push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
                    $parent_id = ($stack[-2]||die "panic")->{id};
                }
                printf qq{n%d -> n%d [%s];\n},
                    $parent_id, $x->{id}, join(",", @link_attr);
            }
            printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
        }

    }
    if ($dbh) {
        my $attr_json = $j->encode($x->{attr});
        my $leaves_json = $j->encode($x->{leaves});
        $node_ins_sth->execute(
            $x->{id}, $x->{name}, $x->{title}, $x->{type}, $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,
        );
        # XXX attribs
    }
    return;
}


while (<>) {
    chomp;
    my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
    if ($type =~ s/^-//) {     # Node type ($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"
                if $opt_verbose;
        }
        die 1 if $stack[$val];
        my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
        enter_node($node);
        $seqn2node{$id} = $node;
    }
    elsif ($type eq "L") {  # Leaf name and memory size
        my $node = $seqn2node{$id} || die;
        $node->{leaves}{$name} += $val;
    }
    elsif (looks_like_number($type)) {  # Attribute type, name and value
        my $node = $seqn2node{$id} || die;
        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;
}

my $x;
while (@stack > 1) {
    leave_node($x = pop @stack) while @stack;
    warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
}
print " ];\n" if $opt_json;
print "}\n" if $opt_dot;

$dbh->commit if $dbh;

use Data::Dumper;
warn Dumper(\$x);
warn Dumper(\%seqn2node);

=for
SV(PVAV) fill=1/1       [#1 @0] 
:   +64 sv =64 
:   +16 av_max =80 
:   AVelem->        [#2 @1] 
:   :   SV(RV)      [#3 @2] 
:   :   :   +24 sv =104 
:   :   :   RV->        [#4 @3] 
:   :   :   :   SV(PVAV) fill=-1/-1     [#5 @4] 
:   :   :   :   :   +64 sv =168 
:   AVelem->        [#6 @1] 
:   :   SV(IV)      [#7 @2] 
:   :   :   +24 sv =192 
192 at -e line 1.
=cut
__DATA__
N 1 0 SV(PVAV) fill=1/1
L 1 64 sv
L 1 16 av_max
N 2 1 AVelem->
N 3 2 SV(RV)
L 3 24 sv
N 4 3 RV->
N 5 4 SV(PVAV) fill=-1/-1
L 5 64 sv
N 6 1 AVelem->
N 7 2 SV(IV)
L 7 24 sv
Commit	Line	Data
2c631ee0	1	#!/bin/env perl
	2
	3	use strict;
	4	use warnings;
	5
e8f4c506	6	use DBI qw(looks_like_number);
b2fc39a5	7	use DBD::SQLite;
f60f09e5	8	use JSON::XS;
b2fc39a5	9
fc6614ee	10	use Getopt::Long;
	11
	12	GetOptions(
	13	'json!' => \my $opt_json,
ee2793c1	14	'dot!' => \my $opt_dot,
b2fc39a5	15	'db=s' => \my $opt_db,
e8f4c506	16	'verbose\|v!' => \my $opt_verbose,
e8f4c506	17	'debug\|d!' => \my $opt_debug,
98128850	18	'showid!' => \my $opt_showid,
fc6614ee	19	) or exit 1;
94fab3d1	20
f60f09e5	21	my $j = JSON::XS->new->ascii->pretty(0);
f60f09e5	22
1915946b	23	my ($dbh, $node_ins_sth);
	24	if ($opt_db) {
	25	$dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
	26	RaiseError => 1, PrintError => 0, AutoCommit => 0
	27	});
	28	$dbh->do("PRAGMA synchronous = OFF");
	29	$dbh->do("DROP TABLE IF EXISTS node");
	30	$dbh->do(q{
	31	CREATE TABLE node (
	32	id integer primary key,
	33	name text,
	34	title text,
98128850	35	type integer,
1915946b	36	depth integer,
	37	parent_id integer,
	38
	39	self_size integer,
	40	kids_size integer,
	41	kids_node_count integer,
	42	child_ids text,
	43	attr_json text,
	44	leaves_json text
	45	)
	46	});
	47	$node_ins_sth = $dbh->prepare(q{
98128850	48	INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
1915946b	49	});
1915946b	50	}
b2fc39a5	51
2c631ee0	52	my @stack;
	53	my %seqn2node;
	54
7020702a	55	use HTML::Entities qw(encode_entities);;
	56	my $dotnode = sub {
	57	my $name = encode_entities(shift);
	58	$name =~ s/"/\\"/g;
7020702a	59	return '"'.$name.'"';
7020702a	60	};
ee2793c1	61
	62	print "memnodes = [" if $opt_json;
	63
	64	if ($opt_dot) {
	65	print "digraph {\n"; # }
	66	print "graph [overlap=false]\n"; # target="???", URL="???"
	67	}
	68
0741448c	69	sub fmt_size {
	70	my $size = shift;
	71	my $kb = $size / 1024;
	72	return $size if $kb < 5;
	73	return sprintf "%.1fKb", $kb if $kb < 1000;
	74	return sprintf "%.1fMb", $kb/1024;
	75	}
	76
ee2793c1	77
94fab3d1	78	sub enter_node {
	79	my $x = shift;
	80	if ($opt_json) {
	81	print " " x $x->{depth};
b2fc39a5	82	print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
94fab3d1	83	}
ee2793c1	84	if ($opt_dot) {
	85	#printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
	86	#print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
	87	}
94fab3d1	88	return;
	89	}
	90
	91	sub leave_node {
	92	my $x = shift;
b2fc39a5	93	delete $seqn2node{$x->{id}};
ee2793c1	94
94fab3d1	95	my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
94fab3d1	96	$x->{self_size} = $self_size;
ee2793c1	97
	98	my $parent = $stack[-1];
	99	if ($parent) {
2c631ee0	100	# link to parent
5a78486c	101	$x->{parent_id} = $parent->{id};
2c631ee0	102	# accumulate into parent
2c631ee0	103	$parent->{kids_node_count} += 1 + ($x->{kids_node_count}\|\|0);
94fab3d1	104	$parent->{kids_size} += $self_size + $x->{kids_size};
5a78486c	105	push @{$parent->{child_id}}, $x->{id};
2c631ee0	106	}
	107	# output
	108	# ...
94fab3d1	109	if ($opt_json) {
98128850	110	print "\t" x $x->{depth};
94fab3d1	111	my $size = $self_size + $x->{kids_size};
	112	print qq(], "data":{ "\$area": $size } },\n);
	113	}
ee2793c1	114	if ($opt_dot) {
1915946b	115	printf "// n%d parent=%s(type=%s)\n", $x->{id},
0741448c	116	$parent ? $parent->{id} : "",
	117	$parent ? $parent->{type} : ""
	118	if 0;
1915946b	119	if ($x->{type} != 2) {
0741448c	120	my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
	121
	122	if ($x->{kids_size}) {
	123	$name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
	124	}
	125	else {
	126	$name .= sprintf " +%s", fmt_size($x->{self_size});
	127	}
98128850	128	$name .= " $x->{id}" if $opt_showid;
0741448c	129
	130	my @node_attr = (
	131	sprintf("label=%s", $dotnode->($name)),
	132	"id=$x->{id}",
	133	);
	134	my @link_attr;
	135	#if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
1915946b	136	if ($parent) { # probably a link
1915946b	137	my $parent_id = $parent->{id};
0741448c	138	my @link_attr = ("id=$parent_id");
1915946b	139	if ($parent->{type} == 2) { # link
	140	(my $link_name = $parent->{name}) =~ s/->$//;
	141	push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
	142	$parent_id = ($stack[-2]\|\|die "panic")->{id};
	143	}
	144	printf qq{n%d -> n%d [%s];\n},
	145	$parent_id, $x->{id}, join(",", @link_attr);
	146	}
	147	printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
	148	}
	149
ee2793c1	150	}
b2fc39a5	151	if ($dbh) {
f60f09e5	152	my $attr_json = $j->encode($x->{attr});
e78b28ca	153	my $leaves_json = $j->encode($x->{leaves});
b2fc39a5	154	$node_ins_sth->execute(
98128850	155	$x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
b2fc39a5	156	$x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
f60f09e5	157	$x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
e78b28ca	158	$attr_json, $leaves_json,
b2fc39a5	159	);
	160	# XXX attribs
	161	}
94fab3d1	162	return;
2c631ee0	163	}
2c631ee0	164
94fab3d1	165
2c631ee0	166	while (<>) {
2c631ee0	167	chomp;
b2fc39a5	168	my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
ee2793c1	169	if ($type =~ s/^-//) { # Node type ($val is depth)
2c631ee0	170	while ($val < @stack) {
94fab3d1	171	leave_node(my $x = pop @stack);
e8f4c506	172	warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
e8f4c506	173	if $opt_verbose;
2c631ee0	174	}
2c631ee0	175	die 1 if $stack[$val];
ee2793c1	176	my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
94fab3d1	177	enter_node($node);
b2fc39a5	178	$seqn2node{$id} = $node;
2c631ee0	179	}
2c631ee0	180	elsif ($type eq "L") { # Leaf name and memory size
b2fc39a5	181	my $node = $seqn2node{$id} \|\| die;
2c631ee0	182	$node->{leaves}{$name} += $val;
2c631ee0	183	}
e8f4c506	184	elsif (looks_like_number($type)) { # Attribute type, name and value
b2fc39a5	185	my $node = $seqn2node{$id} \|\| die;
e8f4c506	186	my $attr = $node->{attr} \|\| die;
	187	if ($type == 1) { # NPattr_NAME
	188	warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
	189	if exists $attr->{$type}{$name};
	190	$attr->{$type}{$name} = $val \|\| $id;
	191	warn "A \@$id: '$name' $val\n";
	192	$node->{title} = $name if $type == 1 and !$val;
	193	}
	194	elsif (2 <= $type and $type <= 4) { # NPattr_PAD*
	195	warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
	196	if defined $attr->{$type}[$val];
	197	$attr->{$type}[$val] = $name;
	198	}
	199	else {
	200	warn "Invalid attribute type '$type' on line $. ($_)";
	201	}
2c631ee0	202	}
	203	else {
	204	warn "Invalid type '$type' on line $. ($_)";
e8f4c506	205	next;
2c631ee0	206	}
b2fc39a5	207	$dbh->commit if $dbh and $id % 10_000 == 0;
2c631ee0	208	}
	209
	210	my $x;
	211	while (@stack > 1) {
94fab3d1	212	leave_node($x = pop @stack) while @stack;
b2fc39a5	213	warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
2c631ee0	214	}
94fab3d1	215	print " ];\n" if $opt_json;
ee2793c1	216	print "}\n" if $opt_dot;
94fab3d1	217
b2fc39a5	218	$dbh->commit if $dbh;
b2fc39a5	219
2c631ee0	220	use Data::Dumper;
	221	warn Dumper(\$x);
	222	warn Dumper(\%seqn2node);
	223
	224	=for
	225	SV(PVAV) fill=1/1 [#1 @0]
	226	: +64 sv =64
	227	: +16 av_max =80
	228	: AVelem-> [#2 @1]
	229	: : SV(RV) [#3 @2]
	230	: : : +24 sv =104
	231	: : : RV-> [#4 @3]
	232	: : : : SV(PVAV) fill=-1/-1 [#5 @4]
	233	: : : : : +64 sv =168
	234	: AVelem-> [#6 @1]
	235	: : SV(IV) [#7 @2]
	236	: : : +24 sv =192
	237	192 at -e line 1.
	238	=cut
	239	__DATA__
	240	N 1 0 SV(PVAV) fill=1/1
	241	L 1 64 sv
	242	L 1 16 av_max
	243	N 2 1 AVelem->
	244	N 3 2 SV(RV)
	245	L 3 24 sv
	246	N 4 3 RV->
	247	N 5 4 SV(PVAV) fill=-1/-1
	248	L 5 64 sv
	249	N 6 1 AVelem->
	250	N 7 2 SV(IV)
	251	L 7 24 sv