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