tools/util/dump_pbc.pl

   1 #! perl
   2
   3 # Copyright (C) 2008, Parrot Foundation.
   4 # $Id$
   5
   6 =head1 NAME
   7
   8 tools/util/dump_pbc.pl - Weave together PBC disassembly with PIR source
   9
  10 =head1 SYNOPSIS
  11
  12  perl tools/util/dump_pbc.pl foo.pbc
  13
  14 =head1 DESCRIPTION
  15
  16 dump_pbc.pl uses Parrot's F<pbc_disassemble> program to disassemble the opcodes
  17 in a PBC (Parrot ByteCode) file, then weaves the disassembly together with
  18 the original PIR source file(s).  This makes it easier to see how the PIR
  19 syntactic sugar is desugared into raw Parrot opcodes.
  20
  21 =head1 BUGS
  22
  23 This program has only been tested for a few simple cases.  Also, the name
  24 might suggest a different use than its actual purpose.
  25
  26 While it is not a bug in F<dump_pbc.pl> per se, there is a line numbering
  27 bug for some PBC opcode sequences that will result in the disassembled
  28 opcodes appearing just before the source lines they represent, rather
  29 than just after.  There does not appear to be consensus yet about where
  30 this bug actually resides.
  31
  32 =cut
  33
  34 use strict;
  35 use warnings;
  36 use Cwd;
  37 use FindBin;
  38
  39 my ($PARROT_ROOT, $RUNTIME_DIR);
  40 BEGIN {
  41     $PARROT_ROOT = Cwd::abs_path("$FindBin::Bin/../..");
  42     $RUNTIME_DIR = "$PARROT_ROOT/runtime/parrot";
  43 }
  44
  45 use lib "$PARROT_ROOT/lib";
  46 use Parrot::Config '%PConfig';
  47
  48 my $DISASSEMBLER = "$PConfig{build_dir}$PConfig{slash}pbc_disassemble$PConfig{exe}";
  49
  50 go(@ARGV);
  51
  52 sub go {
  53     my $pbc = shift;
  54
  55     # The following mess brought to you by Win32, where pipe open doesn't work,
  56     # and thus its greater security and cleaner error handling are unavailable.
  57
  58     -f $pbc && -r _
  59         or die "PBC file '$pbc' does not exist or is not readable.\n";
  60
  61     -f $DISASSEMBLER && -x _
  62         or die  "Can't find disassembler '$DISASSEMBLER';"
  63               . "did you remember to make parrot first?\n";
  64
  65     my @dis = `$DISASSEMBLER $pbc`;
  66     die "No disassembly; errors: $?, $!" unless @dis;
  67
  68     my $cur_file = '';
  69     my $cur_line = -1;
  70     my %cache;
  71
  72     foreach (@dis) {
  73         if (/^(?:# )?Current Source Filename (.*)/) {
  74             my $found = $1;
  75             $found =~ s/^'//;
  76             $found =~ s/'$//;
  77             if ($cur_file ne $found) {
  78                 $cur_file           = $found;
  79                 $cache{$cur_file} ||= slurp_file($cur_file);
  80                 $cur_line           = -1;
  81
  82                 print "\n#### $cur_file\n";
  83             }
  84         }
  85         elsif (my ($info, $seq, $pc, $line, $code) = /^((\d+)-(\d+) (\d+): )(.*)/) {
  86             my $int_line = int    $line;
  87             my $len_line = length $line;
  88             if ($cur_line != $int_line) {
  89                 $cur_line = 0 if $cur_line == -1;
  90                 print "\n";
  91                 foreach my $i ($cur_line + 1 .. $int_line) {
  92                     my $source_code = $cache{$cur_file}[$i-1];
  93                     # next    unless $source_code =~ /\S/;
  94                     printf "# %*d:   %s", $len_line, $i, $source_code;
  95                     print  "\n" if $source_code =~ /^\.end/;
  96                 }
  97                 $cur_line  = $int_line;
  98             }
  99
 100             print ' ' x ($len_line + 4), "$code\n";
 101         }
 102     }
 103 }
 104
 105 sub slurp_file {
 106     my $file = shift;
 107     my $source;
 108
 109        open $source, '<', $file
 110     or open $source, '<', "$PARROT_ROOT/$file"
 111     or open $source, '<', "$RUNTIME_DIR/$file"
 112     or die "Could not open source file '$file': $!";
 113
 114     my @lines = <$source>;
 115
 116     return \@lines;
 117 }
 118
 119
 120 # Local Variables:
 121 #   mode: cperl
 122 #   cperl-indent-level: 4
 123 #   fill-column: 100
 124 # End:
 125 # vim: expandtab shiftwidth=4: