1 | # B::Bytecode.pm
|
---|
2 | # Copyright (c) 2003 Enache Adrian. All rights reserved.
|
---|
3 | # This module is free software; you can redistribute and/or modify
|
---|
4 | # it under the same terms as Perl itself.
|
---|
5 |
|
---|
6 | # Based on the original Bytecode.pm module written by Malcolm Beattie.
|
---|
7 |
|
---|
8 | package B::Bytecode;
|
---|
9 |
|
---|
10 | our $VERSION = '1.01_01';
|
---|
11 |
|
---|
12 | use strict;
|
---|
13 | use Config;
|
---|
14 | use B qw(class main_cv main_root main_start cstring comppadlist
|
---|
15 | defstash curstash begin_av init_av end_av inc_gv warnhook diehook
|
---|
16 | dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
|
---|
17 | OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
|
---|
18 | use B::Asmdata qw(@specialsv_name);
|
---|
19 | use B::Assembler qw(asm newasm endasm);
|
---|
20 |
|
---|
21 | #################################################
|
---|
22 |
|
---|
23 | my ($varix, $opix, $savebegins, %walked, %files, @cloop);
|
---|
24 | my %strtab = (0,0);
|
---|
25 | my %svtab = (0,0);
|
---|
26 | my %optab = (0,0);
|
---|
27 | my %spectab = (0,0);
|
---|
28 | my $tix = 1;
|
---|
29 | sub asm;
|
---|
30 | sub nice ($) { }
|
---|
31 |
|
---|
32 | BEGIN {
|
---|
33 | my $ithreads = $Config{'useithreads'} eq 'define';
|
---|
34 | eval qq{
|
---|
35 | sub ITHREADS() { $ithreads }
|
---|
36 | sub VERSION() { $] }
|
---|
37 | }; die $@ if $@;
|
---|
38 | }
|
---|
39 |
|
---|
40 | #################################################
|
---|
41 |
|
---|
42 | sub pvstring {
|
---|
43 | my $pv = shift;
|
---|
44 | defined($pv) ? cstring ($pv."\0") : "\"\"";
|
---|
45 | }
|
---|
46 |
|
---|
47 | sub pvix {
|
---|
48 | my $str = pvstring shift;
|
---|
49 | my $ix = $strtab{$str};
|
---|
50 | defined($ix) ? $ix : do {
|
---|
51 | asm "newpv", $str;
|
---|
52 | asm "stpv", $strtab{$str} = $tix;
|
---|
53 | $tix++;
|
---|
54 | }
|
---|
55 | }
|
---|
56 |
|
---|
57 | sub B::OP::ix {
|
---|
58 | my $op = shift;
|
---|
59 | my $ix = $optab{$$op};
|
---|
60 | defined($ix) ? $ix : do {
|
---|
61 | nice "[".$op->name." $tix]";
|
---|
62 | asm "newopx", $op->size | $op->type <<7;
|
---|
63 | $optab{$$op} = $opix = $ix = $tix++;
|
---|
64 | $op->bsave($ix);
|
---|
65 | $ix;
|
---|
66 | }
|
---|
67 | }
|
---|
68 |
|
---|
69 | sub B::SPECIAL::ix {
|
---|
70 | my $spec = shift;
|
---|
71 | my $ix = $spectab{$$spec};
|
---|
72 | defined($ix) ? $ix : do {
|
---|
73 | nice '['.$specialsv_name[$$spec].']';
|
---|
74 | asm "ldspecsvx", $$spec;
|
---|
75 | $spectab{$$spec} = $varix = $tix++;
|
---|
76 | }
|
---|
77 | }
|
---|
78 |
|
---|
79 | sub B::SV::ix {
|
---|
80 | my $sv = shift;
|
---|
81 | my $ix = $svtab{$$sv};
|
---|
82 | defined($ix) ? $ix : do {
|
---|
83 | nice '['.class($sv).']';
|
---|
84 | asm "newsvx", $sv->FLAGS;
|
---|
85 | $svtab{$$sv} = $varix = $ix = $tix++;
|
---|
86 | $sv->bsave($ix);
|
---|
87 | $ix;
|
---|
88 | }
|
---|
89 | }
|
---|
90 |
|
---|
91 | sub B::GV::ix {
|
---|
92 | my ($gv,$desired) = @_;
|
---|
93 | my $ix = $svtab{$$gv};
|
---|
94 | defined($ix) ? $ix : do {
|
---|
95 | if ($gv->GP) {
|
---|
96 | my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
|
---|
97 | nice "[GV]";
|
---|
98 | my $name = $gv->STASH->NAME . "::" . $gv->NAME;
|
---|
99 | asm "gv_fetchpvx", cstring $name;
|
---|
100 | $svtab{$$gv} = $varix = $ix = $tix++;
|
---|
101 | asm "sv_flags", $gv->FLAGS;
|
---|
102 | asm "sv_refcnt", $gv->REFCNT;
|
---|
103 | asm "xgv_flags", $gv->GvFLAGS;
|
---|
104 |
|
---|
105 | asm "gp_refcnt", $gv->GvREFCNT;
|
---|
106 | asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
|
---|
107 | return $ix
|
---|
108 | unless $desired || desired $gv;
|
---|
109 | $svix = $gv->SV->ix;
|
---|
110 | $avix = $gv->AV->ix;
|
---|
111 | $hvix = $gv->HV->ix;
|
---|
112 |
|
---|
113 | # XXX {{{{
|
---|
114 | my $cv = $gv->CV;
|
---|
115 | $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
|
---|
116 | my $form = $gv->FORM;
|
---|
117 | $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
|
---|
118 |
|
---|
119 | $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
|
---|
120 | # }}}} XXX
|
---|
121 |
|
---|
122 | nice "-GV-",
|
---|
123 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
124 | asm "gp_sv", $svix;
|
---|
125 | asm "gp_av", $avix;
|
---|
126 | asm "gp_hv", $hvix;
|
---|
127 | asm "gp_cv", $cvix;
|
---|
128 | asm "gp_io", $ioix;
|
---|
129 | asm "gp_cvgen", $gv->CVGEN;
|
---|
130 | asm "gp_form", $formix;
|
---|
131 | asm "gp_file", pvix $gv->FILE;
|
---|
132 | asm "gp_line", $gv->LINE;
|
---|
133 | asm "formfeed", $svix if $name eq "main::\cL";
|
---|
134 | } else {
|
---|
135 | nice "[GV]";
|
---|
136 | asm "newsvx", $gv->FLAGS;
|
---|
137 | $svtab{$$gv} = $varix = $ix = $tix++;
|
---|
138 | my $stashix = $gv->STASH->ix;
|
---|
139 | $gv->B::PVMG::bsave($ix);
|
---|
140 | asm "xgv_flags", $gv->GvFLAGS;
|
---|
141 | asm "xgv_stash", $stashix;
|
---|
142 | }
|
---|
143 | $ix;
|
---|
144 | }
|
---|
145 | }
|
---|
146 |
|
---|
147 | sub B::HV::ix {
|
---|
148 | my $hv = shift;
|
---|
149 | my $ix = $svtab{$$hv};
|
---|
150 | defined($ix) ? $ix : do {
|
---|
151 | my ($ix,$i,@array);
|
---|
152 | my $name = $hv->NAME;
|
---|
153 | if ($name) {
|
---|
154 | nice "[STASH]";
|
---|
155 | asm "gv_stashpvx", cstring $name;
|
---|
156 | asm "sv_flags", $hv->FLAGS;
|
---|
157 | $svtab{$$hv} = $varix = $ix = $tix++;
|
---|
158 | asm "xhv_name", pvix $name;
|
---|
159 | # my $pmrootix = $hv->PMROOT->ix; # XXX
|
---|
160 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
161 | # asm "xhv_pmroot", $pmrootix; # XXX
|
---|
162 | } else {
|
---|
163 | nice "[HV]";
|
---|
164 | asm "newsvx", $hv->FLAGS;
|
---|
165 | $svtab{$$hv} = $varix = $ix = $tix++;
|
---|
166 | my $stashix = $hv->SvSTASH->ix;
|
---|
167 | for (@array = $hv->ARRAY) {
|
---|
168 | next if $i = not $i;
|
---|
169 | $_ = $_->ix;
|
---|
170 | }
|
---|
171 | nice "-HV-",
|
---|
172 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
173 | ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
|
---|
174 | for @array;
|
---|
175 | if (VERSION < 5.009) {
|
---|
176 | asm "xnv", $hv->NVX;
|
---|
177 | }
|
---|
178 | asm "xmg_stash", $stashix;
|
---|
179 | asm "xhv_riter", $hv->RITER;
|
---|
180 | }
|
---|
181 | asm "sv_refcnt", $hv->REFCNT;
|
---|
182 | $ix;
|
---|
183 | }
|
---|
184 | }
|
---|
185 |
|
---|
186 | sub B::NULL::ix {
|
---|
187 | my $sv = shift;
|
---|
188 | $$sv ? $sv->B::SV::ix : 0;
|
---|
189 | }
|
---|
190 |
|
---|
191 | sub B::NULL::opwalk { 0 }
|
---|
192 |
|
---|
193 | #################################################
|
---|
194 |
|
---|
195 | sub B::NULL::bsave {
|
---|
196 | my ($sv,$ix) = @_;
|
---|
197 |
|
---|
198 | nice '-'.class($sv).'-',
|
---|
199 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
200 | asm "sv_refcnt", $sv->REFCNT;
|
---|
201 | }
|
---|
202 |
|
---|
203 | sub B::SV::bsave;
|
---|
204 | *B::SV::bsave = *B::NULL::bsave;
|
---|
205 |
|
---|
206 | sub B::RV::bsave {
|
---|
207 | my ($sv,$ix) = @_;
|
---|
208 | my $rvix = $sv->RV->ix;
|
---|
209 | $sv->B::NULL::bsave($ix);
|
---|
210 | asm "xrv", $rvix;
|
---|
211 | }
|
---|
212 |
|
---|
213 | sub B::PV::bsave {
|
---|
214 | my ($sv,$ix) = @_;
|
---|
215 | $sv->B::NULL::bsave($ix);
|
---|
216 | asm "newpv", pvstring $sv->PVBM;
|
---|
217 | asm "xpv";
|
---|
218 | }
|
---|
219 |
|
---|
220 | sub B::IV::bsave {
|
---|
221 | my ($sv,$ix) = @_;
|
---|
222 | $sv->B::NULL::bsave($ix);
|
---|
223 | asm "xiv", $sv->IVX;
|
---|
224 | }
|
---|
225 |
|
---|
226 | sub B::NV::bsave {
|
---|
227 | my ($sv,$ix) = @_;
|
---|
228 | $sv->B::NULL::bsave($ix);
|
---|
229 | asm "xnv", sprintf "%.40g", $sv->NVX;
|
---|
230 | }
|
---|
231 |
|
---|
232 | sub B::PVIV::bsave {
|
---|
233 | my ($sv,$ix) = @_;
|
---|
234 | $sv->POK ?
|
---|
235 | $sv->B::PV::bsave($ix):
|
---|
236 | $sv->ROK ?
|
---|
237 | $sv->B::RV::bsave($ix):
|
---|
238 | $sv->B::NULL::bsave($ix);
|
---|
239 | if (VERSION >= 5.009) {
|
---|
240 | # See note below in B::PVNV::bsave
|
---|
241 | return if $sv->isa('B::AV');
|
---|
242 | return if $sv->isa('B::HV');
|
---|
243 | }
|
---|
244 | asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
|
---|
245 | "0 but true" : $sv->IVX;
|
---|
246 | }
|
---|
247 |
|
---|
248 | sub B::PVNV::bsave {
|
---|
249 | my ($sv,$ix) = @_;
|
---|
250 | $sv->B::PVIV::bsave($ix);
|
---|
251 | if (VERSION >= 5.009) {
|
---|
252 | # Magical AVs end up here, but AVs now don't have an NV slot actually
|
---|
253 | # allocated. Hence don't write out assembly to store the NV slot if
|
---|
254 | # we're actually an array.
|
---|
255 | return if $sv->isa('B::AV');
|
---|
256 | # Likewise HVs have no NV slot actually allocated.
|
---|
257 | # I don't think that they can get here, but better safe than sorry
|
---|
258 | return if $sv->isa('B::HV');
|
---|
259 | }
|
---|
260 | asm "xnv", sprintf "%.40g", $sv->NVX;
|
---|
261 | }
|
---|
262 |
|
---|
263 | sub B::PVMG::domagic {
|
---|
264 | my ($sv,$ix) = @_;
|
---|
265 | nice '-MAGICAL-';
|
---|
266 | my @mglist = $sv->MAGIC;
|
---|
267 | my (@mgix, @namix);
|
---|
268 | for (@mglist) {
|
---|
269 | push @mgix, $_->OBJ->ix;
|
---|
270 | push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
|
---|
271 | }
|
---|
272 |
|
---|
273 | nice '-'.class($sv).'-',
|
---|
274 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
275 | for (@mglist) {
|
---|
276 | asm "sv_magic", cstring $_->TYPE;
|
---|
277 | asm "mg_obj", shift @mgix;
|
---|
278 | my $length = $_->LENGTH;
|
---|
279 | if ($length == B::HEf_SVKEY) {
|
---|
280 | asm "mg_namex", shift @namix;
|
---|
281 | } elsif ($length) {
|
---|
282 | asm "newpv", pvstring $_->PTR;
|
---|
283 | asm "mg_name";
|
---|
284 | }
|
---|
285 | }
|
---|
286 | }
|
---|
287 |
|
---|
288 | sub B::PVMG::bsave {
|
---|
289 | my ($sv,$ix) = @_;
|
---|
290 | my $stashix = $sv->SvSTASH->ix;
|
---|
291 | $sv->B::PVNV::bsave($ix);
|
---|
292 | asm "xmg_stash", $stashix;
|
---|
293 | $sv->domagic($ix) if $sv->MAGICAL;
|
---|
294 | }
|
---|
295 |
|
---|
296 | sub B::PVLV::bsave {
|
---|
297 | my ($sv,$ix) = @_;
|
---|
298 | my $targix = $sv->TARG->ix;
|
---|
299 | $sv->B::PVMG::bsave($ix);
|
---|
300 | asm "xlv_targ", $targix;
|
---|
301 | asm "xlv_targoff", $sv->TARGOFF;
|
---|
302 | asm "xlv_targlen", $sv->TARGLEN;
|
---|
303 | asm "xlv_type", $sv->TYPE;
|
---|
304 |
|
---|
305 | }
|
---|
306 |
|
---|
307 | sub B::BM::bsave {
|
---|
308 | my ($sv,$ix) = @_;
|
---|
309 | $sv->B::PVMG::bsave($ix);
|
---|
310 | asm "xpv_cur", $sv->CUR;
|
---|
311 | asm "xbm_useful", $sv->USEFUL;
|
---|
312 | asm "xbm_previous", $sv->PREVIOUS;
|
---|
313 | asm "xbm_rare", $sv->RARE;
|
---|
314 | }
|
---|
315 |
|
---|
316 | sub B::IO::bsave {
|
---|
317 | my ($io,$ix) = @_;
|
---|
318 | my $topix = $io->TOP_GV->ix;
|
---|
319 | my $fmtix = $io->FMT_GV->ix;
|
---|
320 | my $bottomix = $io->BOTTOM_GV->ix;
|
---|
321 | $io->B::PVMG::bsave($ix);
|
---|
322 | asm "xio_lines", $io->LINES;
|
---|
323 | asm "xio_page", $io->PAGE;
|
---|
324 | asm "xio_page_len", $io->PAGE_LEN;
|
---|
325 | asm "xio_lines_left", $io->LINES_LEFT;
|
---|
326 | asm "xio_top_name", pvix $io->TOP_NAME;
|
---|
327 | asm "xio_top_gv", $topix;
|
---|
328 | asm "xio_fmt_name", pvix $io->FMT_NAME;
|
---|
329 | asm "xio_fmt_gv", $fmtix;
|
---|
330 | asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
|
---|
331 | asm "xio_bottom_gv", $bottomix;
|
---|
332 | asm "xio_subprocess", $io->SUBPROCESS;
|
---|
333 | asm "xio_type", ord $io->IoTYPE;
|
---|
334 | # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
|
---|
335 | }
|
---|
336 |
|
---|
337 | sub B::CV::bsave {
|
---|
338 | my ($cv,$ix) = @_;
|
---|
339 | my $stashix = $cv->STASH->ix;
|
---|
340 | my $gvix = $cv->GV->ix;
|
---|
341 | my $padlistix = $cv->PADLIST->ix;
|
---|
342 | my $outsideix = $cv->OUTSIDE->ix;
|
---|
343 | my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
|
---|
344 | my $startix = $cv->START->opwalk;
|
---|
345 | my $rootix = $cv->ROOT->ix;
|
---|
346 |
|
---|
347 | $cv->B::PVMG::bsave($ix);
|
---|
348 | asm "xcv_stash", $stashix;
|
---|
349 | asm "xcv_start", $startix;
|
---|
350 | asm "xcv_root", $rootix;
|
---|
351 | asm "xcv_xsubany", $constix;
|
---|
352 | asm "xcv_gv", $gvix;
|
---|
353 | asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
|
---|
354 | asm "xcv_padlist", $padlistix;
|
---|
355 | asm "xcv_outside", $outsideix;
|
---|
356 | asm "xcv_flags", $cv->CvFLAGS;
|
---|
357 | asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
|
---|
358 | asm "xcv_depth", $cv->DEPTH;
|
---|
359 | }
|
---|
360 |
|
---|
361 | sub B::FM::bsave {
|
---|
362 | my ($form,$ix) = @_;
|
---|
363 |
|
---|
364 | $form->B::CV::bsave($ix);
|
---|
365 | asm "xfm_lines", $form->LINES;
|
---|
366 | }
|
---|
367 |
|
---|
368 | sub B::AV::bsave {
|
---|
369 | my ($av,$ix) = @_;
|
---|
370 | return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
|
---|
371 | my @array = $av->ARRAY;
|
---|
372 | $_ = $_->ix for @array;
|
---|
373 | my $stashix = $av->SvSTASH->ix;
|
---|
374 |
|
---|
375 | nice "-AV-",
|
---|
376 | asm "ldsv", $varix = $ix unless $ix == $varix;
|
---|
377 | asm "av_extend", $av->MAX if $av->MAX >= 0;
|
---|
378 | asm "av_pushx", $_ for @array;
|
---|
379 | asm "sv_refcnt", $av->REFCNT;
|
---|
380 | if (VERSION < 5.009) {
|
---|
381 | asm "xav_flags", $av->AvFLAGS;
|
---|
382 | }
|
---|
383 | asm "xmg_stash", $stashix;
|
---|
384 | }
|
---|
385 |
|
---|
386 | sub B::GV::desired {
|
---|
387 | my $gv = shift;
|
---|
388 | my ($cv, $form);
|
---|
389 | $files{$gv->FILE} && $gv->LINE
|
---|
390 | || ${$cv = $gv->CV} && $files{$cv->FILE}
|
---|
391 | || ${$form = $gv->FORM} && $files{$form->FILE}
|
---|
392 | }
|
---|
393 |
|
---|
394 | sub B::HV::bwalk {
|
---|
395 | my $hv = shift;
|
---|
396 | return if $walked{$$hv}++;
|
---|
397 | my %stash = $hv->ARRAY;
|
---|
398 | while (my($k,$v) = each %stash) {
|
---|
399 | if ($v->SvTYPE == SVt_PVGV) {
|
---|
400 | my $hash = $v->HV;
|
---|
401 | if ($$hash && $hash->NAME) {
|
---|
402 | $hash->bwalk;
|
---|
403 | }
|
---|
404 | $v->ix(1) if desired $v;
|
---|
405 | } else {
|
---|
406 | nice "[prototype]";
|
---|
407 | asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
|
---|
408 | $svtab{$$v} = $varix = $tix;
|
---|
409 | $v->bsave($tix++);
|
---|
410 | asm "sv_flags", $v->FLAGS;
|
---|
411 | }
|
---|
412 | }
|
---|
413 | }
|
---|
414 |
|
---|
415 | ######################################################
|
---|
416 |
|
---|
417 |
|
---|
418 | sub B::OP::bsave_thin {
|
---|
419 | my ($op, $ix) = @_;
|
---|
420 | my $next = $op->next;
|
---|
421 | my $nextix = $optab{$$next};
|
---|
422 | $nextix = 0, push @cloop, $op unless defined $nextix;
|
---|
423 | if ($ix != $opix) {
|
---|
424 | nice '-'.$op->name.'-',
|
---|
425 | asm "ldop", $opix = $ix;
|
---|
426 | }
|
---|
427 | asm "op_next", $nextix;
|
---|
428 | asm "op_targ", $op->targ if $op->type; # tricky
|
---|
429 | asm "op_flags", $op->flags;
|
---|
430 | asm "op_private", $op->private;
|
---|
431 | }
|
---|
432 |
|
---|
433 | sub B::OP::bsave;
|
---|
434 | *B::OP::bsave = *B::OP::bsave_thin;
|
---|
435 |
|
---|
436 | sub B::UNOP::bsave {
|
---|
437 | my ($op, $ix) = @_;
|
---|
438 | my $name = $op->name;
|
---|
439 | my $flags = $op->flags;
|
---|
440 | my $first = $op->first;
|
---|
441 | my $firstix =
|
---|
442 | $name =~ /fl[io]p/
|
---|
443 | # that's just neat
|
---|
444 | || (!ITHREADS && $name eq 'regcomp')
|
---|
445 | # trick for /$a/o in pp_regcomp
|
---|
446 | || $name eq 'rv2sv'
|
---|
447 | && $op->flags & OPf_MOD
|
---|
448 | && $op->private & OPpLVAL_INTRO
|
---|
449 | # change #18774 made my life hard
|
---|
450 | ? $first->ix
|
---|
451 | : 0;
|
---|
452 |
|
---|
453 | $op->B::OP::bsave($ix);
|
---|
454 | asm "op_first", $firstix;
|
---|
455 | }
|
---|
456 |
|
---|
457 | sub B::BINOP::bsave {
|
---|
458 | my ($op, $ix) = @_;
|
---|
459 | if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
|
---|
460 | my $last = $op->last;
|
---|
461 | my $lastix = do {
|
---|
462 | local *B::OP::bsave = *B::OP::bsave_fat;
|
---|
463 | local *B::UNOP::bsave = *B::UNOP::bsave_fat;
|
---|
464 | $last->ix;
|
---|
465 | };
|
---|
466 | asm "ldop", $lastix unless $lastix == $opix;
|
---|
467 | asm "op_targ", $last->targ;
|
---|
468 | $op->B::OP::bsave($ix);
|
---|
469 | asm "op_last", $lastix;
|
---|
470 | } else {
|
---|
471 | $op->B::OP::bsave($ix);
|
---|
472 | }
|
---|
473 | }
|
---|
474 |
|
---|
475 | # not needed if no pseudohashes
|
---|
476 |
|
---|
477 | *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
|
---|
478 |
|
---|
479 | # deal with sort / formline
|
---|
480 |
|
---|
481 | sub B::LISTOP::bsave {
|
---|
482 | my ($op, $ix) = @_;
|
---|
483 | my $name = $op->name;
|
---|
484 | sub blocksort() { OPf_SPECIAL|OPf_STACKED }
|
---|
485 | if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
|
---|
486 | my $first = $op->first;
|
---|
487 | my $pushmark = $first->sibling;
|
---|
488 | my $rvgv = $pushmark->first;
|
---|
489 | my $leave = $rvgv->first;
|
---|
490 |
|
---|
491 | my $leaveix = $leave->ix;
|
---|
492 |
|
---|
493 | my $rvgvix = $rvgv->ix;
|
---|
494 | asm "ldop", $rvgvix unless $rvgvix == $opix;
|
---|
495 | asm "op_first", $leaveix;
|
---|
496 |
|
---|
497 | my $pushmarkix = $pushmark->ix;
|
---|
498 | asm "ldop", $pushmarkix unless $pushmarkix == $opix;
|
---|
499 | asm "op_first", $rvgvix;
|
---|
500 |
|
---|
501 | my $firstix = $first->ix;
|
---|
502 | asm "ldop", $firstix unless $firstix == $opix;
|
---|
503 | asm "op_sibling", $pushmarkix;
|
---|
504 |
|
---|
505 | $op->B::OP::bsave($ix);
|
---|
506 | asm "op_first", $firstix;
|
---|
507 | } elsif ($name eq 'formline') {
|
---|
508 | $op->B::UNOP::bsave_fat($ix);
|
---|
509 | } else {
|
---|
510 | $op->B::OP::bsave($ix);
|
---|
511 | }
|
---|
512 | }
|
---|
513 |
|
---|
514 | # fat versions
|
---|
515 |
|
---|
516 | sub B::OP::bsave_fat {
|
---|
517 | my ($op, $ix) = @_;
|
---|
518 | my $siblix = $op->sibling->ix;
|
---|
519 |
|
---|
520 | $op->B::OP::bsave_thin($ix);
|
---|
521 | asm "op_sibling", $siblix;
|
---|
522 | # asm "op_seq", -1; XXX don't allocate OPs piece by piece
|
---|
523 | }
|
---|
524 |
|
---|
525 | sub B::UNOP::bsave_fat {
|
---|
526 | my ($op,$ix) = @_;
|
---|
527 | my $firstix = $op->first->ix;
|
---|
528 |
|
---|
529 | $op->B::OP::bsave($ix);
|
---|
530 | asm "op_first", $firstix;
|
---|
531 | }
|
---|
532 |
|
---|
533 | sub B::BINOP::bsave_fat {
|
---|
534 | my ($op,$ix) = @_;
|
---|
535 | my $last = $op->last;
|
---|
536 | my $lastix = $op->last->ix;
|
---|
537 | if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
|
---|
538 | asm "ldop", $lastix unless $lastix == $opix;
|
---|
539 | asm "op_targ", $last->targ;
|
---|
540 | }
|
---|
541 |
|
---|
542 | $op->B::UNOP::bsave($ix);
|
---|
543 | asm "op_last", $lastix;
|
---|
544 | }
|
---|
545 |
|
---|
546 | sub B::LOGOP::bsave {
|
---|
547 | my ($op,$ix) = @_;
|
---|
548 | my $otherix = $op->other->ix;
|
---|
549 |
|
---|
550 | $op->B::UNOP::bsave($ix);
|
---|
551 | asm "op_other", $otherix;
|
---|
552 | }
|
---|
553 |
|
---|
554 | sub B::PMOP::bsave {
|
---|
555 | my ($op,$ix) = @_;
|
---|
556 | my ($rrop, $rrarg, $rstart);
|
---|
557 |
|
---|
558 | # my $pmnextix = $op->pmnext->ix; # XXX
|
---|
559 |
|
---|
560 | if (ITHREADS) {
|
---|
561 | if ($op->name eq 'subst') {
|
---|
562 | $rrop = "op_pmreplroot";
|
---|
563 | $rrarg = $op->pmreplroot->ix;
|
---|
564 | $rstart = $op->pmreplstart->ix;
|
---|
565 | } elsif ($op->name eq 'pushre') {
|
---|
566 | $rrop = "op_pmreplrootpo";
|
---|
567 | $rrarg = $op->pmreplroot;
|
---|
568 | }
|
---|
569 | $op->B::BINOP::bsave($ix);
|
---|
570 | asm "op_pmstashpv", pvix $op->pmstashpv;
|
---|
571 | } else {
|
---|
572 | $rrop = "op_pmreplrootgv";
|
---|
573 | $rrarg = $op->pmreplroot->ix;
|
---|
574 | $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
|
---|
575 | my $stashix = $op->pmstash->ix;
|
---|
576 | $op->B::BINOP::bsave($ix);
|
---|
577 | asm "op_pmstash", $stashix;
|
---|
578 | }
|
---|
579 |
|
---|
580 | asm $rrop, $rrarg if $rrop;
|
---|
581 | asm "op_pmreplstart", $rstart if $rstart;
|
---|
582 |
|
---|
583 | asm "op_pmflags", $op->pmflags;
|
---|
584 | asm "op_pmpermflags", $op->pmpermflags;
|
---|
585 | asm "op_pmdynflags", $op->pmdynflags;
|
---|
586 | # asm "op_pmnext", $pmnextix; # XXX
|
---|
587 | asm "newpv", pvstring $op->precomp;
|
---|
588 | asm "pregcomp";
|
---|
589 | }
|
---|
590 |
|
---|
591 | sub B::SVOP::bsave {
|
---|
592 | my ($op,$ix) = @_;
|
---|
593 | my $svix = $op->sv->ix;
|
---|
594 |
|
---|
595 | $op->B::OP::bsave($ix);
|
---|
596 | asm "op_sv", $svix;
|
---|
597 | }
|
---|
598 |
|
---|
599 | sub B::PADOP::bsave {
|
---|
600 | my ($op,$ix) = @_;
|
---|
601 |
|
---|
602 | $op->B::OP::bsave($ix);
|
---|
603 | asm "op_padix", $op->padix;
|
---|
604 | }
|
---|
605 |
|
---|
606 | sub B::PVOP::bsave {
|
---|
607 | my ($op,$ix) = @_;
|
---|
608 | $op->B::OP::bsave($ix);
|
---|
609 | return unless my $pv = $op->pv;
|
---|
610 |
|
---|
611 | if ($op->name eq 'trans') {
|
---|
612 | asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
|
---|
613 | } else {
|
---|
614 | asm "newpv", pvstring $pv;
|
---|
615 | asm "op_pv";
|
---|
616 | }
|
---|
617 | }
|
---|
618 |
|
---|
619 | sub B::LOOP::bsave {
|
---|
620 | my ($op,$ix) = @_;
|
---|
621 | my $nextix = $op->nextop->ix;
|
---|
622 | my $lastix = $op->lastop->ix;
|
---|
623 | my $redoix = $op->redoop->ix;
|
---|
624 |
|
---|
625 | $op->B::BINOP::bsave($ix);
|
---|
626 | asm "op_redoop", $redoix;
|
---|
627 | asm "op_nextop", $nextix;
|
---|
628 | asm "op_lastop", $lastix;
|
---|
629 | }
|
---|
630 |
|
---|
631 | sub B::COP::bsave {
|
---|
632 | my ($cop,$ix) = @_;
|
---|
633 | my $warnix = $cop->warnings->ix;
|
---|
634 | my $ioix = $cop->io->ix;
|
---|
635 | if (ITHREADS) {
|
---|
636 | $cop->B::OP::bsave($ix);
|
---|
637 | asm "cop_stashpv", pvix $cop->stashpv;
|
---|
638 | asm "cop_file", pvix $cop->file;
|
---|
639 | } else {
|
---|
640 | my $stashix = $cop->stash->ix;
|
---|
641 | my $fileix = $cop->filegv->ix(1);
|
---|
642 | $cop->B::OP::bsave($ix);
|
---|
643 | asm "cop_stash", $stashix;
|
---|
644 | asm "cop_filegv", $fileix;
|
---|
645 | }
|
---|
646 | asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
|
---|
647 | asm "cop_seq", $cop->cop_seq;
|
---|
648 | asm "cop_arybase", $cop->arybase;
|
---|
649 | asm "cop_line", $cop->line;
|
---|
650 | asm "cop_warnings", $warnix;
|
---|
651 | asm "cop_io", $ioix;
|
---|
652 | }
|
---|
653 |
|
---|
654 | sub B::OP::opwalk {
|
---|
655 | my $op = shift;
|
---|
656 | my $ix = $optab{$$op};
|
---|
657 | defined($ix) ? $ix : do {
|
---|
658 | my $ix;
|
---|
659 | my @oplist = $op->oplist;
|
---|
660 | push @cloop, undef;
|
---|
661 | $ix = $_->ix while $_ = pop @oplist;
|
---|
662 | while ($_ = pop @cloop) {
|
---|
663 | asm "ldop", $optab{$$_};
|
---|
664 | asm "op_next", $optab{${$_->next}};
|
---|
665 | }
|
---|
666 | $ix;
|
---|
667 | }
|
---|
668 | }
|
---|
669 |
|
---|
670 | #################################################
|
---|
671 |
|
---|
672 | sub save_cq {
|
---|
673 | my $av;
|
---|
674 | if (($av=begin_av)->isa("B::AV")) {
|
---|
675 | if ($savebegins) {
|
---|
676 | for ($av->ARRAY) {
|
---|
677 | next unless $_->FILE eq $0;
|
---|
678 | asm "push_begin", $_->ix;
|
---|
679 | }
|
---|
680 | } else {
|
---|
681 | for ($av->ARRAY) {
|
---|
682 | next unless $_->FILE eq $0;
|
---|
683 | # XXX BEGIN { goto A while 1; A: }
|
---|
684 | for (my $op = $_->START; $$op; $op = $op->next) {
|
---|
685 | next unless $op->name eq 'require' ||
|
---|
686 | # this kludge needed for tests
|
---|
687 | $op->name eq 'gv' && do {
|
---|
688 | my $gv = class($op) eq 'SVOP' ?
|
---|
689 | $op->gv :
|
---|
690 | (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
|
---|
691 | $$gv && $gv->NAME =~ /use_ok|plan/
|
---|
692 | };
|
---|
693 | asm "push_begin", $_->ix;
|
---|
694 | last;
|
---|
695 | }
|
---|
696 | }
|
---|
697 | }
|
---|
698 | }
|
---|
699 | if (($av=init_av)->isa("B::AV")) {
|
---|
700 | for ($av->ARRAY) {
|
---|
701 | next unless $_->FILE eq $0;
|
---|
702 | asm "push_init", $_->ix;
|
---|
703 | }
|
---|
704 | }
|
---|
705 | if (($av=end_av)->isa("B::AV")) {
|
---|
706 | for ($av->ARRAY) {
|
---|
707 | next unless $_->FILE eq $0;
|
---|
708 | asm "push_end", $_->ix;
|
---|
709 | }
|
---|
710 | }
|
---|
711 | }
|
---|
712 |
|
---|
713 | sub compile {
|
---|
714 | my ($head, $scan, $T_inhinc, $keep_syn);
|
---|
715 | my $cwd = '';
|
---|
716 | $files{$0} = 1;
|
---|
717 | sub keep_syn {
|
---|
718 | $keep_syn = 1;
|
---|
719 | *B::OP::bsave = *B::OP::bsave_fat;
|
---|
720 | *B::UNOP::bsave = *B::UNOP::bsave_fat;
|
---|
721 | *B::BINOP::bsave = *B::BINOP::bsave_fat;
|
---|
722 | *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
|
---|
723 | }
|
---|
724 | sub bwarn { print STDERR "Bytecode.pm: @_\n" }
|
---|
725 |
|
---|
726 | for (@_) {
|
---|
727 | if (/^-S/) {
|
---|
728 | *newasm = *endasm = sub { };
|
---|
729 | *asm = sub { print " @_\n" };
|
---|
730 | *nice = sub ($) { print "\n@_\n" };
|
---|
731 | } elsif (/^-H/) {
|
---|
732 | require ByteLoader;
|
---|
733 | $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
|
---|
734 | } elsif (/^-k/) {
|
---|
735 | keep_syn;
|
---|
736 | } elsif (/^-o(.*)$/) {
|
---|
737 | open STDOUT, ">$1" or die "open $1: $!";
|
---|
738 | } elsif (/^-f(.*)$/) {
|
---|
739 | $files{$1} = 1;
|
---|
740 | } elsif (/^-s(.*)$/) {
|
---|
741 | $scan = length($1) ? $1 : $0;
|
---|
742 | } elsif (/^-b/) {
|
---|
743 | $savebegins = 1;
|
---|
744 | # this is here for the testsuite
|
---|
745 | } elsif (/^-TI/) {
|
---|
746 | $T_inhinc = 1;
|
---|
747 | } elsif (/^-TF(.*)/) {
|
---|
748 | my $thatfile = $1;
|
---|
749 | *B::COP::file = sub { $thatfile };
|
---|
750 | } else {
|
---|
751 | bwarn "Ignoring '$_' option";
|
---|
752 | }
|
---|
753 | }
|
---|
754 | if ($scan) {
|
---|
755 | my $f;
|
---|
756 | if (open $f, $scan) {
|
---|
757 | while (<$f>) {
|
---|
758 | /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
|
---|
759 | /^#/ and next;
|
---|
760 | if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
|
---|
761 | bwarn "keeping the syntax tree: \"goto\" op found";
|
---|
762 | keep_syn;
|
---|
763 | }
|
---|
764 | }
|
---|
765 | } else {
|
---|
766 | bwarn "cannot rescan '$scan'";
|
---|
767 | }
|
---|
768 | close $f;
|
---|
769 | }
|
---|
770 | binmode STDOUT;
|
---|
771 | return sub {
|
---|
772 | print $head if $head;
|
---|
773 | newasm sub { print @_ };
|
---|
774 |
|
---|
775 | defstash->bwalk;
|
---|
776 | asm "main_start", main_start->opwalk;
|
---|
777 | asm "main_root", main_root->ix;
|
---|
778 | asm "main_cv", main_cv->ix;
|
---|
779 | asm "curpad", (comppadlist->ARRAY)[1]->ix;
|
---|
780 |
|
---|
781 | asm "signal", cstring "__WARN__" # XXX
|
---|
782 | if warnhook->ix;
|
---|
783 | asm "incav", inc_gv->AV->ix if $T_inhinc;
|
---|
784 | save_cq;
|
---|
785 | asm "incav", inc_gv->AV->ix if $T_inhinc;
|
---|
786 | asm "dowarn", dowarn;
|
---|
787 |
|
---|
788 | {
|
---|
789 | no strict 'refs';
|
---|
790 | nice "<DATA>";
|
---|
791 | my $dh = *{defstash->NAME."::DATA"};
|
---|
792 | unless (eof $dh) {
|
---|
793 | local undef $/;
|
---|
794 | asm "data", ord 'D';
|
---|
795 | print <$dh>;
|
---|
796 | } else {
|
---|
797 | asm "ret";
|
---|
798 | }
|
---|
799 | }
|
---|
800 |
|
---|
801 | endasm;
|
---|
802 | }
|
---|
803 | }
|
---|
804 |
|
---|
805 | 1;
|
---|
806 |
|
---|
807 | =head1 NAME
|
---|
808 |
|
---|
809 | B::Bytecode - Perl compiler's bytecode backend
|
---|
810 |
|
---|
811 | =head1 SYNOPSIS
|
---|
812 |
|
---|
813 | B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
|
---|
814 |
|
---|
815 | =head1 DESCRIPTION
|
---|
816 |
|
---|
817 | Compiles a Perl script into a bytecode format that could be loaded
|
---|
818 | later by the ByteLoader module and executed as a regular Perl script.
|
---|
819 |
|
---|
820 | =head1 EXAMPLE
|
---|
821 |
|
---|
822 | $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
|
---|
823 | $ perl hi
|
---|
824 | hi!
|
---|
825 |
|
---|
826 | =head1 OPTIONS
|
---|
827 |
|
---|
828 | =over 4
|
---|
829 |
|
---|
830 | =item B<-b>
|
---|
831 |
|
---|
832 | Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
|
---|
833 | other files (ex. C<use Foo;>) are saved.
|
---|
834 |
|
---|
835 | =item B<-H>
|
---|
836 |
|
---|
837 | prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
|
---|
838 |
|
---|
839 | =item B<-k>
|
---|
840 |
|
---|
841 | keep the syntax tree - it is stripped by default.
|
---|
842 |
|
---|
843 | =item B<-o>I<outfile>
|
---|
844 |
|
---|
845 | put the bytecode in <outfile> instead of dumping it to STDOUT.
|
---|
846 |
|
---|
847 | =item B<-s>
|
---|
848 |
|
---|
849 | scan the script for C<# line ..> directives and for <goto LABEL>
|
---|
850 | expressions. When gotos are found keep the syntax tree.
|
---|
851 |
|
---|
852 | =back
|
---|
853 |
|
---|
854 | =head1 KNOWN BUGS
|
---|
855 |
|
---|
856 | =over 4
|
---|
857 |
|
---|
858 | =item *
|
---|
859 |
|
---|
860 | C<BEGIN { goto A: while 1; A: }> won't even compile.
|
---|
861 |
|
---|
862 | =item *
|
---|
863 |
|
---|
864 | C<?...?> and C<reset> do not work as expected.
|
---|
865 |
|
---|
866 | =item *
|
---|
867 |
|
---|
868 | variables in C<(?{ ... })> constructs are not properly scoped.
|
---|
869 |
|
---|
870 | =item *
|
---|
871 |
|
---|
872 | scripts that use source filters will fail miserably.
|
---|
873 |
|
---|
874 | =back
|
---|
875 |
|
---|
876 | =head1 NOTICE
|
---|
877 |
|
---|
878 | There are also undocumented bugs and options.
|
---|
879 |
|
---|
880 | THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
|
---|
881 |
|
---|
882 | =head1 AUTHORS
|
---|
883 |
|
---|
884 | Originally written by Malcolm Beattie <[email protected]> and
|
---|
885 | modified by Benjamin Stuhl <[email protected]>.
|
---|
886 |
|
---|
887 | Rewritten by Enache Adrian <[email protected]>, 2003 a.d.
|
---|
888 |
|
---|
889 | =cut
|
---|