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