examine-relay

[eric pouech]

since the format of the relay traces has been changed, the modification
to tools/examine-relay haven't been done

this is now done. I also added a bit of thread separation in the script

A+
-- 
---------------
Eric Pouech (http://perso.wanadoo.fr/eric.pouech/)
"The future will be better tomorrow", Vice President Dan Quayle
-------------- next part --------------
Name: relay
ChangeLog: fixed for new relay format. added thread knowledge
GenDate: 2001/06/23 14:08:37 UTC
ModifiedFiles: tools/examine-relay
AddedFiles: 
===================================================================
RCS file: /usr/share/cvs/cvsroot/wine/wine/tools/examine-relay,v
retrieving revision 1.1.1.1
diff -u -u -r1.1.1.1 examine-relay
--- tools/examine-relay	1998/09/24 03:43:39	1.1.1.1
+++ tools/examine-relay	2001/06/23 14:05:58
@@ -8,63 +8,74 @@
 # list might be incorrect.  (It could be something else also.)
 #
 # Copyright 1997-1998 Morten Welinder (terra at diku.dk)
+#           2001      Eric Pouech
 #
 # -----------------------------------------------------------------------------
 
+use strict;
+
 my $srcfile = $ARGV[0];
-my @callstack = ();
+my %tid_callstack = ();
 my $newlineerror = 0;
 my $indentp = 1;
 
 open (IN, "<$srcfile") || die "Cannot open $srcfile for reading: $!\n";
 LINE:
 while (<IN>) {
-    if (/^Call ([A-Za-z0-9]+\.\d+): .*\)/) {
-	my $func = $1;
+
+    if (/^([0-9a-f]+):Call ([A-Za-z0-9]+\.[A-Za-z0-9_]+)\((.*\)) .*/) {
+	my $tid = $1;
+	my $func = $2;
+
 	if (/ ret=(........)$/ ||
-	    / ret=(....:....) (ds=....)$/ ||
-	    / ret=(........) (fs=....)$/) {
+	    / ret=(....:....) (ds=....)$/) {
 	    my $retaddr = $1;
 	    my $segreg = $2;
 
 	    $segreg = "none" unless defined $segreg;
-	    push @callstack, [$func,$retaddr, $segreg];
+
+	    push @{$tid_callstack{$tid}}, [$func, $retaddr, $segreg];
 	    next;
 	} else {
 	    # Assume a line got cut by a line feed in a string.
 	    $_ .= scalar (<IN>);
 	    if (!$newlineerror) {
-		print "Error: string probably cut by newline.\n";
+		print "Err[$tid] string probably cut by newline.\n";
 		$newlineerror = 1;
 	    }	    
 	    # print "[$_]";
 	    redo;
 	}
     }
-
 
-    if (/^Ret  ([A-Za-z0-9]+\.\d+): .* ret=(........)$/ ||
-	/^Ret  ([A-Za-z0-9]+\.\d+): .* ret=(....:....) (ds=....)$/ ||
-	/^Ret  ([A-Za-z0-9]+\.\d+): .* ret=(........) (fs=....)$/) {
-	my $func = $1;
-	my $retaddr = $2;
-	my $segreg = $3;
+    if (/^([0-9a-f]+):Ret  ([A-Za-z0-9]+\.[A-Za-z0-9_]+)\(.*\) .* ret=(........)$/ ||
+	/^([0-9a-f]+):Ret  ([A-Za-z0-9]+\.[A-Za-z0-9_]+)\(.*\) .* ret=(....:....) (ds=....)$/) {
+	my $tid = $1;
+	my $func = $2;
+	my $retaddr = $3;
+	my $segreg = $4;
 	my ($topfunc,$topaddr,$topseg);
 
+	if (!defined($tid_callstack{$tid}))
+	{
+	    print "Err[$tid]: unknown tid\n";
+	    next;
+	}
+
 	$segreg = "none" unless defined $segreg;
 
       POP:
 	while (1) {
-	    if ($#callstack == -1) {
-		print "Error: Return from $func to $retaddr with empty stack.\n";
+	    if ($#{$tid_callstack{$tid}} == -1) {
+		print "Err[$tid]: Return from $func to $retaddr with empty stack.\n";
 		next LINE;
 	    }
 
-	    ($topfunc,$topaddr,$topseg) = @{pop @callstack};
+	    ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
 
 	    if ($topfunc ne $func) {
-		print "Error: Return from $topfunc, but call from $func.\n";
-		next POP 
+		print "Err[$tid]: Return from $topfunc, but call from $func.\n";
+		next POP;
 	    }
 	    last POP;
 	}
@@ -72,20 +83,22 @@
 	my $addrok = ($topaddr eq $retaddr);
 	my $segok = ($topseg eq $segreg);
 	if ($addrok && $segok) {
-	    print "OK: ", ($indentp ? (' ' x (1 + $#callstack)) : '');
+	    print "Ok [$tid]: ", ($indentp ? (' ' x (1 + $#{$tid_callstack{$tid}})) : '');
 	    print "$func from $retaddr with $segreg.\n";
 	} else {
-	    print "Error: Return from $func is to $retaddr, not $topaddr.\n"
+	    print "Err[$tid]: Return from $func is to $retaddr, not $topaddr.\n"
 		if !$addrok;
-	    print "Error: Return from $func with segreg $segreg, not $topseg.\n"
+	    print "Err[$tid]: Return from $func with segreg $segreg, not $topseg.\n"
 		if !$segok;
 	}    
     }
 }
 
-while ($#callstack != -1) {
-    my ($topfunc,$topaddr) = @{pop @callstack};
-    print "Error: leftover call to $topfunc from $topaddr.\n";
+foreach my $tid (keys %tid_callstack) {
+    while ($#{$tid_callstack{$tid}} != -1) {
+	my ($topfunc,$topaddr,$topseg) = @{pop @{$tid_callstack{$tid}}};
+	print "Err[$tid]: leftover call to $topfunc from $topaddr.\n";
+    }
 }
 
 close (IN);