l4re-base-25.08.0

src/fiasco/tool/kobjdeps

@@ -0,0 +1,161 @@
+#!/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;
+  }
+