Commit | Line | Data |
---|---|---|
a798dbf2 | 1 | package B::Bblock; |
28b605d8 | 2 | |
4522225b | 3 | our $VERSION = '1.02'; |
28b605d8 | 4 | |
a798dbf2 MB |
5 | use Exporter (); |
6 | @ISA = "Exporter"; | |
7 | @EXPORT_OK = qw(find_leaders); | |
8 | ||
9 | use B qw(peekop walkoptree walkoptree_exec | |
5ab5c7a4 VB |
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 MB |
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 VB |
25 | |
26 | sub remove_sortblock{ | |
27 | foreach (keys %$bblock){ | |
28 | my $leader=$$bblock{$_}; | |
29 | delete $$bblock{$_} if( $leader == 0); | |
59c10aa2 VB |
30 | } |
31 | } | |
a798dbf2 MB |
32 | sub find_leaders { |
33 | my ($root, $start) = @_; | |
34 | $bblock = {}; | |
56eca212 GS |
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 MB |
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 MB |
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 MB |
97 | mark_leader($op->other->next); |
98 | } else { | |
99 | mark_leader($op->other); | |
100 | } | |
101 | } | |
102 | ||
0bfcb1eb VB |
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 VB |
110 | and $op->flags & OPf_STACKED){ |
111 | my $root=$op->first->sibling->first; | |
112 | my $leader=$root->first; | |
113 | $bblock->{$$leader} = 0; | |
114 | } | |
56eca212 GS |
115 | } |
116 | ||
a798dbf2 MB |
117 | sub B::PMOP::mark_if_leader { |
118 | my $op = shift; | |
3f872cb9 | 119 | if ($op->name ne "pushre") { |
a798dbf2 MB |
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 MB |
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 SM |
141 | print "-------\n"; |
142 | set_style_standard("terse"); | |
143 | eval "concise_cv('exec', \\&$objname)"; | |
144 | die "concise_cv('exec', \\&$objname) failed: $@" if $@; | |
a798dbf2 MB |
145 | } |
146 | } | |
147 | } else { | |
31b49ad4 SM |
148 | return sub { |
149 | walk_bblocks(main_root, main_start); | |
150 | print "-------\n"; | |
151 | set_style_standard("terse"); | |
152 | concise_main("exec"); | |
153 | }; | |
a798dbf2 MB |
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 MB |
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 GS |
169 | |
170 | __END__ | |
171 | ||
172 | =head1 NAME | |
173 | ||
174 | B::Bblock - Walk basic blocks | |
175 | ||
176 | =head1 SYNOPSIS | |
177 | ||
2c12eace MS |
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 GS |
184 | |
185 | =head1 DESCRIPTION | |
186 | ||
200f06d0 GS |
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 | |
3c4b39be | 189 | start to finish, with no possibility of branching or halting. |
7f20e9dd | 190 | |
2c12eace MS |
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 GS |
220 | =head1 AUTHOR |
221 | ||
222 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> | |
223 | ||
224 | =cut |