File Coverage

blib/lib/B/Bblock.pm
Criterion Covered Total %
statement 12 104 11.5
branch 0 38 0.0
condition 0 27 0.0
subroutine 4 20 20.0
pod 1 8 12.5
total 17 197 8.6


line stmt bran cond sub pod time code
1             # Maintained now in B::C by Reini Urban
2             package B::Bblock;
3              
4             our $VERSION = '1.05';
5              
6 15     15   677 use Exporter ();
  15         34  
  15         890  
7             @ISA = "Exporter";
8             our @EXPORT_OK = qw(find_leaders);
9              
10 15         1200 use B qw(peekop walkoptree walkoptree_exec
11             main_root main_start svref_2object
12 15     15   102 OPf_SPECIAL OPf_STACKED );
  15         34  
13              
14 15     15   105 use strict;
  15         33  
  15         504  
15              
16             my $bblock;
17             my @bblock_ends;
18             # don't load Config with its dependencies
19 15     15   1293 use B::C ();
  15         43  
  15         19351  
20 0 0 0 0 0   sub CPERL56 () { ($B::C::Config::Config{usecperl} and $] >= 5.025003) ? 1 : 0 } #sibparent, xpad_cop_seq
21 0 0 0 0 0   sub PUSHRE () { ($] >= 5.025006 or CPERL56) ? "split" : "pushre" }
22              
23             sub mark_leader {
24 0     0 0   my $op = shift;
25 0 0         if ($$op) {
26 0           $bblock->{$$op} = $op;
27             }
28             }
29              
30             sub remove_sortblock {
31 0     0 0   foreach ( keys %$bblock ) {
32 0           my $leader = $$bblock{$_};
33 0 0         delete $$bblock{$_} if ( $leader == 0 );
34             }
35             }
36              
37             sub find_leaders {
38 0     0 1   my ( $root, $start ) = @_;
39 0           $bblock = {};
40 0 0         mark_leader($start) if ( ref $start ne "B::NULL" );
41 0 0         walkoptree( $root, "mark_if_leader" ) if ( ( ref $root ) ne "B::NULL" );
42 0           remove_sortblock();
43 0           return $bblock;
44             }
45              
46             # Debugging
47             sub walk_bblocks {
48 0     0 0   my ( $root, $start ) = @_;
49 0           my ( $op, $lastop, $leader, $bb );
50 0           $bblock = {};
51 0           mark_leader($start);
52 0           walkoptree( $root, "mark_if_leader" );
53 0           my @leaders = values %$bblock;
54 0           while ( $leader = shift @leaders ) {
55 0           $lastop = $leader;
56 0           $op = $leader->next;
57 0   0       while ( $$op && !exists( $bblock->{$$op} ) ) {
58 0           $bblock->{$$op} = $leader;
59 0           $lastop = $op;
60 0           $op = $op->next;
61             }
62 0           push( @bblock_ends, [ $leader, $lastop ] );
63             }
64 0           foreach $bb (@bblock_ends) {
65 0           ( $leader, $lastop ) = @$bb;
66 0           printf "%s .. %s\n", peekop($leader), peekop($lastop);
67 0           for ( $op = $leader ; $$op != $$lastop ; $op = $op->next ) {
68 0           printf " %s\n", peekop($op);
69             }
70 0           printf " %s\n", peekop($lastop);
71             }
72             }
73              
74             sub walk_bblocks_obj {
75 0     0 0   my $cvref = shift;
76 0           my $cv = svref_2object($cvref);
77 0           walk_bblocks( $cv->ROOT, $cv->START );
78             }
79              
80       0     sub B::OP::mark_if_leader { }
81              
82             sub B::COP::mark_if_leader {
83 0     0     my $op = shift;
84 0 0         if ( $op->label ) {
85 0           mark_leader($op);
86             }
87             }
88              
89             sub B::LOOP::mark_if_leader {
90 0     0     my $op = shift;
91 0           mark_leader( $op->next );
92 0           mark_leader( $op->nextop );
93 0           mark_leader( $op->redoop );
94 0           mark_leader( $op->lastop->next );
95             }
96              
97             sub B::LOGOP::mark_if_leader {
98 0     0     my $op = shift;
99 0           my $opname = $op->name;
100 0           mark_leader( $op->next );
101 0 0         if ( $opname eq "entertry" ) {
102 0           mark_leader( $op->other->next );
103             }
104             else {
105 0           mark_leader( $op->other );
106             }
107             }
108              
109             sub B::LISTOP::mark_if_leader {
110 0     0     my $op = shift;
111 0           my $first = $op->first;
112 0           $first = $first->next while ( $first->name eq "null" );
113 0 0         mark_leader( $op->first ) unless ( exists( $bblock->{$$first} ) );
114 0           mark_leader( $op->next );
115 0 0 0       if ( $op->name eq "sort"
      0        
116             and $op->flags & OPf_SPECIAL
117             and $op->flags & OPf_STACKED )
118             {
119 0           my $root = $op->first->sibling->first;
120 0           my $leader = $root->first;
121 0           $bblock->{$$leader} = 0;
122             }
123             }
124              
125             sub B::PMOP::mark_if_leader {
126 0     0     my $op = shift;
127 0 0 0       if ( $op->type
      0        
      0        
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 0           my $replroot = $op->pmreplroot;
133 0 0         if ($$replroot) {
134 0           mark_leader( $replroot );
135 0           mark_leader( $op->next );
136 0           mark_leader( $op->pmreplstart );
137             }
138             }
139             }
140              
141             # PMOP stuff omitted
142              
143             sub compile {
144 0     0 0   my @options = @_;
145 0           my $have_B_Concise;
146 0           B::clearsym();
147              
148 0 0         eval { require B::Concise; 1 } and $have_B_Concise = 1;
  0            
  0            
149 0 0         B::Concise->import(qw(concise_cv concise_main set_style_standard))
150             if $have_B_Concise;
151              
152 0 0 0       if ( @options and $have_B_Concise ) {
153             return sub {
154 0     0     my $objname;
155 0           foreach $objname (@options) {
156 0 0         $objname = "main::$objname" unless $objname =~ /::/;
157 0           print "walk_bblocks $objname\n";
158 0           eval "walk_bblocks_obj(\\&$objname)";
159 0 0         die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
160 0           print "-------\n";
161 0           set_style_standard("terse");
162 0           eval "concise_cv('exec', \\&$objname)";
163 0 0         die "concise_cv('exec', \\&$objname) failed: $@" if $@;
164             }
165             }
166 0           }
167             else {
168             return sub {
169 0     0     walk_bblocks( main_root, main_start );
170 0           print "-------\n";
171 0 0         if ($have_B_Concise) {
172 0           set_style_standard("terse");
173 0           concise_main("exec");
174             }
175 0           };
176             }
177             }
178              
179             1;
180              
181             __END__