sl@0: #! perl
sl@0: # Copyright (c) 2004-2009 Nokia Corporation and/or its subsidiary(-ies).
sl@0: # All rights reserved.
sl@0: # This component and the accompanying materials are made available
sl@0: # under the terms of the License "Eclipse Public License v1.0"
sl@0: # which accompanies this distribution, and is available
sl@0: # at the URL "http://www.eclipse.org/legal/epl-v10.html".
sl@0: #
sl@0: # Initial Contributors:
sl@0: # Nokia Corporation - initial contribution.
sl@0: #
sl@0: # Contributors:
sl@0: #
sl@0: # Description:
sl@0: #
sl@0: 
sl@0: if (@ARGV<1)
sl@0: 	{
sl@0: #........1.........2.........3.........4.........5.........6.........7.....
sl@0: 	print <<USAGE_EOF;
sl@0: 
sl@0: Usage:
sl@0: 	printstk.pl d_exc_nnn [romimage.symbol]
sl@0: 
sl@0: Given the output of D_EXC, a file d_exc_nnn.txt and d_exc_nnn.stk, it 
sl@0: uses the other information to try to put symbolic information against 
sl@0: the stack image.
sl@0: 
sl@0: USAGE_EOF
sl@0: 	exit 1;
sl@0: 	}
sl@0: 
sl@0: sub add_object
sl@0: 	{
sl@0: 	my ($base, $max, $name) = @_;
sl@0: 	$address{$base} = [ $base, $max, $name ];
sl@0: 	my $key=$base>>20;
sl@0: 	my $maxkey=$max>>20;
sl@0: 	while ($key <= $maxkey)		# allowing for objects that span the boundary
sl@0: 		{
sl@0: 		push @{$addresslist{$key}}, $base;
sl@0: 		$key+=1;
sl@0: 		}
sl@0: 	}
sl@0: 
sl@0: my $RomBase = 0xF8000000;
sl@0: my $RomLimit = 0xFFF00000;
sl@0: add_object($RomBase,$RomLimit, "ROM");
sl@0: 
sl@0: # Handle a MAKSYM.LOG file for a ROM
sl@0: #
sl@0: sub read_rom_symbols
sl@0: 	{
sl@0: 	my ($romimage)=@_;
sl@0: 	open ROMSYMBOLS, $romimage or print "Can't open $romimage\n" and return;
sl@0: 
sl@0: 	my $a;
sl@0: 	my $b;
sl@0: 	while (my $line = <ROMSYMBOLS>)
sl@0: 		{
sl@0: 		if(!($line =~ /^[0-9A-Fa-f]{8}/))
sl@0: 			{
sl@0: 			next;
sl@0: 			}
sl@0: 		# 8 bytes for the address
sl@0: 		
sl@0: 		$a = substr $line,0,8;
sl@0: 		if(!($a =~ /[0-9A-Fa-f]{8}/))
sl@0: 			{
sl@0: 			next;
sl@0: 			}
sl@0: 		# 4 bytes for the length
sl@0: 		$b = substr $line,12,4;
sl@0: 		if(!($b =~ /[0-9A-Fa-f]{4}/))
sl@0: 			{
sl@0: 			next;
sl@0: 			}
sl@0: 		# rest of line is symbol
sl@0: 		my $symbol = substr $line,20;
sl@0: 		chomp $symbol;
sl@0: 
sl@0: 		my $base=hex($a);
sl@0: 		my $length=hex($b);
sl@0: 		if ($base < 0x50000000) 
sl@0: 			{
sl@0: 			next;	# skip this line
sl@0: 			}
sl@0: 		if ($length==0xffffffff)
sl@0: 			{
sl@0: 			$length=100;	# MAKSYM bug? choose a rational length
sl@0: 			}
sl@0: 		add_object($base, $base+$length-1, $symbol);
sl@0: 		}
sl@0: 	print "ROM Symbols from $romimage\n";
sl@0: 	}
sl@0: 
sl@0: # Handle MAP file for a non execute-in-place binary
sl@0: #
sl@0: sub read_map_symbols
sl@0: 	{
sl@0: 	my ($binary, $binbase)=@_;
sl@0: 	$binary =~ /([^\\]+)$/;
sl@0: 	my $basename=$1;
sl@0: 	if (not open MAPFILE, "$basename.map")
sl@0: 		{
sl@0: 		print "Can't open map file for \n$binary.map)\n";		
sl@0: 		return;
sl@0: 		}
sl@0: 
sl@0: 		
sl@0: 	my @maplines;
sl@0: 	while (<MAPFILE>) 
sl@0: 		{
sl@0: 		push @maplines, $_;
sl@0: 		}
sl@0: 	close MAPFILE;
sl@0: # See if we're dealing with the RVCT output
sl@0: 	if ($maplines[0] =~ /^ARM Linker/) 
sl@0: 		{
sl@0: 		# scroll down to the global symbols
sl@0: 		while ($_ = shift @maplines) 
sl@0: 			{
sl@0: 			if (/Global Symbols/) 
sl@0: 				{
sl@0: 				last;
sl@0: 				}
sl@0: 			}
sl@0: 		# .text gets linked at 0x00008000		
sl@0: 		$imgtext=hex(8000);#start of the text section during linking
sl@0: 		
sl@0: 		foreach (@maplines) 
sl@0: 			{
sl@0: 			# name address ignore size section
sl@0: 			if (/^\s*(.+)\s*(0x\S+)\s+[^\d]*(\d+)\s+(.*)$/) 
sl@0: 				{
sl@0: 				my $symbol  = $1;
sl@0: 				my $addr = hex($2);
sl@0: 				my $size = $3;
sl@0: 				if ($size > 0)#symbols of the 0 size contain some auxillary information, ignore them
sl@0: 					{
sl@0: 	            			add_object($addr-$imgtext+$binbase,#relocated address of the current symbol 
sl@0: 						$addr-$imgtext+$binbase+$size,#relocated address of the current symbol + size of the current symbol
sl@0: 						"$binary $symbol");
sl@0: 					}
sl@0: 				}
sl@0: 			}			      
sl@0: 		}
sl@0: 	else 
sl@0: #we are dealing with GCC output
sl@0: 		{
sl@0: 		my $imgtext;
sl@0: 		
sl@0: 		# Find text section
sl@0: 		while (($_ = shift @maplines) && !(/^\.text\s+/)) 
sl@0: 			{
sl@0: 			}
sl@0: 
sl@0: 		/^\.text\s+(\w+)\s+(\w+)/
sl@0: 			or die "ERROR: Can't get .text section info for \"$file\"\n";
sl@0: 		$imgtext=hex($1);#start of the text section during linking
sl@0: 		$binbase-=$imgtext;
sl@0: 		
sl@0: 		foreach (@maplines) 
sl@0: 			{
sl@0: 			if (/___CTOR_LIST__/)
sl@0: 				{
sl@0: 				last;	# end of text section
sl@0: 				}
sl@0: 
sl@0: 			if (/^\s(\.text)?\s+(0x\w+)\s+(0x\w+)\s+(.*)$/io) 
sl@0: 				{		    
sl@0: 				$textlimit = hex($2)+$binbase+hex($3)-1;			
sl@0: 				next;
sl@0: 				}
sl@0: 					
sl@0: 			if (/^\s+(\w+)\s\s+([a-zA-Z_].+)/o) 			
sl@0: 				{				    
sl@0: 				my $addr = hex($1);
sl@0: 				my $symbol = $2;
sl@0: 				add_object($addr+$binbase,#relocated address of the current symbol
sl@0: 					$textlimit,#limit of the current object section
sl@0: 					"$binary $symbol");
sl@0: 				next;
sl@0: 				}
sl@0: 			}						
sl@0: 		}
sl@0: #end of GCC output parsing		
sl@0: 	}
sl@0: 
sl@0: # Handle a matched pair of D_EXC output files (.txt and .stk)
sl@0: #
sl@0: sub read_d_exc
sl@0: 	{
sl@0: 	my ($name)=@_;
sl@0: 
sl@0: 	$stackbase = 0;
sl@0: 	open D_EXC, "$name.txt" or die "Can't open $name.txt\n";
sl@0: 
sl@0: 	binmode D_EXC;
sl@0: 	read D_EXC, $data, 16;
sl@0: 	close D_EXC;
sl@0: 
sl@0: 	if ($data =~ /^(..)*.\0.\0/)
sl@0: 		{
sl@0: 		# Assuming Unicode
sl@0: 		close D_EXC;
sl@0: 
sl@0: 		# Charconv won't convert STDIN or write to STDOUT
sl@0: 		# so we generate an intermediate UTF8 file 
sl@0: 		system "charconv -little -input=unicode $name.txt -output=utf8 $name.utf8.txt";
sl@0: 
sl@0: 		open D_EXC, "$name.utf8.txt" or die "Can't open $name.utf8.txt\n";
sl@0: 		}
sl@0: 	else
sl@0: 		{
sl@0: 		# Assuming ASCII
sl@0: 		open D_EXC, "$name.txt" or die "Can't open $name.txt\n";
sl@0: 		}
sl@0: 
sl@0: 	my $is_eka2_log = 0;
sl@0: 
sl@0: 	while (my $line = <D_EXC>)
sl@0: 		{
sl@0: 
sl@0: 		if ($line =~ /^EKA2 USER CRASH LOG$/)
sl@0: 			{
sl@0: 			$is_eka2_log = 1;
sl@0: 			next;
sl@0: 			}
sl@0: 	
sl@0: 		# code=1 PC=500f7ff8 FAR=00000042 FSR=e8820013
sl@0: 		
sl@0: 		if ($line =~ /^code=\d PC=(.{8})/)
sl@0: 			{
sl@0: 			$is_exc = 1;
sl@0: 			$fault_pc = hex($1);
sl@0: 			next;
sl@0: 			};
sl@0: 
sl@0: 		# R13svc=81719fc0 R14svc=50031da0 SPSRsvc=60000010
sl@0: 	
sl@0: 		if ($line =~ /^R13svc=(.{8}) R14svc=(.{8}) SPSRsvc=(.{8})/)
sl@0: 			{
sl@0: 			$fault_lr = hex($2);
sl@0: 			next;
sl@0: 			}
sl@0: 
sl@0: 		# r00=fffffff8 00000000 80000718 80000003
sl@0: 
sl@0: 		if ($line =~ /^r(\d\d)=(.{8}) (.{8}) (.{8}) (.{8})/)
sl@0: 			{
sl@0: 			$registers{$1} = $line;
sl@0: 			if ($1 == 12)
sl@0: 				{
sl@0: 				$activesp = hex($3);
sl@0: 				$user_pc = hex($5);
sl@0: 				$user_lr = hex($4);
sl@0: 				}
sl@0: 			next;
sl@0: 			}
sl@0: 
sl@0: 		# User Stack 03900000-03905ffb
sl@0: 		# EKA1 format deliberately broken (was /^Stack.*/) to catch version problems
sl@0: 
sl@0: 		if ($line =~ /^User Stack (.{8})-(.{8})/)
sl@0: 			{
sl@0: 			$stackbase = hex($1);
sl@0: 			add_object($stackbase,hex($2), "Stack");
sl@0: 			next;
sl@0: 			}
sl@0: 
sl@0: 		# fff00000-fff00fff C:\foo\bar.dll
sl@0: 
sl@0: 		if ($line =~ /^(.{8})-(.{8}) (.+)/)
sl@0: 			{
sl@0: 			next if ($RomBase <= hex($1) && hex($1) < $RomLimit); # skip ROM XIP binaries
sl@0: 			add_object(hex($1), hex($2), $3);
sl@0: 			read_map_symbols($3, hex($1));
sl@0: 			}
sl@0: 		}
sl@0: 	close D_EXC;
sl@0: 
sl@0: 	die "$name.txt is not a valid EKA2 crash log" unless $is_eka2_log;
sl@0: 
sl@0: 	if ($stackbase == 0)
sl@0: 		{
sl@0: 		die "couldn't find stack information in $name.txt\n";
sl@0: 		}
sl@0: 
sl@0: 	die "couldn't find stack pointer in  $name.txt\n" unless $activesp != 0;
sl@0: 	$activesp -= $stackbase;
sl@0: 
sl@0: 	# Read in the binary dump of the stack
sl@0: 
sl@0: 	open STACK, "$name.stk" or die "Can't open $name.stk\n";
sl@0: 	print "Stack Data from $name.stk\n";
sl@0: 
sl@0: 	binmode STACK;
sl@0: 	while (read STACK, $data, 4)
sl@0: 		{
sl@0: 		unshift @stack, (unpack "V", $data);
sl@0: 		}
sl@0: 	$stackptr = 0;
sl@0: 	}
sl@0: 
sl@0: # Handle the captured text output from the Kernel debugger
sl@0: #
sl@0: sub read_debugger
sl@0: 	{
sl@0: 	my ($name)=@_;
sl@0: 
sl@0: 	open DEBUGFILE, "$name" or die "Can't open $name\n";
sl@0: 	print "Kernel Debugger session from $name\n";
sl@0: 
sl@0: 	# stuff which should be inferred from "$name"
sl@0: 
sl@0: 	$stackbase = 0x81C00000;
sl@0: 	$stackmax  = 0x81C01DC0;
sl@0: 	$activesp = 0x81c01bc4-$stackbase;
sl@0: 	add_object($stackbase,0x81C01FFF, "Stack");
sl@0: 
sl@0: 	while (my $line = <DEBUGFILE>)
sl@0: 		{
sl@0: 		if ($line =~ /^(\w{8}): ((\w\w ){16})/)
sl@0: 			{
sl@0: 			my $addr = hex($1);
sl@0: 			if ($addr < $stackbase || $addr > $stackmax)
sl@0: 				{
sl@0: 				next;
sl@0: 				}
sl@0: 			if (@stack == 0)
sl@0: 				{
sl@0: 				if ($addr != $stackbase)
sl@0: 					{
sl@0: 					printf "Missing stack data for %x-%x - fill with 0x29\n", $stackbase, $addr-1;
sl@0: 					@stack = (0x29292929) x (($addr-$stackbase)/4);
sl@0: 					}
sl@0: 				}
sl@0: 			unshift @stack, reverse (unpack "V4", (pack "H2"x16, (split / /,$2)));
sl@0: 			}
sl@0: 		}
sl@0: 		$stackptr = 0;
sl@0: 	}
sl@0: 
sl@0: read_d_exc(@ARGV[0]);
sl@0: if (@ARGV>1)
sl@0: 	{
sl@0: 	read_rom_symbols(@ARGV[1]);
sl@0: 	}
sl@0: 
sl@0: # We've accumulated the ranges of objects indexed by start address,
sl@0: # with a companion list of addresses subdivided by the leading byte
sl@0: # Now sort them numerically...
sl@0: 
sl@0: sub numerically { $a <=> $b }
sl@0: foreach my $key (keys %addresslist)
sl@0: 	{
sl@0: 	@{$addresslist{$key}} = sort numerically @{$addresslist{$key}};
sl@0: 	}
sl@0: 
sl@0: # Off we go, reading the stack!
sl@0: 
sl@0: sub skip_unused 
sl@0: 	{
sl@0: 	my $skipped=0;
sl@0: 	while (@stack)
sl@0: 		{
sl@0: 		my $word=(pop @stack);
sl@0: 		if ($word!=0x29292929)
sl@0: 			{ 
sl@0: 			push @stack, $word;
sl@0: 			last;
sl@0: 			}
sl@0: 		$skipped += 4;
sl@0: 		}
sl@0: 	$stackptr += $skipped;
sl@0: 	return $skipped;
sl@0: 	}
sl@0: 
sl@0: sub lookup_addr
sl@0: {
sl@0: 	my ($word) = @_;
sl@0: 
sl@0: 	# Optimization - try looking up the address directly
sl@0: 
sl@0: 	my $base;
sl@0: 	my $max;
sl@0: 	my $name;
sl@0: 	if(defined $address{$word}) {
sl@0: 		($base, $max, $name) = @{$address{$word}};
sl@0: 	}
sl@0: 	if (!(defined $base))
sl@0: 		{
sl@0: 		my $key=$word>>20;
sl@0: 		my $regionbase;
sl@0: 		foreach $base (@{$addresslist{$key}})
sl@0: 			{
sl@0: 			if ($base <= $word)
sl@0: 				{
sl@0: 				$regionbase = $base;
sl@0: 				next;
sl@0: 				}
sl@0: 			if ($base > $word)
sl@0: 				{
sl@0: 				last;
sl@0: 				}
sl@0: 			}
sl@0: 		if(defined $regionbase)
sl@0: 			{
sl@0: 			($base, $max, $name) = @{$address{$regionbase}};
sl@0: 			}
sl@0: 		}
sl@0: 	if (defined $base && defined $max && $base <= $word && $max >= $word)
sl@0: 		{
sl@0: 		my $data = pack "V", $word;
sl@0: 		$data =~ tr [\040-\177]/./c;
sl@0: 		return sprintf "%08x %4s  %s + 0x%x", $word, $data, $name, $word - $base;
sl@0: 		}
sl@0: 	return "";
sl@0: }
sl@0: 
sl@0: sub match_addr
sl@0: #
sl@0: # Try matching one of the named areas in the addresslist
sl@0: #
sl@0: {
sl@0: 	my $word = (pop @stack);
sl@0: 
sl@0: 	if ($word < 1024*1024)
sl@0: 		{
sl@0: 		push @stack, $word;
sl@0: 		return 0;
sl@0: 		}
sl@0: 
sl@0: 	my $result = lookup_addr($word);
sl@0: 	if ($result ne "")
sl@0: 		{
sl@0: 		print "$result\n";
sl@0: 		$stackptr+=4;
sl@0: 		return 1;
sl@0: 		}
sl@0: 	push @stack, $word;
sl@0: 	return 0;
sl@0: 	}
sl@0: 
sl@0: sub match_tbuf8
sl@0: #
sl@0: # Try matching a TBuf8
sl@0: #	0x3000LLLL 0x0000MMMM data
sl@0: #	
sl@0: 	{
sl@0: 	if (scalar @stack <3)
sl@0: 		{
sl@0: 		return 0;	# too short
sl@0: 		}
sl@0: 	my $word = (pop @stack);
sl@0: 	my $maxlen = (pop @stack);
sl@0: 	
sl@0: 	my $len = $word & 0x0ffff;
sl@0: 	my $type = ($word >> 16) & 0x0ffff;
sl@0: 	if ( $type != 0x3000 || $maxlen <= $len || $maxlen > 4* scalar @stack 
sl@0: 		|| ($stackptr < $activesp && $stackptr + $maxlen + 8 > $activesp))
sl@0: 		{
sl@0: 		push @stack, $maxlen;
sl@0: 		push @stack, $word;
sl@0: 		return 0;		# wrong type, or invalid looking sizes, or out of date
sl@0: 		}
sl@0: 
sl@0: 	printf "TBuf8<%d>, length %d\n", $maxlen, $len;
sl@0: 	$stackptr += 8;
sl@0: 
sl@0: 	my $string="";
sl@0: 	while ($maxlen > 0)
sl@0: 		{
sl@0: 		$string .= pack "V", pop @stack;
sl@0: 		$maxlen -= 4;
sl@0: 		$stackptr += 4;
sl@0: 		}
sl@0: 	if ($len==0)
sl@0: 		{
sl@0: 		print "\n";
sl@0: 		return 1;
sl@0: 		}
sl@0: 	my $line = substr($string,0,$len);
sl@0: 	my @buf = unpack "C*", $line;
sl@0: 	$line =~ tr [\040-\177]/./c;
sl@0: 	printf "\n  %s", $line;
sl@0: 	while ($len > 0)
sl@0: 		{
sl@0: 		my $datalen = 16;
sl@0: 		if ($datalen > $len)
sl@0: 			{
sl@0: 			$datalen = $len;
sl@0: 			}
sl@0: 		$len -= $datalen;
sl@0: 		printf "\n  ";
sl@0: 		while ($datalen > 0)
sl@0: 			{
sl@0: 			my $char = shift @buf;
sl@0: 			printf "%02x ", $char;
sl@0: 			$datalen -= 1;
sl@0: 			}
sl@0: 		}
sl@0: 	printf "\n\n";
sl@0: 	return 1;
sl@0: 	}
sl@0: 
sl@0: # Skip the unused part of the stack
sl@0: 
sl@0: skip_unused;
sl@0: printf "High watermark = %04x\n", $stackptr;
sl@0: 
sl@0: # process the interesting bit!
sl@0: 
sl@0: my $printed_current_sp = 0;
sl@0: while (@stack)
sl@0: 	{
sl@0: 	if (!$printed_current_sp && $stackptr >= $activesp)
sl@0: 		{
sl@0: 		printf "\n >>>> current user stack pointer >>>>\n\n";
sl@0: 
sl@0: 		print $registers{"00"};
sl@0: 		print $registers{"04"};
sl@0: 		print $registers{"08"};
sl@0: 		print $registers{"12"};
sl@0: 
sl@0: 		if ($is_exc && $user_pc != $fault_pc)
sl@0: 			{
sl@0: 			print "\nWARNING: A kernel-side exception occured but this script\n";
sl@0: 			print "is currently limited to user stack analysis. Sorry.\n";
sl@0: 			my $result = lookup_addr($fault_pc);
sl@0: 			if ($result ne "")
sl@0: 				{
sl@0: 				print "Kernel PC = $result\n";
sl@0: 				}
sl@0: 			$result = lookup_addr($fault_lr);
sl@0: 			if ($result ne "")
sl@0: 				{
sl@0: 				print "Kernel LR = $result\n";
sl@0: 				}
sl@0: 			print "\n";
sl@0: 			}
sl@0: 
sl@0: 		my $result = lookup_addr($user_pc);
sl@0: 		if ($result ne "")
sl@0: 			{
sl@0: 			print "User PC = $result\n";
sl@0: 			}
sl@0: 		$result = lookup_addr($user_lr);
sl@0: 		if ($result ne "")
sl@0: 			{
sl@0: 			print "User LR = $result\n";
sl@0: 			}
sl@0: 		printf "\n >>>> current user stack pointer >>>>\n\n";
sl@0: 		$printed_current_sp = 1;
sl@0: 		}
sl@0: 
sl@0: 	printf "%04x  ", $stackptr;
sl@0: 
sl@0: 	match_tbuf8() and next;
sl@0: 	match_addr() and next;
sl@0: 
sl@0: 	$word = pop @stack;
sl@0: 	$data = pack "V", $word;
sl@0: 	$data =~ tr [\040-\177]/./c;
sl@0: 	printf "%08x %4s  ", $word, $data;
sl@0: 	$stackptr += 4;
sl@0: 
sl@0: 	if ($word == 0x29292929)
sl@0: 		{
sl@0: 		$skipped = skip_unused;
sl@0: 		if ($skipped != 0)
sl@0: 			{
sl@0: 			printf "\n....";
sl@0: 			}
sl@0: 		printf "\n";
sl@0: 		next;
sl@0: 		}
sl@0: 
sl@0: 	# Try matching $word against the known addresses of things
sl@0: 	printf "\n";
sl@0: 	}
sl@0: 
sl@0: