ext/B/B/Bblock.pm

   1 package B::Bblock;
   2
   3 our $VERSION = '1.00';
   4
   5 use Exporter ();
   6 @ISA = "Exporter";
   7 @EXPORT_OK = qw(find_leaders);
   8
   9 use B qw(peekop walkoptree walkoptree_exec
  10          main_root main_start svref_2object
  11          OPf_SPECIAL OPf_STACKED );
  12
  13 use B::Terse;
  14 use strict;
  15
  16 my $bblock;
  17 my @bblock_ends;
  18
  19 sub mark_leader {
  20     my $op = shift;
  21     if ($$op) {
  22         $bblock->{$$op} = $op;
  23     }
  24 }
  25
  26 sub remove_sortblock{
  27     foreach (keys %$bblock){
  28         my $leader=$$bblock{$_};
  29         delete $$bblock{$_} if( $leader == 0);
  30     }
  31 }
  32 sub find_leaders {
  33     my ($root, $start) = @_;
  34     $bblock = {};
  35     mark_leader($start) if ( ref $start ne "B::NULL" );
  36     walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
  37     remove_sortblock();
  38     return $bblock;
  39 }
  40
  41 # Debugging
  42 sub walk_bblocks {
  43     my ($root, $start) = @_;
  44     my ($op, $lastop, $leader, $bb);
  45     $bblock = {};
  46     mark_leader($start);
  47     walkoptree($root, "mark_if_leader");
  48     my @leaders = values %$bblock;
  49     while ($leader = shift @leaders) {
  50         $lastop = $leader;
  51         $op = $leader->next;
  52         while ($$op && !exists($bblock->{$$op})) {
  53             $bblock->{$$op} = $leader;
  54             $lastop = $op;
  55             $op = $op->next;
  56         }
  57         push(@bblock_ends, [$leader, $lastop]);
  58     }
  59     foreach $bb (@bblock_ends) {
  60         ($leader, $lastop) = @$bb;
  61         printf "%s .. %s\n", peekop($leader), peekop($lastop);
  62         for ($op = $leader; $$op != $$lastop; $op = $op->next) {
  63             printf "    %s\n", peekop($op);
  64         }
  65         printf "    %s\n", peekop($lastop);
  66     }
  67     print "-------\n";
  68     walkoptree_exec($start, "terse");
  69 }
  70
  71 sub walk_bblocks_obj {
  72     my $cvref = shift;
  73     my $cv = svref_2object($cvref);
  74     walk_bblocks($cv->ROOT, $cv->START);
  75 }
  76
  77 sub B::OP::mark_if_leader {}
  78
  79 sub B::COP::mark_if_leader {
  80     my $op = shift;
  81     if ($op->label) {
  82         mark_leader($op);
  83     }
  84 }
  85
  86 sub B::LOOP::mark_if_leader {
  87     my $op = shift;
  88     mark_leader($op->next);
  89     mark_leader($op->nextop);
  90     mark_leader($op->redoop);
  91     mark_leader($op->lastop->next);
  92 }
  93
  94 sub B::LOGOP::mark_if_leader {
  95     my $op = shift;
  96     my $opname = $op->name;
  97     mark_leader($op->next);
  98     if ($opname eq "entertry") {
  99         mark_leader($op->other->next);
 100     } else {
 101         mark_leader($op->other);
 102     }
 103 }
 104
 105 sub B::LISTOP::mark_if_leader {
 106     my $op = shift;
 107     my $first=$op->first;
 108     $first=$first->next while ($first->name eq "null");
 109     mark_leader($op->first) unless (exists( $bblock->{$$first}));
 110     mark_leader($op->next);
 111     if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
 112         and $op->flags & OPf_STACKED){
 113         my $root=$op->first->sibling->first;
 114         my $leader=$root->first;
 115         $bblock->{$$leader} = 0;
 116     }
 117 }
 118
 119 sub B::PMOP::mark_if_leader {
 120     my $op = shift;
 121     if ($op->name ne "pushre") {
 122         my $replroot = $op->pmreplroot;
 123         if ($$replroot) {
 124             mark_leader($replroot);
 125             mark_leader($op->next);
 126             mark_leader($op->pmreplstart);
 127         }
 128     }
 129 }
 130
 131 # PMOP stuff omitted
 132
 133 sub compile {
 134     my @options = @_;
 135     B::clearsym();
 136     if (@options) {
 137         return sub {
 138             my $objname;
 139             foreach $objname (@options) {
 140                 $objname = "main::$objname" unless $objname =~ /::/;
 141                 eval "walk_bblocks_obj(\\&$objname)";
 142                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 143             }
 144         }
 145     } else {
 146         return sub { walk_bblocks(main_root, main_start) };
 147     }
 148 }
 149
 150 # Basic block leaders:
 151 #     Any COP (pp_nextstate) with a non-NULL label
 152 #     [The op after a pp_enter] Omit
 153 #     [The op after a pp_entersub. Don't count this one.]
 154 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 155 #     The ops pointed at by op_next and op_other of a LOGOP, except
 156 #     for pp_entertry which has op_next and op_other->op_next
 157 #     The op pointed at by op_pmreplstart of a PMOP
 158 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 159 #     [The op after a pp_return] Omit
 160
 161 1;
 162
 163 __END__
 164
 165 =head1 NAME
 166
 167 B::Bblock - Walk basic blocks
 168
 169 =head1 SYNOPSIS
 170
 171   # External interface
 172   perl -MO=Bblock[,OPTIONS] foo.pl
 173
 174   # Programmatic API
 175   use B::Bblock qw(find_leaders);
 176   my $leaders = find_leaders($root_op, $start_op);
 177
 178 =head1 DESCRIPTION
 179
 180 This module is used by the B::CC back end.  It walks "basic blocks".
 181 A basic block is a series of operations which is known to execute from
 182 start to finish, with no possiblity of branching or halting.
 183
 184 It can be used either stand alone or from inside another program.
 185
 186 =for _private
 187 Somebody who understands the stand-alone options document them, please.
 188
 189 =head2 Functions
 190
 191 =over 4
 192
 193 =item B<find_leaders>
 194
 195   my $leaders = find_leaders($root_op, $start_op);
 196
 197 Given the root of the op tree and an op from which to start
 198 processing, it will return a hash ref representing all the ops which
 199 start a block.
 200
 201 =for _private
 202 The above description may be somewhat wrong.
 203
 204 The values of %$leaders are the op objects themselves.  Keys are $$op
 205 addresses.
 206
 207 =for _private
 208 Above cribbed from B::CC's comments.  What's a $$op address?
 209
 210 =back
 211
 212
 213 =head1 AUTHOR
 214
 215 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 216
 217 =cut