#! perl

 # Copyright (c) 2004-2009 Nokia Corporation and/or its subsidiary(-ies).

 # All rights reserved.

 # This component and the accompanying materials are made available

 # under the terms of the License "Eclipse Public License v1.0"

 # which accompanies this distribution, and is available

 # at the URL "http://www.eclipse.org/legal/epl-v10.html".

 #

 # Initial Contributors:

 # Nokia Corporation - initial contribution.

 #

 # Contributors:

 #

 # Description:

 #

 if (@ARGV<1)

 	{

 #........1.........2.........3.........4.........5.........6.........7.....

 	print <<USAGE_EOF;

 Usage:

 	printstk.pl d_exc_nnn [romimage.symbol]

 Given the output of D_EXC, a file d_exc_nnn.txt and d_exc_nnn.stk, it 

 uses the other information to try to put symbolic information against 

 the stack image.

 USAGE_EOF

 	exit 1;

 	}

 sub add_object

 	{

 	my ($base, $max, $name) = @_;

 	$address{$base} = [ $base, $max, $name ];

 	my $key=$base>>20;

 	my $maxkey=$max>>20;

 	while ($key <= $maxkey)		# allowing for objects that span the boundary

 		{

 		push @{$addresslist{$key}}, $base;

 		$key+=1;

 		}

 	}

 my $RomBase = 0xF8000000;

 my $RomLimit = 0xFFF00000;

 add_object($RomBase,$RomLimit, "ROM");

 # Handle a MAKSYM.LOG file for a ROM

 #

 sub read_rom_symbols

 	{

 	my ($romimage)=@_;

 	open ROMSYMBOLS, $romimage or print "Can't open $romimage\n" and return;

 	my $a;

 	my $b;

 	while (my $line = <ROMSYMBOLS>)

 		{

 		if(!($line =~ /^[0-9A-Fa-f]{8}/))

 			{

 			next;

 			}

 		# 8 bytes for the address

 		$a = substr $line,0,8;

 		if(!($a =~ /[0-9A-Fa-f]{8}/))

 			{

 			next;

 			}

 		# 4 bytes for the length

 		$b = substr $line,12,4;

 		if(!($b =~ /[0-9A-Fa-f]{4}/))

 			{

 			next;

 			}

 		# rest of line is symbol

 		my $symbol = substr $line,20;

 		chomp $symbol;

 		my $base=hex($a);

 		my $length=hex($b);

 		if ($base < 0x50000000) 

 			{

 			next;	# skip this line

 			}

 		if ($length==0xffffffff)

 			{

 			$length=100;	# MAKSYM bug? choose a rational length

 			}

 		add_object($base, $base+$length-1, $symbol);

 		}

 	print "ROM Symbols from $romimage\n";

 	}

 # Handle MAP file for a non execute-in-place binary

 #

 sub read_map_symbols

 	{

 	my ($binary, $binbase)=@_;

 	$binary =~ /([^\\]+)$/;

 	my $basename=$1;

 	if (not open MAPFILE, "$basename.map")

 		{

 		print "Can't open map file for \n$binary.map)\n";		

 		return;

 		}

 	my @maplines;

 	while (<MAPFILE>) 

 		{

 		push @maplines, $_;

 		}

 	close MAPFILE;

 # See if we're dealing with the RVCT output

 	if ($maplines[0] =~ /^ARM Linker/) 

 		{

 		# scroll down to the global symbols

 		while ($_ = shift @maplines) 

 			{

 			if (/Global Symbols/) 

 				{

 				last;

 				}

 			}

 		# .text gets linked at 0x00008000		

 		$imgtext=hex(8000);#start of the text section during linking

 		foreach (@maplines) 

 			{

 			# name address ignore size section

 			if (/^\s*(.+)\s*(0x\S+)\s+[^\d]*(\d+)\s+(.*)$/) 

 				{

 				my $symbol  = $1;

 				my $addr = hex($2);

 				my $size = $3;

 				if ($size > 0)#symbols of the 0 size contain some auxillary information, ignore them

 					{

 	            			add_object($addr-$imgtext+$binbase,#relocated address of the current symbol 

 						$addr-$imgtext+$binbase+$size,#relocated address of the current symbol + size of the current symbol

 						"$binary $symbol");

 					}

 				}

 			}			      

 		}

 	else 

 #we are dealing with GCC output

 		{

 		my $imgtext;

 		# Find text section

 		while (($_ = shift @maplines) && !(/^\.text\s+/)) 

 			{

 			}

 		/^\.text\s+(\w+)\s+(\w+)/

 			or die "ERROR: Can't get .text section info for \"$file\"\n";

 		$imgtext=hex($1);#start of the text section during linking

 		$binbase-=$imgtext;

 		foreach (@maplines) 

 			{

 			if (/___CTOR_LIST__/)

 				{

 				last;	# end of text section

 				}

 			if (/^\s(\.text)?\s+(0x\w+)\s+(0x\w+)\s+(.*)$/io) 

 				{		    

 				$textlimit = hex($2)+$binbase+hex($3)-1;			

 				next;

 				}

 			if (/^\s+(\w+)\s\s+([a-zA-Z_].+)/o) 			

 				{				    

 				my $addr = hex($1);

 				my $symbol = $2;

 				add_object($addr+$binbase,#relocated address of the current symbol

 					$textlimit,#limit of the current object section

 					"$binary $symbol");

 				next;

 				}

 			}						

 		}

 #end of GCC output parsing		

 	}

 # Handle a matched pair of D_EXC output files (.txt and .stk)

 #

 sub read_d_exc

 	{

 	my ($name)=@_;

 	$stackbase = 0;

 	open D_EXC, "$name.txt" or die "Can't open $name.txt\n";

 	binmode D_EXC;

 	read D_EXC, $data, 16;

 	close D_EXC;

 	if ($data =~ /^(..)*.\0.\0/)

 		{

 		# Assuming Unicode

 		close D_EXC;

 		# Charconv won't convert STDIN or write to STDOUT

 		# so we generate an intermediate UTF8 file 

 		system "charconv -little -input=unicode $name.txt -output=utf8 $name.utf8.txt";

 		open D_EXC, "$name.utf8.txt" or die "Can't open $name.utf8.txt\n";

 		}

 	else

 		{

 		# Assuming ASCII

 		open D_EXC, "$name.txt" or die "Can't open $name.txt\n";

 		}

 	my $is_eka2_log = 0;

 	while (my $line = <D_EXC>)

 		{

 		if ($line =~ /^EKA2 USER CRASH LOG$/)

 			{

 			$is_eka2_log = 1;

 			next;

 			}

 		# code=1 PC=500f7ff8 FAR=00000042 FSR=e8820013

 		if ($line =~ /^code=\d PC=(.{8})/)

 			{

 			$is_exc = 1;

 			$fault_pc = hex($1);

 			next;

 			};

 		# R13svc=81719fc0 R14svc=50031da0 SPSRsvc=60000010

 		if ($line =~ /^R13svc=(.{8}) R14svc=(.{8}) SPSRsvc=(.{8})/)

 			{

 			$fault_lr = hex($2);

 			next;

 			}

 		# r00=fffffff8 00000000 80000718 80000003

 		if ($line =~ /^r(\d\d)=(.{8}) (.{8}) (.{8}) (.{8})/)

 			{

 			$registers{$1} = $line;

 			if ($1 == 12)

 				{

 				$activesp = hex($3);

 				$user_pc = hex($5);

 				$user_lr = hex($4);

 				}

 			next;

 			}

 		# User Stack 03900000-03905ffb

 		# EKA1 format deliberately broken (was /^Stack.*/) to catch version problems

 		if ($line =~ /^User Stack (.{8})-(.{8})/)

 			{

 			$stackbase = hex($1);

 			add_object($stackbase,hex($2), "Stack");

 			next;

 			}

 		# fff00000-fff00fff C:\foo\bar.dll

 		if ($line =~ /^(.{8})-(.{8}) (.+)/)

 			{

 			next if ($RomBase <= hex($1) && hex($1) < $RomLimit); # skip ROM XIP binaries

 			add_object(hex($1), hex($2), $3);

 			read_map_symbols($3, hex($1));

 			}

 		}

 	close D_EXC;

 	die "$name.txt is not a valid EKA2 crash log" unless $is_eka2_log;

 	if ($stackbase == 0)

 		{

 		die "couldn't find stack information in $name.txt\n";

 		}

 	die "couldn't find stack pointer in  $name.txt\n" unless $activesp != 0;

 	$activesp -= $stackbase;

 	# Read in the binary dump of the stack

 	open STACK, "$name.stk" or die "Can't open $name.stk\n";

 	print "Stack Data from $name.stk\n";

 	binmode STACK;

 	while (read STACK, $data, 4)

 		{

 		unshift @stack, (unpack "V", $data);

 		}

 	$stackptr = 0;

 	}

 # Handle the captured text output from the Kernel debugger

 #

 sub read_debugger

 	{

 	my ($name)=@_;

 	open DEBUGFILE, "$name" or die "Can't open $name\n";

 	print "Kernel Debugger session from $name\n";

 	# stuff which should be inferred from "$name"

 	$stackbase = 0x81C00000;

 	$stackmax  = 0x81C01DC0;

 	$activesp = 0x81c01bc4-$stackbase;

 	add_object($stackbase,0x81C01FFF, "Stack");

 	while (my $line = <DEBUGFILE>)

 		{

 		if ($line =~ /^(\w{8}): ((\w\w ){16})/)

 			{

 			my $addr = hex($1);

 			if ($addr < $stackbase || $addr > $stackmax)

 				{

 				next;

 				}

 			if (@stack == 0)

 				{

 				if ($addr != $stackbase)

 					{

 					printf "Missing stack data for %x-%x - fill with 0x29\n", $stackbase, $addr-1;

 					@stack = (0x29292929) x (($addr-$stackbase)/4);

 					}

 				}

 			unshift @stack, reverse (unpack "V4", (pack "H2"x16, (split / /,$2)));

 			}

 		}

 		$stackptr = 0;

 	}

 read_d_exc(@ARGV[0]);

 if (@ARGV>1)

 	{

 	read_rom_symbols(@ARGV[1]);

 	}

 # We've accumulated the ranges of objects indexed by start address,

 # with a companion list of addresses subdivided by the leading byte

 # Now sort them numerically...

 sub numerically { $a <=> $b }

 foreach my $key (keys %addresslist)

 	{

 	@{$addresslist{$key}} = sort numerically @{$addresslist{$key}};

 	}

 # Off we go, reading the stack!

 sub skip_unused 

 	{

 	my $skipped=0;

 	while (@stack)

 		{

 		my $word=(pop @stack);

 		if ($word!=0x29292929)

 			{ 

 			push @stack, $word;

 			last;

 			}

 		$skipped += 4;

 		}

 	$stackptr += $skipped;

 	return $skipped;

 	}

 sub lookup_addr

 {

 	my ($word) = @_;

 	# Optimization - try looking up the address directly

 	my $base;

 	my $max;

 	my $name;

 	if(defined $address{$word}) {

 		($base, $max, $name) = @{$address{$word}};

 	}

 	if (!(defined $base))

 		{

 		my $key=$word>>20;

 		my $regionbase;

 		foreach $base (@{$addresslist{$key}})

 			{

 			if ($base <= $word)

 				{

 				$regionbase = $base;

 				next;

 				}

 			if ($base > $word)

 				{

 				last;

 				}

 			}

 		if(defined $regionbase)

 			{

 			($base, $max, $name) = @{$address{$regionbase}};

 			}

 		}

 	if (defined $base && defined $max && $base <= $word && $max >= $word)

 		{

 		my $data = pack "V", $word;

 		$data =~ tr [\040-\177]/./c;

 		return sprintf "%08x %4s  %s + 0x%x", $word, $data, $name, $word - $base;

 		}

 	return "";

 }

 sub match_addr

 #

 # Try matching one of the named areas in the addresslist

 #

 {

 	my $word = (pop @stack);

 	if ($word < 1024*1024)

 		{

 		push @stack, $word;

 		return 0;

 		}

 	my $result = lookup_addr($word);

 	if ($result ne "")

 		{

 		print "$result\n";

 		$stackptr+=4;

 		return 1;

 		}

 	push @stack, $word;

 	return 0;

 	}

 sub match_tbuf8

 #

 # Try matching a TBuf8

 #	0x3000LLLL 0x0000MMMM data

 #	

 	{

 	if (scalar @stack <3)

 		{

 		return 0;	# too short

 		}

 	my $word = (pop @stack);

 	my $maxlen = (pop @stack);

 	my $len = $word & 0x0ffff;

 	my $type = ($word >> 16) & 0x0ffff;

 	if ( $type != 0x3000 || $maxlen <= $len || $maxlen > 4* scalar @stack 

 		|| ($stackptr < $activesp && $stackptr + $maxlen + 8 > $activesp))

 		{

 		push @stack, $maxlen;

 		push @stack, $word;

 		return 0;		# wrong type, or invalid looking sizes, or out of date

 		}

 	printf "TBuf8<%d>, length %d\n", $maxlen, $len;

 	$stackptr += 8;

 	my $string="";

 	while ($maxlen > 0)

 		{

 		$string .= pack "V", pop @stack;

 		$maxlen -= 4;

 		$stackptr += 4;

 		}

 	if ($len==0)

 		{

 		print "\n";

 		return 1;

 		}

 	my $line = substr($string,0,$len);

 	my @buf = unpack "C*", $line;

 	$line =~ tr [\040-\177]/./c;

 	printf "\n  %s", $line;

 	while ($len > 0)

 		{

 		my $datalen = 16;

 		if ($datalen > $len)

 			{

 			$datalen = $len;

 			}

 		$len -= $datalen;

 		printf "\n  ";

 		while ($datalen > 0)

 			{

 			my $char = shift @buf;

 			printf "%02x ", $char;

 			$datalen -= 1;

 			}

 		}

 	printf "\n\n";

 	return 1;

 	}

 # Skip the unused part of the stack

 skip_unused;

 printf "High watermark = %04x\n", $stackptr;

 # process the interesting bit!

 my $printed_current_sp = 0;

 while (@stack)

 	{

 	if (!$printed_current_sp && $stackptr >= $activesp)

 		{

 		printf "\n >>>> current user stack pointer >>>>\n\n";

 		print $registers{"00"};

 		print $registers{"04"};

 		print $registers{"08"};

 		print $registers{"12"};

 		if ($is_exc && $user_pc != $fault_pc)

 			{

 			print "\nWARNING: A kernel-side exception occured but this script\n";

 			print "is currently limited to user stack analysis. Sorry.\n";

 			my $result = lookup_addr($fault_pc);

 			if ($result ne "")

 				{

 				print "Kernel PC = $result\n";

 				}

 			$result = lookup_addr($fault_lr);

 			if ($result ne "")

 				{

 				print "Kernel LR = $result\n";

 				}

 			print "\n";

 			}

 		my $result = lookup_addr($user_pc);

 		if ($result ne "")

 			{

 			print "User PC = $result\n";

 			}

 		$result = lookup_addr($user_lr);

 		if ($result ne "")

 			{

 			print "User LR = $result\n";

 			}

 		printf "\n >>>> current user stack pointer >>>>\n\n";

 		$printed_current_sp = 1;

 		}

 	printf "%04x  ", $stackptr;

 	match_tbuf8() and next;

 	match_addr() and next;

 	$word = pop @stack;

 	$data = pack "V", $word;

 	$data =~ tr [\040-\177]/./c;

 	printf "%08x %4s  ", $word, $data;

 	$stackptr += 4;

 	if ($word == 0x29292929)

 		{

 		$skipped = skip_unused;

 		if ($skipped != 0)

 			{

 			printf "\n....";

 			}

 		printf "\n";

 		next;

 		}

 	# Try matching $word against the known addresses of things

 	printf "\n";

 	}