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

	}