Commit | Line | Data |
a798dbf2 |
1 | package B::Bblock; |
28b605d8 |
2 | |
4522225b |
3 | our $VERSION = '1.02'; |
28b605d8 |
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 | |
31b49ad4 |
13 | use B::Concise qw(concise_cv concise_main set_style_standard); |
a798dbf2 |
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 | } |
a798dbf2 |
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; |
3f872cb9 |
94 | my $opname = $op->name; |
a798dbf2 |
95 | mark_leader($op->next); |
3f872cb9 |
96 | if ($opname eq "entertry") { |
a798dbf2 |
97 | mark_leader($op->other->next); |
98 | } else { |
99 | mark_leader($op->other); |
100 | } |
101 | } |
102 | |
0bfcb1eb |
103 | sub B::LISTOP::mark_if_leader { |
104 | my $op = shift; |
59c10aa2 |
105 | my $first=$op->first; |
3f872cb9 |
106 | $first=$first->next while ($first->name eq "null"); |
59c10aa2 |
107 | mark_leader($op->first) unless (exists( $bblock->{$$first})); |
0bfcb1eb |
108 | mark_leader($op->next); |
3f872cb9 |
109 | if ($op->name eq "sort" and $op->flags & OPf_SPECIAL |
5ab5c7a4 |
110 | and $op->flags & OPf_STACKED){ |
111 | my $root=$op->first->sibling->first; |
112 | my $leader=$root->first; |
113 | $bblock->{$$leader} = 0; |
114 | } |
56eca212 |
115 | } |
116 | |
a798dbf2 |
117 | sub B::PMOP::mark_if_leader { |
118 | my $op = shift; |
3f872cb9 |
119 | if ($op->name ne "pushre") { |
a798dbf2 |
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 = @_; |
2b8dc4d2 |
133 | B::clearsym(); |
a798dbf2 |
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 $@; |
31b49ad4 |
141 | print "-------\n"; |
142 | set_style_standard("terse"); |
143 | eval "concise_cv('exec', \\&$objname)"; |
144 | die "concise_cv('exec', \\&$objname) failed: $@" if $@; |
a798dbf2 |
145 | } |
146 | } |
147 | } else { |
31b49ad4 |
148 | return sub { |
149 | walk_bblocks(main_root, main_start); |
150 | print "-------\n"; |
151 | set_style_standard("terse"); |
152 | concise_main("exec"); |
153 | }; |
a798dbf2 |
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 |
a798dbf2 |
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; |
7f20e9dd |
169 | |
170 | __END__ |
171 | |
172 | =head1 NAME |
173 | |
174 | B::Bblock - Walk basic blocks |
175 | |
176 | =head1 SYNOPSIS |
177 | |
2c12eace |
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); |
7f20e9dd |
184 | |
185 | =head1 DESCRIPTION |
186 | |
200f06d0 |
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. |
7f20e9dd |
190 | |
2c12eace |
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 | |
7f20e9dd |
220 | =head1 AUTHOR |
221 | |
222 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
223 | |
224 | =cut |