1# Maintained now in B::C by Reini Urban <rurban@cpan.org>
2package B::Bblock;
3
4our $VERSION = '1.05';
5
6use Exporter ();
7@ISA = "Exporter";
8our @EXPORT_OK = qw(find_leaders);
9
10use B qw(peekop walkoptree walkoptree_exec
11  main_root main_start svref_2object
12  OPf_SPECIAL OPf_STACKED );
13
14use strict;
15
16my $bblock;
17my @bblock_ends;
18# don't load Config with its dependencies
19use B::C ();
20sub CPERL56 () { ($B::C::Config::Config{usecperl} and $] >= 5.025003) ? 1 : 0 } #sibparent, xpad_cop_seq
21sub PUSHRE  () { ($] >= 5.025006 or CPERL56) ? "split" : "pushre" }
22
23sub mark_leader {
24  my $op = shift;
25  if ($$op) {
26    $bblock->{$$op} = $op;
27  }
28}
29
30sub remove_sortblock {
31  foreach ( keys %$bblock ) {
32    my $leader = $$bblock{$_};
33    delete $$bblock{$_} if ( $leader == 0 );
34  }
35}
36
37sub find_leaders {
38  my ( $root, $start ) = @_;
39  $bblock = {};
40  mark_leader($start) if ( ref $start ne "B::NULL" );
41  walkoptree( $root, "mark_if_leader" ) if ( ( ref $root ) ne "B::NULL" );
42  remove_sortblock();
43  return $bblock;
44}
45
46# Debugging
47sub walk_bblocks {
48  my ( $root, $start ) = @_;
49  my ( $op, $lastop, $leader, $bb );
50  $bblock = {};
51  mark_leader($start);
52  walkoptree( $root, "mark_if_leader" );
53  my @leaders = values %$bblock;
54  while ( $leader = shift @leaders ) {
55    $lastop = $leader;
56    $op     = $leader->next;
57    while ( $$op && !exists( $bblock->{$$op} ) ) {
58      $bblock->{$$op} = $leader;
59      $lastop         = $op;
60      $op             = $op->next;
61    }
62    push( @bblock_ends, [ $leader, $lastop ] );
63  }
64  foreach $bb (@bblock_ends) {
65    ( $leader, $lastop ) = @$bb;
66    printf "%s .. %s\n", peekop($leader), peekop($lastop);
67    for ( $op = $leader ; $$op != $$lastop ; $op = $op->next ) {
68      printf "    %s\n", peekop($op);
69    }
70    printf "    %s\n", peekop($lastop);
71  }
72}
73
74sub walk_bblocks_obj {
75  my $cvref = shift;
76  my $cv    = svref_2object($cvref);
77  walk_bblocks( $cv->ROOT, $cv->START );
78}
79
80sub B::OP::mark_if_leader { }
81
82sub B::COP::mark_if_leader {
83  my $op = shift;
84  if ( $op->label ) {
85    mark_leader($op);
86  }
87}
88
89sub B::LOOP::mark_if_leader {
90  my $op = shift;
91  mark_leader( $op->next );
92  mark_leader( $op->nextop );
93  mark_leader( $op->redoop );
94  mark_leader( $op->lastop->next );
95}
96
97sub B::LOGOP::mark_if_leader {
98  my $op     = shift;
99  my $opname = $op->name;
100  mark_leader( $op->next );
101  if ( $opname eq "entertry" ) {
102    mark_leader( $op->other->next );
103  }
104  else {
105    mark_leader( $op->other );
106  }
107}
108
109sub B::LISTOP::mark_if_leader {
110  my $op    = shift;
111  my $first = $op->first;
112  $first = $first->next while ( $first->name eq "null" );
113  mark_leader( $op->first ) unless ( exists( $bblock->{$$first} ) );
114  mark_leader( $op->next );
115  if (  $op->name eq "sort"
116    and $op->flags & OPf_SPECIAL
117    and $op->flags & OPf_STACKED )
118  {
119    my $root   = $op->first->sibling->first;
120    my $leader = $root->first;
121    $bblock->{$$leader} = 0;
122  }
123}
124
125sub B::PMOP::mark_if_leader {
126  my $op = shift;
127  if (  $op->type
128    and $op->name ne PUSHRE
129    and ($] > 5.008005 or $op->name ne "substcont") )
130  {
131    #warn $op->name, $op->type if $] == 5.008004;
132    my $replroot = $op->pmreplroot;
133    if ($$replroot) {
134      mark_leader( $replroot );
135      mark_leader( $op->next );
136      mark_leader( $op->pmreplstart );
137    }
138  }
139}
140
141# PMOP stuff omitted
142
143sub compile {
144  my @options = @_;
145  my $have_B_Concise;
146  B::clearsym();
147
148  eval { require B::Concise; 1 } and $have_B_Concise = 1;
149  B::Concise->import(qw(concise_cv concise_main set_style_standard))
150      if $have_B_Concise;
151
152  if ( @options and $have_B_Concise ) {
153    return sub {
154      my $objname;
155      foreach $objname (@options) {
156        $objname = "main::$objname" unless $objname =~ /::/;
157        print "walk_bblocks $objname\n";
158        eval "walk_bblocks_obj(\\&$objname)";
159        die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
160        print "-------\n";
161        set_style_standard("terse");
162        eval "concise_cv('exec', \\&$objname)";
163        die "concise_cv('exec', \\&$objname) failed: $@" if $@;
164      }
165      }
166  }
167  else {
168    return sub {
169      walk_bblocks( main_root, main_start );
170      print "-------\n";
171      if ($have_B_Concise) {
172        set_style_standard("terse");
173        concise_main("exec");
174      }
175    };
176  }
177}
178
1791;
180
181__END__
182
183=head1 NAME
184
185B::Bblock - Walk basic blocks
186
187=head1 SYNOPSIS
188
189  # External interface
190  perl -MO=Bblock[,OPTIONS] foo.pl
191
192    perl -MO=Bblock foo.pl     prints the basic block for main_root
193    perl -MO=Bblock,foo::mysub foo.pm prints the basic block for &pkg::mysub
194    perl -MO=Bblock,mysub foo.pm prints the basic block for &main::mysub
195
196  # Programmatic API
197  use B::Bblock qw(find_leaders);
198  my $leaders = find_leaders($root_op, $start_op);
199
200=head1 DESCRIPTION
201
202This module is used by the L<B::CC> backend.  It walks "basic blocks".
203A basic block is a series of operations which is known to execute from
204start to finish, with no possibility of branching or halting.
205
206The block is the list of ops from the every leader up to the next.
207The leaders are the separator of each basic block.
208
209The module can be used either stand alone or from inside another program.
210Standalone it just prints the basic blocks ops in L<B::Concise>.
211terse format to STDOUT.
212Without options it starts at the main_root.
213
214Basic block leaders are:
215
216     Any COP (pp_nextstate) with a non-NULL label.
217       [The op after a pp_enter] Omit
218       [The op after a pp_entersub. Don't count this one.]
219     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP.
220     The ops pointed at by op_next and op_other of a LOGOP, except
221       for pp_entertry which has op_next and op_other->op_next
222     The op pointed at by op_pmreplstart of a PMOP.
223     The op pointed at by op_other->op_pmreplstart of pp_substcont?
224       [The op after a pp_return] Omit
225
226=head1 OPTIONS
227
228A comma-separated list of sub names to walk.
229
230=head2 Functions
231
232=over 4
233
234=item B<find_leaders>
235
236  my $leaders = find_leaders($root_op, $start_op);
237
238Given the root of the op tree and an op from which to start
239processing, it will return a hash ref representing all the ops which
240start a block.
241
242The values of %$leaders are the op objects themselves.  Keys are $$op
243addresses.
244
245=back
246
247=head1 AUTHOR
248
249Malcolm Beattie C<MICB at cpan.org> I<(retired)>,
250Reini Urban C<perl-compiler@googlegroups.com>
251
252=cut
253
254# Local Variables:
255#   mode: cperl
256#   cperl-indent-level: 2
257#   fill-column: 78
258# End:
259# vim: expandtab shiftwidth=2:
260