| 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 |