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