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::Concise qw(concise_cv concise_main set_style_standard);
  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 }
  68
  69 sub walk_bblocks_obj {
  70     my $cvref = shift;
  71     my $cv = svref_2object($cvref);
  72     walk_bblocks($cv->ROOT, $cv->START);
  73 }
  74
  75 sub B::OP::mark_if_leader {}
  76
  77 sub B::COP::mark_if_leader {
  78     my $op = shift;
  79     if ($op->label) {
  80         mark_leader($op);
  81     }
  82 }
  83
  84 sub B::LOOP::mark_if_leader {
  85     my $op = shift;
  86     mark_leader($op->next);
  87     mark_leader($op->nextop);
  88     mark_leader($op->redoop);
  89     mark_leader($op->lastop->next);
  90 }
  91
  92 sub B::LOGOP::mark_if_leader {
  93     my $op = shift;
  94     my $opname = $op->name;
  95     mark_leader($op->next);
  96     if ($opname eq "entertry") {
  97         mark_leader($op->other->next);
  98     } else {
  99         mark_leader($op->other);
 100     }
 101 }
 102
 103 sub B::LISTOP::mark_if_leader {
 104     my $op = shift;
 105     my $first=$op->first;
 106     $first=$first->next while ($first->name eq "null");
 107     mark_leader($op->first) unless (exists( $bblock->{$$first}));
 108     mark_leader($op->next);
 109     if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
 110         and $op->flags & OPf_STACKED){
 111         my $root=$op->first->sibling->first;
 112         my $leader=$root->first;
 113         $bblock->{$$leader} = 0;
 114     }
 115 }
 116
 117 sub B::PMOP::mark_if_leader {
 118     my $op = shift;
 119     if ($op->name ne "pushre") {
 120         my $replroot = $op->pmreplroot;
 121         if ($$replroot) {
 122             mark_leader($replroot);
 123             mark_leader($op->next);
 124             mark_leader($op->pmreplstart);
 125         }
 126     }
 127 }
 128
 129 # PMOP stuff omitted
 130
 131 sub compile {
 132     my @options = @_;
 133     B::clearsym();
 134     if (@options) {
 135         return sub {
 136             my $objname;
 137             foreach $objname (@options) {
 138                 $objname = "main::$objname" unless $objname =~ /::/;
 139                 eval "walk_bblocks_obj(\\&$objname)";
 140                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 141                 print "-------\n";
 142                 set_style_standard("terse");
 143                 eval "concise_cv('exec', \\&$objname)";
 144                 die "concise_cv('exec', \\&$objname) failed: $@" if $@;
 145             }
 146         }
 147     } else {
 148         return sub {
 149             walk_bblocks(main_root, main_start);
 150             print "-------\n";
 151             set_style_standard("terse");
 152             concise_main("exec");
 153         };
 154     }
 155 }
 156
 157 # Basic block leaders:
 158 #     Any COP (pp_nextstate) with a non-NULL label
 159 #     [The op after a pp_enter] Omit
 160 #     [The op after a pp_entersub. Don't count this one.]
 161 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 162 #     The ops pointed at by op_next and op_other of a LOGOP, except
 163 #     for pp_entertry which has op_next and op_other->op_next
 164 #     The op pointed at by op_pmreplstart of a PMOP
 165 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 166 #     [The op after a pp_return] Omit
 167
 168 1;
 169
 170 __END__
 171
 172 =head1 NAME
 173
 174 B::Bblock - Walk basic blocks
 175
 176 =head1 SYNOPSIS
 177
 178   # External interface
 179   perl -MO=Bblock[,OPTIONS] foo.pl
 180
 181   # Programmatic API
 182   use B::Bblock qw(find_leaders);
 183   my $leaders = find_leaders($root_op, $start_op);
 184
 185 =head1 DESCRIPTION
 186
 187 This module is used by the B::CC back end.  It walks "basic blocks".
 188 A basic block is a series of operations which is known to execute from
 189 start to finish, with no possiblity of branching or halting.
 190
 191 It can be used either stand alone or from inside another program.
 192
 193 =for _private
 194 Somebody who understands the stand-alone options document them, please.
 195
 196 =head2 Functions
 197
 198 =over 4
 199
 200 =item B<find_leaders>
 201
 202   my $leaders = find_leaders($root_op, $start_op);
 203
 204 Given the root of the op tree and an op from which to start
 205 processing, it will return a hash ref representing all the ops which
 206 start a block.
 207
 208 =for _private
 209 The above description may be somewhat wrong.
 210
 211 The values of %$leaders are the op objects themselves.  Keys are $$op
 212 addresses.
 213
 214 =for _private
 215 Above cribbed from B::CC's comments.  What's a $$op address?
 216
 217 =back
 218
 219
 220 =head1 AUTHOR
 221
 222 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 223
 224 =cut