This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial check-in of perl compiler.
[perl5.git] / B / Bblock.pm
1 package B::Bblock;
2 use Exporter ();
3 @ISA = "Exporter";
4 @EXPORT_OK = qw(find_leaders);
5
6 use B qw(ad 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 (ad($op)) {
17         $bblock->{ad($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 (ad($op) && !exists($bblock->{ad($op)})) {
41             $bblock->{ad($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; ad($op) != ad($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     my $op = shift;
67     my $ppaddr = $op->ppaddr;
68 #    if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_entersub" || $ppaddr eq "pp_return") {
69     if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_return") {
70         mark_leader($op->next);
71     }
72 }
73
74 sub B::COP::mark_if_leader {
75     my $op = shift;
76     if ($op->label) {
77         mark_leader($op);
78     }
79 }
80
81 sub B::LOOP::mark_if_leader {
82     my $op = shift;
83     mark_leader($op->next);
84     mark_leader($op->nextop);
85     mark_leader($op->redoop);
86     mark_leader($op->lastop->next);
87 }
88
89 sub B::LOGOP::mark_if_leader {
90     my $op = shift;
91     my $ppaddr = $op->ppaddr;
92     mark_leader($op->next);
93     if ($ppaddr eq "pp_entertry") {
94         mark_leader($op->other->next);
95     } else {
96         mark_leader($op->other);
97     }
98 }
99
100 sub B::CONDOP::mark_if_leader {
101     my $op = shift;
102     mark_leader($op->next);
103     mark_leader($op->true);
104     mark_leader($op->false);
105 }
106
107 sub B::PMOP::mark_if_leader {
108     my $op = shift;
109     if ($op->ppaddr ne "pp_pushre") {
110         my $replroot = $op->pmreplroot;
111         if (ad($replroot)) {
112             mark_leader($replroot);
113             mark_leader($op->next);
114             mark_leader($op->pmreplstart);
115         }
116     }
117 }
118
119 # PMOP stuff omitted
120
121 sub compile {
122     my @options = @_;
123     if (@options) {
124         return sub {
125             my $objname;
126             foreach $objname (@options) {
127                 $objname = "main::$objname" unless $objname =~ /::/;
128                 eval "walk_bblocks_obj(\\&$objname)";
129                 die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
130             }
131         }
132     } else {
133         return sub { walk_bblocks(main_root, main_start) };
134     }
135 }
136
137 # Basic block leaders:
138 #     Any COP (pp_nextstate) with a non-NULL label
139 #     The op after a pp_enter
140 #     [The op after a pp_entersub. Don't count this one.]
141 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
142 #     The ops pointed at by op_next and op_other of a LOGOP, except
143 #     for pp_entertry which has op_next and op_other->op_next
144 #     The ops pointed at by op_true and op_false of a CONDOP
145 #     The op pointed at by op_pmreplstart of a PMOP
146 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
147 #     The op after a pp_return
148
149 1;