#!/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";