bin/retrace

   1 #! /usr/bin/perl
   2 # $Id$
   3 # (eu-unstrip -n --core=`echo ./core.*`; echo; gdb -nx -ex "set debug-file-directory /_N" -ex "core-file `echo ./core.*`" -ex bt -ex q) 2>/dev/null | retrace
   4
   5 use strict;
   6 use warnings;
   7
   8 delete @ENV{qw(PATH BASH_ENV)};
   9 my $hex=qr/[[:xdigit:]]/;
  10 my $tmp="/tmp/retrace.$$";
  11
  12 sub spawn($)
  13 {
  14   my($cmd)=@_;
  15
  16   $cmd.=" >&2";
  17   system $cmd and die "$cmd: $!";
  18 }
  19
  20 sub readfile($)
  21 {
  22   my($fname)=@_;
  23
  24   local *F;
  25   open F,$fname or die $fname;
  26   my $F=do { local $/; <F>; };
  27   defined $F or die $fname;
  28   close F or die $fname;
  29   return $F;
  30 }
  31
  32 sub writefile
  33 {
  34   my($fname,$content)=@_;
  35
  36   local *F;
  37   open F,">$fname" or die $fname;
  38   print F $content or die $fname;
  39   close F or die $fname;
  40 }
  41
  42 my $gdbcmd;
  43 sub cmd_prep()
  44 {
  45   $gdbcmd=<<"HERE";
  46 set width 0
  47 set height 0
  48 set pagination off
  49 set confirm no
  50 set architecture i386:x86-64
  51 HERE
  52 }
  53
  54 sub buildid_to_filename($)
  55 {
  56   my($hash)=@_;
  57
  58   $hash=~/^($hex{2})($hex{38})$/o or die;
  59   local $_=readfile "readlink -f /usr/lib/debug/.build-id/$1/$2 |";
  60   chomp;
  61   return $_;
  62 }
  63
  64 sub filename_to_text_off($)
  65 {
  66   my($filename)=@_;
  67
  68   my $headers=readfile "eu-readelf --section-headers $filename |";
  69
  70   # Section Headers:
  71   # [Nr] Name                 Type         Addr             Off      Size     ES Flags Lk Inf Al
  72   # [...]
  73   # [12] .text                PROGBITS     000000000001e6a0 0001e6a0 000fe2b4  0 AX     0   0 16
  74   $headers=~/^\[ *\d+\] \.text +PROGBITS +$hex+ +($hex+) /mo or die "No .text Addr found:\n".$headers;
  75   return $1;
  76 }
  77
  78 sub cmd_add_symbol_file($$)
  79 {
  80   my($base0x,$buildid_hash)=@_;
  81
  82   my $buildid_filename=buildid_to_filename $buildid_hash;
  83   if (!-r $buildid_filename) {
  84     print "$buildid_hash Missing: $buildid_filename\n";
  85     return;
  86   }
  87   print "$buildid_hash $buildid_filename\n";
  88
  89   my $text_addr=filename_to_text_off $buildid_filename;
  90
  91   $gdbcmd.=<<"HERE";
  92 add-symbol-file $buildid_filename $base0x+0x$text_addr
  93 HERE
  94 }
  95
  96 sub cmd_add_address0x($)
  97 {
  98   my($address0x)=@_;
  99
 100   # addr2line/eu-addr2line do not print symbols with no .debug_line.
 101   $gdbcmd.=<<"HERE";
 102 echo =S=$address0x\\n
 103 info sym $address0x
 104 echo =E=$address0x\\n
 105 HERE
 106   # __nanosleep_nocancel + 7 in section .text of /lib64/libc-2.10.1.so
 107 }
 108
 109 sub cmd_finish()
 110 {
 111   $gdbcmd.=<<"HERE";
 112 quit
 113 HERE
 114 }
 115
 116 sub eu_unstrip_n_read($)
 117 {
 118   my($F)=@_;
 119
 120   local $_;
 121   while (<$F>) {
 122     # 0x36b5a00000+0x36e000 ec8dd400904ddfcac8b1c343263a790f977159dc@0x36b5a00280 /lib64/libc-2.10.1.so /usr/lib/debug/lib64/libc-2.10.1.so.debug  on
 123     chomp;
 124     last if $_ eq "";
 125     my($base0x,$buildid_hash)=(/^(0x$hex+)[+]0x$hex+ +($hex+)\Q@\E0x$hex+/) or die "Invalid eu-unstrip -n line: $_";
 126     cmd_add_symbol_file $base0x,$buildid_hash;
 127   }
 128 }
 129
 130 sub gdb_bt_read()
 131 {
 132   my @r;
 133   local $_;
 134   while (<>) {
 135     # #0  0x00000036b5aa3f70 in ?? ()
 136     if (!/^(#\d+ +(0x$hex+) in )\Q?? ()\E\s*$/) {
 137       push @r,$_;
 138       next;
 139     }
 140     my($prefix,$address0x)=($1,$2);
 141     cmd_add_address0x $address0x;
 142     push @r,[$_,$prefix,$address0x];
 143   }
 144   return @r;
 145 }
 146
 147 spawn "renice 20 -p $$ 2>/dev/null";
 148 unlink $tmp;
 149 cmd_prep;
 150 eu_unstrip_n_read \*STDIN;
 151 my @output=gdb_bt_read;
 152 cmd_finish;
 153
 154 writefile $tmp,$gdbcmd;
 155 ###print $gdbcmd;
 156 my $gdbout=readfile "TERM=dumb gdb -nx -batch -x $tmp </dev/null |";
 157
 158 print "### retrace begin\n";
 159
 160 for (@output) {
 161   if (!ref) {
 162     print;
 163     next;
 164   }
 165   my($origline,$prefix,$address0x)=@$_;
 166   # __nanosleep_nocancel + 7 in section .text of /lib64/libc-2.10.1.so
 167   if ($gdbout!~/\n=S=$address0x\n(.*?\n)=E=$address0x\n/) {
 168     # This should not happen for addresses not found, they would have valid
 169     # marked output just with unsuccessful result from GDB.
 170     print "### retrace fail: $origline";
 171     next;
 172   }
 173   my $gdbline=$1;
 174   print $prefix.$gdbline;
 175 }
 176
 177 unlink $tmp;
 178 print "### retrace finish\n";
 179 exit 0;