B/Bblock.pm

   1 package B::Bblock;
   2 use Exporter ();
   3 @ISA = "Exporter";
   4 @EXPORT_OK = qw(find_leaders);
   5
   6 use B qw(ad 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 (ad($op)) {
  17         $bblock->{ad($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 (ad($op) && !exists($bblock->{ad($op)})) {
  41             $bblock->{ad($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; ad($op) != ad($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     my $op = shift;
  67     my $ppaddr = $op->ppaddr;
  68 #    if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_entersub" || $ppaddr eq "pp_return") {
  69     if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_return") {
  70         mark_leader($op->next);
  71     }
  72 }
  73
  74 sub B::COP::mark_if_leader {
  75     my $op = shift;
  76     if ($op->label) {
  77         mark_leader($op);
  78     }
  79 }
  80
  81 sub B::LOOP::mark_if_leader {
  82     my $op = shift;
  83     mark_leader($op->next);
  84     mark_leader($op->nextop);
  85     mark_leader($op->redoop);
  86     mark_leader($op->lastop->next);
  87 }
  88
  89 sub B::LOGOP::mark_if_leader {
  90     my $op = shift;
  91     my $ppaddr = $op->ppaddr;
  92     mark_leader($op->next);
  93     if ($ppaddr eq "pp_entertry") {
  94         mark_leader($op->other->next);
  95     } else {
  96         mark_leader($op->other);
  97     }
  98 }
  99
 100 sub B::CONDOP::mark_if_leader {
 101     my $op = shift;
 102     mark_leader($op->next);
 103     mark_leader($op->true);
 104     mark_leader($op->false);
 105 }
 106
 107 sub B::PMOP::mark_if_leader {
 108     my $op = shift;
 109     if ($op->ppaddr ne "pp_pushre") {
 110         my $replroot = $op->pmreplroot;
 111         if (ad($replroot)) {
 112             mark_leader($replroot);
 113             mark_leader($op->next);
 114             mark_leader($op->pmreplstart);
 115         }
 116     }
 117 }
 118
 119 # PMOP stuff omitted
 120
 121 sub compile {
 122     my @options = @_;
 123     if (@options) {
 124         return sub {
 125             my $objname;
 126             foreach $objname (@options) {
 127                 $objname = "main::$objname" unless $objname =~ /::/;
 128                 eval "walk_bblocks_obj(\\&$objname)";
 129                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 130             }
 131         }
 132     } else {
 133         return sub { walk_bblocks(main_root, main_start) };
 134     }
 135 }
 136
 137 # Basic block leaders:
 138 #     Any COP (pp_nextstate) with a non-NULL label
 139 #     The op after a pp_enter
 140 #     [The op after a pp_entersub. Don't count this one.]
 141 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 142 #     The ops pointed at by op_next and op_other of a LOGOP, except
 143 #     for pp_entertry which has op_next and op_other->op_next
 144 #     The ops pointed at by op_true and op_false of a CONDOP
 145 #     The op pointed at by op_pmreplstart of a PMOP
 146 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 147 #     The op after a pp_return
 148
 149 1;