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.pm
1 #      B.pm
2 #
3 #      Copyright (c) 1996 Malcolm Beattie
4 #
5 #      You may distribute under the terms of either the GNU General Public
6 #      License or the Artistic License, as specified in the README file.
7 #
8 package B;
9 require DynaLoader;
10 require Exporter;
11 @ISA = qw(Exporter DynaLoader);
12 @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
13                 class peekop cast_I32 ad cstring cchar hash
14                 main_root main_start main_cv svref_2object
15                 walkoptree walkoptree_exec walksymtable
16                 comppadlist sv_undef compile_stats timing_info);
17
18 use strict;
19 @B::SV::ISA = 'B::OBJECT';
20 @B::NULL::ISA = 'B::SV';
21 @B::PV::ISA = 'B::SV';
22 @B::IV::ISA = 'B::SV';
23 @B::NV::ISA = 'B::IV';
24 @B::RV::ISA = 'B::SV';
25 @B::PVIV::ISA = qw(B::PV B::IV);
26 @B::PVNV::ISA = qw(B::PV B::NV);
27 @B::PVMG::ISA = 'B::PVNV';
28 @B::PVLV::ISA = 'B::PVMG';
29 @B::BM::ISA = 'B::PVMG';
30 @B::AV::ISA = 'B::PVMG';
31 @B::GV::ISA = 'B::PVMG';
32 @B::HV::ISA = 'B::PVMG';
33 @B::CV::ISA = 'B::PVMG';
34 @B::IO::ISA = 'B::CV';
35
36 @B::OP::ISA = 'B::OBJECT';
37 @B::UNOP::ISA = 'B::OP';
38 @B::BINOP::ISA = 'B::UNOP';
39 @B::LOGOP::ISA = 'B::UNOP';
40 @B::CONDOP::ISA = 'B::UNOP';
41 @B::LISTOP::ISA = 'B::BINOP';
42 @B::SVOP::ISA = 'B::OP';
43 @B::GVOP::ISA = 'B::OP';
44 @B::PVOP::ISA = 'B::OP';
45 @B::CVOP::ISA = 'B::OP';
46 @B::LOOP::ISA = 'B::LISTOP';
47 @B::PMOP::ISA = 'B::LISTOP';
48 @B::COP::ISA = 'B::OP';
49
50 @B::SPECIAL::ISA = 'B::OBJECT';
51
52 {
53     # Stop "-w" from complaining about the lack of a real B::OBJECT class
54     package B::OBJECT;
55 }
56
57 my $debug;
58 my $op_count = 0;
59
60 sub debug {
61     my ($class, $value) = @_;
62     $debug = $value;
63 }
64
65 # sub OPf_KIDS;
66 # add to .xs for perl5.002
67 sub OPf_KIDS () { 4 }
68
69 sub ad {
70     my $obj = shift;
71     return $$obj;
72 }
73
74 sub class {
75     my $obj = shift;
76     my $name = ref $obj;
77     $name =~ s/^.*:://;
78     return $name;
79 }
80
81 # For debugging
82 sub peekop {
83     my $op = shift;
84     return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
85 }
86
87 sub walkoptree {
88     my($op, $method, $level) = @_;
89     $op_count++; # just for statistics
90     $level ||= 0;
91     warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
92     $op->$method($level);
93     if (ad($op) && ($op->flags & OPf_KIDS)) {
94         my $kid;
95         for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
96             walkoptree($kid, $method, $level + 1);
97         }
98     }
99 }
100
101 sub compile_stats {
102     return "Total number of OPs processed: $op_count\n";
103 }
104
105 sub timing_info {
106     my ($sec, $min, $hr) = localtime;
107     my ($user, $sys) = times;
108     sprintf("%02d:%02d:%02d user=$user sys=$sys",
109             $hr, $min, $sec, $user, $sys);
110 }
111
112 my %symtable;
113 sub savesym {
114     my ($obj, $value) = @_;
115 #    warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
116     $symtable{sprintf("sym_%x", ad($obj))} = $value;
117 }
118
119 sub objsym {
120     my $obj = shift;
121     return $symtable{sprintf("sym_%x", ad($obj))};
122 }
123
124 sub walkoptree_exec {
125     my ($op, $method, $level) = @_;
126     my ($sym, $ppname);
127     my $prefix = "    " x $level;
128     for (; $$op; $op = $op->next) {
129         $sym = objsym($op);
130         if (defined($sym)) {
131             print $prefix, "goto $sym\n";
132             return;
133         }
134         savesym($op, sprintf("%s (0x%lx)", class($op), ad($op)));
135         $op->$method($level);
136         $ppname = $op->ppaddr;
137         if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
138             print $prefix, uc($1), " => {\n";
139             walkoptree_exec($op->other, $method, $level + 1);
140             print $prefix, "}\n";
141         } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
142             my $pmreplstart = $op->pmreplstart;
143             if (ad($pmreplstart)) {
144                 print $prefix, "PMREPLSTART => {\n";
145                 walkoptree_exec($pmreplstart, $method, $level + 1);
146                 print $prefix, "}\n";
147             }
148         } elsif ($ppname eq "pp_substcont") {
149             print $prefix, "SUBSTCONT => {\n";
150             walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
151             print $prefix, "}\n";
152             $op = $op->other;
153         } elsif ($ppname eq "pp_cond_expr") {
154             # pp_cond_expr never returns op_next
155             print $prefix, "TRUE => {\n";
156             walkoptree_exec($op->true, $method, $level + 1);
157             print $prefix, "}\n";
158             $op = $op->false;
159             redo;
160         } elsif ($ppname eq "pp_range") {
161             print $prefix, "TRUE => {\n";
162             walkoptree_exec($op->true, $method, $level + 1);
163             print $prefix, "}\n", $prefix, "FALSE => {\n";
164             walkoptree_exec($op->false, $method, $level + 1);
165             print $prefix, "}\n";
166         } elsif ($ppname eq "pp_enterloop") {
167             print $prefix, "REDO => {\n";
168             walkoptree_exec($op->redoop, $method, $level + 1);
169             print $prefix, "}\n", $prefix, "NEXT => {\n";
170             walkoptree_exec($op->nextop, $method, $level + 1);
171             print $prefix, "}\n", $prefix, "LAST => {\n";
172             walkoptree_exec($op->lastop,  $method, $level + 1);
173             print $prefix, "}\n";
174         } elsif ($ppname eq "pp_subst") {
175             my $replstart = $op->pmreplstart;
176             if (ad($replstart)) {
177                 print $prefix, "SUBST => {\n";
178                 walkoptree_exec($replstart, $method, $level + 1);
179                 print $prefix, "}\n";
180             }
181         }
182     }
183 }
184
185 sub walksymtable {
186     my ($symref, $method, $recurse) = @_;
187     my $sym;
188     no strict 'vars';
189     local(*glob);
190     while (($sym, *glob) = each %$symref) {
191         if ($sym =~ /::$/) {
192             if ($sym ne "main::" && &$recurse($sym)) {
193                 walksymtable(\%glob, $method, $recurse);
194             }
195         } else {
196             svref_2object(\*glob)->EGV->$method();
197         }
198     }
199 }
200
201 bootstrap B;
202
203 1;