contrib/perl5/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::PMOP::mark_if_leader {
 101     my $op = shift;
 102     if ($op->ppaddr ne "pp_pushre") {
 103         my $replroot = $op->pmreplroot;
 104         if ($$replroot) {
 105             mark_leader($replroot);
 106             mark_leader($op->next);
 107             mark_leader($op->pmreplstart);
 108         }
 109     }
 110 }
 111
 112 # PMOP stuff omitted
 113
 114 sub compile {
 115     my @options = @_;
 116     if (@options) {
 117         return sub {
 118             my $objname;
 119             foreach $objname (@options) {
 120                 $objname = "main::$objname" unless $objname =~ /::/;
 121                 eval "walk_bblocks_obj(\\&$objname)";
 122                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 123             }
 124         }
 125     } else {
 126         return sub { walk_bblocks(main_root, main_start) };
 127     }
 128 }
 129
 130 # Basic block leaders:
 131 #     Any COP (pp_nextstate) with a non-NULL label
 132 #     [The op after a pp_enter] Omit
 133 #     [The op after a pp_entersub. Don't count this one.]
 134 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 135 #     The ops pointed at by op_next and op_other of a LOGOP, except
 136 #     for pp_entertry which has op_next and op_other->op_next
 137 #     The ops pointed at by op_true and op_false of a CONDOP
 138 #     The op pointed at by op_pmreplstart of a PMOP
 139 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 140 #     [The op after a pp_return] Omit
 141
 142 1;
 143
 144 __END__
 145
 146 =head1 NAME
 147
 148 B::Bblock - Walk basic blocks
 149
 150 =head1 SYNOPSIS
 151
 152         perl -MO=Bblock[,OPTIONS] foo.pl
 153
 154 =head1 DESCRIPTION
 155
 156 See F<ext/B/README>.
 157
 158 =head1 AUTHOR
 159
 160 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 161
 162 =cut