ext/B/B/Bblock.pm

   1 package B::Bblock;
   2 use Exporter ();
   3 @ISA = "Exporter";
   4 @EXPORT_OK = qw(find_leaders);
   5
   6 use B qw(peekop walkoptree walkoptree_exec
   7          main_root main_start svref_2object);
   8 use B::Terse;
   9 use strict;
  10
  11 my $bblock;
  12 my @bblock_ends;
  13
  14 sub mark_leader {
  15     my $op = shift;
  16     if ($$op) {
  17         $bblock->{$$op} = $op;
  18     }
  19 }
  20
  21 sub find_leaders {
  22     my ($root, $start) = @_;
  23     $bblock = {};
  24     mark_leader($start);
  25     walkoptree($root, "mark_if_leader");
  26     return $bblock;
  27 }
  28
  29 # Debugging
  30 sub walk_bblocks {
  31     my ($root, $start) = @_;
  32     my ($op, $lastop, $leader, $bb);
  33     $bblock = {};
  34     mark_leader($start);
  35     walkoptree($root, "mark_if_leader");
  36     my @leaders = values %$bblock;
  37     while ($leader = shift @leaders) {
  38         $lastop = $leader;
  39         $op = $leader->next;
  40         while ($$op && !exists($bblock->{$$op})) {
  41             $bblock->{$$op} = $leader;
  42             $lastop = $op;
  43             $op = $op->next;
  44         }
  45         push(@bblock_ends, [$leader, $lastop]);
  46     }
  47     foreach $bb (@bblock_ends) {
  48         ($leader, $lastop) = @$bb;
  49         printf "%s .. %s\n", peekop($leader), peekop($lastop);
  50         for ($op = $leader; $$op != $$lastop; $op = $op->next) {
  51             printf "    %s\n", peekop($op);
  52         }
  53         printf "    %s\n", peekop($lastop);
  54     }
  55     print "-------\n";
  56     walkoptree_exec($start, "terse");
  57 }
  58
  59 sub walk_bblocks_obj {
  60     my $cvref = shift;
  61     my $cv = svref_2object($cvref);
  62     walk_bblocks($cv->ROOT, $cv->START);
  63 }
  64
  65 sub B::OP::mark_if_leader {}
  66
  67 sub B::COP::mark_if_leader {
  68     my $op = shift;
  69     if ($op->label) {
  70         mark_leader($op);
  71     }
  72 }
  73
  74 sub B::LOOP::mark_if_leader {
  75     my $op = shift;
  76     mark_leader($op->next);
  77     mark_leader($op->nextop);
  78     mark_leader($op->redoop);
  79     mark_leader($op->lastop->next);
  80 }
  81
  82 sub B::LOGOP::mark_if_leader {
  83     my $op = shift;
  84     my $ppaddr = $op->ppaddr;
  85     mark_leader($op->next);
  86     if ($ppaddr eq "pp_entertry") {
  87         mark_leader($op->other->next);
  88     } else {
  89         mark_leader($op->other);
  90     }
  91 }
  92
  93 sub B::CONDOP::mark_if_leader {
  94     my $op = shift;
  95     mark_leader($op->next);
  96     mark_leader($op->true);
  97     mark_leader($op->false);
  98 }
  99
 100 sub B::LISTOP::mark_if_leader {
 101     my $op = shift;
 102     mark_leader($op->first);
 103     mark_leader($op->next);
 104 }
 105
 106 sub B::PMOP::mark_if_leader {
 107     my $op = shift;
 108     if ($op->ppaddr ne "pp_pushre") {
 109         my $replroot = $op->pmreplroot;
 110         if ($$replroot) {
 111             mark_leader($replroot);
 112             mark_leader($op->next);
 113             mark_leader($op->pmreplstart);
 114         }
 115     }
 116 }
 117
 118 # PMOP stuff omitted
 119
 120 sub compile {
 121     my @options = @_;
 122     if (@options) {
 123         return sub {
 124             my $objname;
 125             foreach $objname (@options) {
 126                 $objname = "main::$objname" unless $objname =~ /::/;
 127                 eval "walk_bblocks_obj(\\&$objname)";
 128                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 129             }
 130         }
 131     } else {
 132         return sub { walk_bblocks(main_root, main_start) };
 133     }
 134 }
 135
 136 # Basic block leaders:
 137 #     Any COP (pp_nextstate) with a non-NULL label
 138 #     [The op after a pp_enter] Omit
 139 #     [The op after a pp_entersub. Don't count this one.]
 140 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 141 #     The ops pointed at by op_next and op_other of a LOGOP, except
 142 #     for pp_entertry which has op_next and op_other->op_next
 143 #     The ops pointed at by op_true and op_false of a CONDOP
 144 #     The op pointed at by op_pmreplstart of a PMOP
 145 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 146 #     [The op after a pp_return] Omit
 147
 148 1;
 149
 150 __END__
 151
 152 =head1 NAME
 153
 154 B::Bblock - Walk basic blocks
 155
 156 =head1 SYNOPSIS
 157
 158         perl -MO=Bblock[,OPTIONS] foo.pl
 159
 160 =head1 DESCRIPTION
 161
 162 See F<ext/B/README>.
 163
 164 =head1 AUTHOR
 165
 166 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 167
 168 =cut