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         perl -MO=Bblock[,OPTIONS] foo.pl
 172
 173 =head1 DESCRIPTION
 174
 175 This module is used by the B::CC back end.  It walks "basic blocks".
 176 A basic block is a series of operations which is known to execute from
 177 start to finish, with no possiblity of branching or halting.
 178
 179 =head1 AUTHOR
 180
 181 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 182
 183 =cut