162 lines
3.5 KiB
Perl
Executable File
162 lines
3.5 KiB
Perl
Executable File
#!/usr/bin/env perl
|
||
#
|
||
# Adam Lackorzynski <adam@l4re.org>
|
||
#
|
||
# Input to this script is the output of dumpmapdbobjs from Fiasco-jdb
|
||
# Output of this script is a dot graph
|
||
#
|
||
# Convert to SVG with e.g.:
|
||
# fdp -Gmclimit=200.0 -Gnslimit=500.0 -Gratio=0.7 \
|
||
# -Tsvg -o x.svg x.dot
|
||
#
|
||
# To be improved...
|
||
|
||
use strict;
|
||
use warnings;
|
||
|
||
my $line = 0;
|
||
#my %spaces;
|
||
my %intasks;
|
||
my %kobjstype;
|
||
my %names;
|
||
my %obj_to_connector;
|
||
my %obj_to_root_space;
|
||
|
||
my %obj_colors = (
|
||
'Task' => 'red',
|
||
'Thread' => 'green',
|
||
'Sched' => 'blue',
|
||
'Factory' => 'yellow',
|
||
'Gate' => 'magenta',
|
||
);
|
||
|
||
my $dbgid;
|
||
while (<>)
|
||
{
|
||
chomp;
|
||
++$line;
|
||
s/
|
||
$//;
|
||
if (/^([\da-fA-F]+)\s+([\da-fA-F]+)\s+\[(.+)\]\s+({(.+?)})?/)
|
||
{
|
||
$dbgid = $1;
|
||
my $obj_type = $3;
|
||
my $name = $5;
|
||
|
||
$obj_type =~ s/\[.*?m//g;
|
||
|
||
#print "obj_type = $obj_type\n";
|
||
|
||
$obj_to_connector{$dbgid} = $1 ? $1 : $3
|
||
if $obj_type eq 'Gate' and (/ D=([\da-fA-Z]+)(\/([\da-fA-Z]+))?/);
|
||
$obj_to_connector{$dbgid} = $1
|
||
if $obj_type =~ /^IRQ/ and (/ T=([\da-fA-Z]+)/);
|
||
$obj_to_connector{$dbgid} = $2
|
||
if $obj_type eq 'Thread' and (/ S=(D:)?([\da-fA-Z]+)/);
|
||
|
||
$kobjstype{$dbgid} = $obj_type;
|
||
$names{$dbgid} = $name if defined $name;
|
||
}
|
||
elsif (/^\s+[\da-fA-F]+\[C:[\da-fA-F]+\]:\s+space=(D:)?([\da-fA-F]+)/)
|
||
{
|
||
die "no dbgid set?!" unless defined $dbgid;
|
||
|
||
push @{$intasks{$dbgid}}, $2;
|
||
$obj_to_root_space{$dbgid} = $2 unless defined $obj_to_root_space{$dbgid};
|
||
}
|
||
}
|
||
|
||
sub id_to_objtype($)
|
||
{
|
||
my $a = shift;
|
||
return "$kobjstype{$a}" if defined $kobjstype{$a};
|
||
return $a;
|
||
}
|
||
|
||
sub id_to_name($)
|
||
{
|
||
my $a = shift;
|
||
return "$a".":".id_to_objtype($a).":".$names{$a} if defined $names{$a};
|
||
return "$a".":".id_to_objtype($a);
|
||
}
|
||
|
||
print "digraph A {\n";
|
||
|
||
if (0)
|
||
{
|
||
foreach my $o (keys %kobjstype)
|
||
{
|
||
print " o$o [label = \"", id_to_objtype($o), "\"];\n";
|
||
}
|
||
}
|
||
|
||
foreach my $t (keys %kobjstype)
|
||
{
|
||
next unless $kobjstype{$t} eq 'Task';
|
||
|
||
print " subgraph cluster_$t { label = \"", id_to_name($t), "\";".
|
||
" style=filled; \n";
|
||
|
||
foreach my $o (keys %intasks)
|
||
{
|
||
foreach my $space (@{$intasks{$o}})
|
||
{
|
||
if ($t eq $space)
|
||
{
|
||
print " s$space"."o$o [label = \"".id_to_name($o)."\"";
|
||
#print " s$space"."o$o [label = \"$o\"";
|
||
print ",color=$obj_colors{$kobjstype{$o}}"
|
||
if defined $obj_colors{$kobjstype{$o}};
|
||
print "];\n";
|
||
}
|
||
}
|
||
}
|
||
|
||
print " }\n";
|
||
}
|
||
|
||
# mappings
|
||
foreach my $o (keys %intasks)
|
||
{
|
||
my @stack;
|
||
|
||
my $l = 0;
|
||
foreach my $space (@{$intasks{$o}})
|
||
{
|
||
$stack[$l] = $space;
|
||
|
||
if ($l > 0)
|
||
{
|
||
print " s$stack[$l-1]o$o -> s$stack[$l]o$o";
|
||
print "[color=$obj_colors{$kobjstype{$o}}]"
|
||
if defined $obj_colors{$kobjstype{$o}};
|
||
print ";\n";
|
||
}
|
||
++$l;
|
||
}
|
||
}
|
||
|
||
# connect tasks to cluster-boxes
|
||
foreach my $t (keys %kobjstype)
|
||
{
|
||
next unless
|
||
$kobjstype{$t} eq 'Task';
|
||
|
||
if (defined $obj_to_root_space{$t} and $obj_to_root_space{$t} ne $t)
|
||
{
|
||
print " s$obj_to_root_space{$t}o$t -> cluster_$t [style=dashed];\n";
|
||
}
|
||
}
|
||
|
||
|
||
# connect gates/irqs to their threads
|
||
foreach my $g (keys %obj_to_connector)
|
||
{
|
||
my $s1 = $obj_to_root_space{$g};
|
||
my $s2 = $obj_to_root_space{$obj_to_connector{$g}};
|
||
my $o = $obj_to_connector{$g};
|
||
print " s${s1}o$g -> s${s2}o$o [style=dotted];\n"
|
||
if defined $s1 and defined $s1;
|
||
}
|
||
|
||
print "}\n";
|