Commit | Line | Data |
a798dbf2 |
1 | package B::Bblock; |
28b605d8 |
2 | |
3 | our $VERSION = '1.00'; |
4 | |
a798dbf2 |
5 | use Exporter (); |
6 | @ISA = "Exporter"; |
7 | @EXPORT_OK = qw(find_leaders); |
8 | |
9 | use B qw(peekop walkoptree walkoptree_exec |
5ab5c7a4 |
10 | main_root main_start svref_2object |
11 | OPf_SPECIAL OPf_STACKED ); |
12 | |
a798dbf2 |
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 | } |
5ab5c7a4 |
25 | |
26 | sub remove_sortblock{ |
27 | foreach (keys %$bblock){ |
28 | my $leader=$$bblock{$_}; |
29 | delete $$bblock{$_} if( $leader == 0); |
59c10aa2 |
30 | } |
31 | } |
a798dbf2 |
32 | sub find_leaders { |
33 | my ($root, $start) = @_; |
34 | $bblock = {}; |
56eca212 |
35 | mark_leader($start) if ( ref $start ne "B::NULL" ); |
36 | walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; |
5ab5c7a4 |
37 | remove_sortblock(); |
a798dbf2 |
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; |
3f872cb9 |
96 | my $opname = $op->name; |
a798dbf2 |
97 | mark_leader($op->next); |
3f872cb9 |
98 | if ($opname eq "entertry") { |
a798dbf2 |
99 | mark_leader($op->other->next); |
100 | } else { |
101 | mark_leader($op->other); |
102 | } |
103 | } |
104 | |
0bfcb1eb |
105 | sub B::LISTOP::mark_if_leader { |
106 | my $op = shift; |
59c10aa2 |
107 | my $first=$op->first; |
3f872cb9 |
108 | $first=$first->next while ($first->name eq "null"); |
59c10aa2 |
109 | mark_leader($op->first) unless (exists( $bblock->{$$first})); |
0bfcb1eb |
110 | mark_leader($op->next); |
3f872cb9 |
111 | if ($op->name eq "sort" and $op->flags & OPf_SPECIAL |
5ab5c7a4 |
112 | and $op->flags & OPf_STACKED){ |
113 | my $root=$op->first->sibling->first; |
114 | my $leader=$root->first; |
115 | $bblock->{$$leader} = 0; |
116 | } |
56eca212 |
117 | } |
118 | |
a798dbf2 |
119 | sub B::PMOP::mark_if_leader { |
120 | my $op = shift; |
3f872cb9 |
121 | if ($op->name ne "pushre") { |
a798dbf2 |
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 = @_; |
2b8dc4d2 |
135 | B::clearsym(); |
a798dbf2 |
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 |
a798dbf2 |
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; |
7f20e9dd |
162 | |
163 | __END__ |
164 | |
165 | =head1 NAME |
166 | |
167 | B::Bblock - Walk basic blocks |
168 | |
169 | =head1 SYNOPSIS |
170 | |
2c12eace |
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); |
7f20e9dd |
177 | |
178 | =head1 DESCRIPTION |
179 | |
200f06d0 |
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. |
7f20e9dd |
183 | |
2c12eace |
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 | |
7f20e9dd |
213 | =head1 AUTHOR |
214 | |
215 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
216 | |
217 | =cut |