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 $opname = $op->name;
  94     mark_leader($op->next);
  95     if ($opname eq "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->name eq "null");
 106     mark_leader($op->first) unless (exists( $bblock->{$$first}));
 107     mark_leader($op->next);
 108     if ($op->name eq "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->name ne "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     B::clearsym();
 133     if (@options) {
 134         return sub {
 135             my $objname;
 136             foreach $objname (@options) {
 137                 $objname = "main::$objname" unless $objname =~ /::/;
 138                 eval "walk_bblocks_obj(\\&$objname)";
 139                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
 140             }
 141         }
 142     } else {
 143         return sub { walk_bblocks(main_root, main_start) };
 144     }
 145 }
 146
 147 # Basic block leaders:
 148 #     Any COP (pp_nextstate) with a non-NULL label
 149 #     [The op after a pp_enter] Omit
 150 #     [The op after a pp_entersub. Don't count this one.]
 151 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 152 #     The ops pointed at by op_next and op_other of a LOGOP, except
 153 #     for pp_entertry which has op_next and op_other->op_next
 154 #     The op pointed at by op_pmreplstart of a PMOP
 155 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 156 #     [The op after a pp_return] Omit
 157
 158 1;
 159
 160 __END__
 161
 162 =head1 NAME
 163
 164 B::Bblock - Walk basic blocks
 165
 166 =head1 SYNOPSIS
 167
 168         perl -MO=Bblock[,OPTIONS] foo.pl
 169
 170 =head1 DESCRIPTION
 171
 172 This module is used by the B::CC back end.  It walks "basic blocks".
 173 A basic block is a series of operations which is known to execute from
 174 start to finish, with no possiblity of branching or halting.
 175
 176 =head1 AUTHOR
 177
 178 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 179
 180 =cut