Commit | Line | Data |
a798dbf2 |
1 | package B::Bblock; |
2 | use Exporter (); |
3 | @ISA = "Exporter"; |
4 | @EXPORT_OK = qw(find_leaders); |
5 | |
6 | use B qw(peekop walkoptree walkoptree_exec |
5ab5c7a4 |
7 | main_root main_start svref_2object |
8 | OPf_SPECIAL OPf_STACKED ); |
9 | |
a798dbf2 |
10 | use B::Terse; |
11 | use strict; |
12 | |
13 | my $bblock; |
14 | my @bblock_ends; |
15 | |
16 | sub mark_leader { |
17 | my $op = shift; |
18 | if ($$op) { |
19 | $bblock->{$$op} = $op; |
20 | } |
21 | } |
5ab5c7a4 |
22 | |
23 | sub remove_sortblock{ |
24 | foreach (keys %$bblock){ |
25 | my $leader=$$bblock{$_}; |
26 | delete $$bblock{$_} if( $leader == 0); |
59c10aa2 |
27 | } |
28 | } |
a798dbf2 |
29 | sub find_leaders { |
30 | my ($root, $start) = @_; |
31 | $bblock = {}; |
56eca212 |
32 | mark_leader($start) if ( ref $start ne "B::NULL" ); |
33 | walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; |
5ab5c7a4 |
34 | remove_sortblock(); |
a798dbf2 |
35 | return $bblock; |
36 | } |
37 | |
38 | # Debugging |
39 | sub walk_bblocks { |
40 | my ($root, $start) = @_; |
41 | my ($op, $lastop, $leader, $bb); |
42 | $bblock = {}; |
43 | mark_leader($start); |
44 | walkoptree($root, "mark_if_leader"); |
45 | my @leaders = values %$bblock; |
46 | while ($leader = shift @leaders) { |
47 | $lastop = $leader; |
48 | $op = $leader->next; |
49 | while ($$op && !exists($bblock->{$$op})) { |
50 | $bblock->{$$op} = $leader; |
51 | $lastop = $op; |
52 | $op = $op->next; |
53 | } |
54 | push(@bblock_ends, [$leader, $lastop]); |
55 | } |
56 | foreach $bb (@bblock_ends) { |
57 | ($leader, $lastop) = @$bb; |
58 | printf "%s .. %s\n", peekop($leader), peekop($lastop); |
59 | for ($op = $leader; $$op != $$lastop; $op = $op->next) { |
60 | printf " %s\n", peekop($op); |
61 | } |
62 | printf " %s\n", peekop($lastop); |
63 | } |
64 | print "-------\n"; |
65 | walkoptree_exec($start, "terse"); |
66 | } |
67 | |
68 | sub walk_bblocks_obj { |
69 | my $cvref = shift; |
70 | my $cv = svref_2object($cvref); |
71 | walk_bblocks($cv->ROOT, $cv->START); |
72 | } |
73 | |
74 | sub B::OP::mark_if_leader {} |
75 | |
76 | sub B::COP::mark_if_leader { |
77 | my $op = shift; |
78 | if ($op->label) { |
79 | mark_leader($op); |
80 | } |
81 | } |
82 | |
83 | sub B::LOOP::mark_if_leader { |
84 | my $op = shift; |
85 | mark_leader($op->next); |
86 | mark_leader($op->nextop); |
87 | mark_leader($op->redoop); |
88 | mark_leader($op->lastop->next); |
89 | } |
90 | |
91 | sub B::LOGOP::mark_if_leader { |
92 | my $op = shift; |
3f872cb9 |
93 | my $opname = $op->name; |
a798dbf2 |
94 | mark_leader($op->next); |
3f872cb9 |
95 | if ($opname eq "entertry") { |
a798dbf2 |
96 | mark_leader($op->other->next); |
97 | } else { |
98 | mark_leader($op->other); |
99 | } |
100 | } |
101 | |
0bfcb1eb |
102 | sub B::LISTOP::mark_if_leader { |
103 | my $op = shift; |
59c10aa2 |
104 | my $first=$op->first; |
3f872cb9 |
105 | $first=$first->next while ($first->name eq "null"); |
59c10aa2 |
106 | mark_leader($op->first) unless (exists( $bblock->{$$first})); |
0bfcb1eb |
107 | mark_leader($op->next); |
3f872cb9 |
108 | if ($op->name eq "sort" and $op->flags & OPf_SPECIAL |
5ab5c7a4 |
109 | and $op->flags & OPf_STACKED){ |
110 | my $root=$op->first->sibling->first; |
111 | my $leader=$root->first; |
112 | $bblock->{$$leader} = 0; |
113 | } |
56eca212 |
114 | } |
115 | |
a798dbf2 |
116 | sub B::PMOP::mark_if_leader { |
117 | my $op = shift; |
3f872cb9 |
118 | if ($op->name ne "pushre") { |
a798dbf2 |
119 | my $replroot = $op->pmreplroot; |
120 | if ($$replroot) { |
121 | mark_leader($replroot); |
122 | mark_leader($op->next); |
123 | mark_leader($op->pmreplstart); |
124 | } |
125 | } |
126 | } |
127 | |
128 | # PMOP stuff omitted |
129 | |
130 | sub compile { |
131 | my @options = @_; |
2b8dc4d2 |
132 | B::clearsym(); |
a798dbf2 |
133 | if (@options) { |
134 | return sub { |
135 | my $objname; |
136 | foreach $objname (@options) { |
137 | $objname = "main::$objname" unless $objname =~ /::/; |
138 | eval "walk_bblocks_obj(\\&$objname)"; |
139 | die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; |
140 | } |
141 | } |
142 | } else { |
143 | return sub { walk_bblocks(main_root, main_start) }; |
144 | } |
145 | } |
146 | |
147 | # Basic block leaders: |
148 | # Any COP (pp_nextstate) with a non-NULL label |
149 | # [The op after a pp_enter] Omit |
150 | # [The op after a pp_entersub. Don't count this one.] |
151 | # The ops pointed at by nextop, redoop and lastop->op_next of a LOOP |
152 | # The ops pointed at by op_next and op_other of a LOGOP, except |
153 | # for pp_entertry which has op_next and op_other->op_next |
a798dbf2 |
154 | # The op pointed at by op_pmreplstart of a PMOP |
155 | # The op pointed at by op_other->op_pmreplstart of pp_substcont? |
156 | # [The op after a pp_return] Omit |
157 | |
158 | 1; |
7f20e9dd |
159 | |
160 | __END__ |
161 | |
162 | =head1 NAME |
163 | |
164 | B::Bblock - Walk basic blocks |
165 | |
166 | =head1 SYNOPSIS |
167 | |
168 | perl -MO=Bblock[,OPTIONS] foo.pl |
169 | |
170 | =head1 DESCRIPTION |
171 | |
172 | See F<ext/B/README>. |
173 | |
174 | =head1 AUTHOR |
175 | |
176 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
177 | |
178 | =cut |