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.
6 # Based on the original Bytecode.pm module written by Malcolm Beattie.
10 our $VERSION = '1.01';
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);
21 #################################################
23 my ($varix, $opix, $savebegins, %walked, %files, @cloop);
33 my $ithreads = $Config{'useithreads'} eq 'define';
35 sub ITHREADS() { $ithreads }
40 #################################################
44 defined($pv) ? cstring ($pv."\0") : "\"\"";
48 my $str = pvstring shift;
49 my $ix = $strtab{$str};
50 defined($ix) ? $ix : do {
52 asm "stpv", $strtab{$str} = $tix;
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++;
71 my $ix = $spectab{$$spec};
72 defined($ix) ? $ix : do {
73 nice '['.$specialsv_name[$$spec].']';
74 asm "ldspecsvx", $$spec;
75 $spectab{$$spec} = $varix = $tix++;
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++;
92 my ($gv,$desired) = @_;
93 my $ix = $svtab{$$gv};
94 defined($ix) ? $ix : do {
96 my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
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;
105 asm "gp_refcnt", $gv->GvREFCNT;
106 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
108 unless $desired || desired $gv;
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;
119 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
123 asm "ldsv", $varix = $ix unless $ix == $varix;
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";
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;
149 my $ix = $svtab{$$hv};
150 defined($ix) ? $ix : do {
152 my $name = $hv->NAME;
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
164 asm "newsvx", $hv->FLAGS;
165 $svtab{$$hv} = $varix = $ix = $tix++;
166 my $stashix = $hv->SvSTASH->ix;
167 for (@array = $hv->ARRAY) {
172 asm "ldsv", $varix = $ix unless $ix == $varix;
173 ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
175 asm "xmg_stash", $stashix;
176 asm "xhv_riter", $hv->RITER;
178 asm "sv_refcnt", $hv->REFCNT;
185 $$sv ? $sv->B::SV::ix : 0;
188 sub B::NULL::opwalk { 0 }
190 #################################################
195 nice '-'.class($sv).'-',
196 asm "ldsv", $varix = $ix unless $ix == $varix;
197 asm "sv_refcnt", $sv->REFCNT;
201 *B::SV::bsave = *B::NULL::bsave;
205 my $rvix = $sv->RV->ix;
206 $sv->B::NULL::bsave($ix);
212 $sv->B::NULL::bsave($ix);
213 asm "newpv", pvstring $sv->PVBM;
219 $sv->B::NULL::bsave($ix);
225 $sv->B::NULL::bsave($ix);
226 asm "xnv", sprintf "%.40g", $sv->NVX;
232 $sv->B::PV::bsave($ix):
234 $sv->B::RV::bsave($ix):
235 $sv->B::NULL::bsave($ix);
236 asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
237 "0 but true" : $sv->IVX;
242 $sv->B::PVIV::bsave($ix);
243 asm "xnv", sprintf "%.40g", $sv->NVX;
246 sub B::PVMG::domagic {
249 my @mglist = $sv->MAGIC;
252 push @mgix, $_->OBJ->ix;
253 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
256 nice '-'.class($sv).'-',
257 asm "ldsv", $varix = $ix unless $ix == $varix;
259 asm "sv_magic", cstring $_->TYPE;
260 asm "mg_obj", shift @mgix;
261 my $length = $_->LENGTH;
262 if ($length == B::HEf_SVKEY) {
263 asm "mg_namex", shift @namix;
265 asm "newpv", pvstring $_->PTR;
273 my $stashix = $sv->SvSTASH->ix;
274 $sv->B::PVNV::bsave($ix);
275 asm "xmg_stash", $stashix;
276 $sv->domagic($ix) if $sv->MAGICAL;
281 my $targix = $sv->TARG->ix;
282 $sv->B::PVMG::bsave($ix);
283 asm "xlv_targ", $targix;
284 asm "xlv_targoff", $sv->TARGOFF;
285 asm "xlv_targlen", $sv->TARGLEN;
286 asm "xlv_type", $sv->TYPE;
292 $sv->B::PVMG::bsave($ix);
293 asm "xpv_cur", $sv->CUR;
294 asm "xbm_useful", $sv->USEFUL;
295 asm "xbm_previous", $sv->PREVIOUS;
296 asm "xbm_rare", $sv->RARE;
301 my $topix = $io->TOP_GV->ix;
302 my $fmtix = $io->FMT_GV->ix;
303 my $bottomix = $io->BOTTOM_GV->ix;
304 $io->B::PVMG::bsave($ix);
305 asm "xio_lines", $io->LINES;
306 asm "xio_page", $io->PAGE;
307 asm "xio_page_len", $io->PAGE_LEN;
308 asm "xio_lines_left", $io->LINES_LEFT;
309 asm "xio_top_name", pvix $io->TOP_NAME;
310 asm "xio_top_gv", $topix;
311 asm "xio_fmt_name", pvix $io->FMT_NAME;
312 asm "xio_fmt_gv", $fmtix;
313 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
314 asm "xio_bottom_gv", $bottomix;
315 asm "xio_subprocess", $io->SUBPROCESS;
316 asm "xio_type", ord $io->IoTYPE;
317 # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
322 my $stashix = $cv->STASH->ix;
323 my $gvix = $cv->GV->ix;
324 my $padlistix = $cv->PADLIST->ix;
325 my $outsideix = $cv->OUTSIDE->ix;
326 my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
327 my $startix = $cv->START->opwalk;
328 my $rootix = $cv->ROOT->ix;
330 $cv->B::PVMG::bsave($ix);
331 asm "xcv_stash", $stashix;
332 asm "xcv_start", $startix;
333 asm "xcv_root", $rootix;
334 asm "xcv_xsubany", $constix;
336 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
337 asm "xcv_padlist", $padlistix;
338 asm "xcv_outside", $outsideix;
339 asm "xcv_flags", $cv->CvFLAGS;
340 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
341 asm "xcv_depth", $cv->DEPTH;
347 $form->B::CV::bsave($ix);
348 asm "xfm_lines", $form->LINES;
353 return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
354 my @array = $av->ARRAY;
355 $_ = $_->ix for @array;
356 my $stashix = $av->SvSTASH->ix;
359 asm "ldsv", $varix = $ix unless $ix == $varix;
360 asm "av_extend", $av->MAX if $av->MAX >= 0;
361 asm "av_pushx", $_ for @array;
362 asm "sv_refcnt", $av->REFCNT;
363 asm "xmg_stash", $stashix;
369 $files{$gv->FILE} && $gv->LINE
370 || ${$cv = $gv->CV} && $files{$cv->FILE}
371 || ${$form = $gv->FORM} && $files{$form->FILE}
376 return if $walked{$$hv}++;
377 my %stash = $hv->ARRAY;
378 while (my($k,$v) = each %stash) {
379 if ($v->SvTYPE == SVt_PVGV) {
381 if ($$hash && $hash->NAME) {
384 $v->ix(1) if desired $v;
387 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
388 $svtab{$$v} = $varix = $tix;
390 asm "sv_flags", $v->FLAGS;
395 ######################################################
398 sub B::OP::bsave_thin {
400 my $next = $op->next;
401 my $nextix = $optab{$$next};
402 $nextix = 0, push @cloop, $op unless defined $nextix;
404 nice '-'.$op->name.'-',
405 asm "ldop", $opix = $ix;
407 asm "op_next", $nextix;
408 asm "op_targ", $op->targ if $op->type; # tricky
409 asm "op_flags", $op->flags;
410 asm "op_private", $op->private;
414 *B::OP::bsave = *B::OP::bsave_thin;
418 my $name = $op->name;
419 my $flags = $op->flags;
420 my $first = $op->first;
424 || (!ITHREADS && $name eq 'regcomp')
425 # trick for /$a/o in pp_regcomp
427 && $op->flags & OPf_MOD
428 && $op->private & OPpLVAL_INTRO
429 # change #18774 made my life hard
433 $op->B::OP::bsave($ix);
434 asm "op_first", $firstix;
437 sub B::BINOP::bsave {
439 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
440 my $last = $op->last;
442 local *B::OP::bsave = *B::OP::bsave_fat;
443 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
446 asm "ldop", $lastix unless $lastix == $opix;
447 asm "op_targ", $last->targ;
448 $op->B::OP::bsave($ix);
449 asm "op_last", $lastix;
451 $op->B::OP::bsave($ix);
455 # not needed if no pseudohashes
457 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
459 # deal with sort / formline
461 sub B::LISTOP::bsave {
463 my $name = $op->name;
464 sub blocksort() { OPf_SPECIAL|OPf_STACKED }
465 if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
466 my $first = $op->first;
467 my $pushmark = $first->sibling;
468 my $rvgv = $pushmark->first;
469 my $leave = $rvgv->first;
471 my $leaveix = $leave->ix;
473 my $rvgvix = $rvgv->ix;
474 asm "ldop", $rvgvix unless $rvgvix == $opix;
475 asm "op_first", $leaveix;
477 my $pushmarkix = $pushmark->ix;
478 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
479 asm "op_first", $rvgvix;
481 my $firstix = $first->ix;
482 asm "ldop", $firstix unless $firstix == $opix;
483 asm "op_sibling", $pushmarkix;
485 $op->B::OP::bsave($ix);
486 asm "op_first", $firstix;
487 } elsif ($name eq 'formline') {
488 $op->B::UNOP::bsave_fat($ix);
490 $op->B::OP::bsave($ix);
496 sub B::OP::bsave_fat {
498 my $siblix = $op->sibling->ix;
500 $op->B::OP::bsave_thin($ix);
501 asm "op_sibling", $siblix;
502 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
505 sub B::UNOP::bsave_fat {
507 my $firstix = $op->first->ix;
509 $op->B::OP::bsave($ix);
510 asm "op_first", $firstix;
513 sub B::BINOP::bsave_fat {
515 my $last = $op->last;
516 my $lastix = $op->last->ix;
517 if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
518 asm "ldop", $lastix unless $lastix == $opix;
519 asm "op_targ", $last->targ;
522 $op->B::UNOP::bsave($ix);
523 asm "op_last", $lastix;
526 sub B::LOGOP::bsave {
528 my $otherix = $op->other->ix;
530 $op->B::UNOP::bsave($ix);
531 asm "op_other", $otherix;
536 my ($rrop, $rrarg, $rstart);
538 # my $pmnextix = $op->pmnext->ix; # XXX
541 if ($op->name eq 'subst') {
542 $rrop = "op_pmreplroot";
543 $rrarg = $op->pmreplroot->ix;
544 $rstart = $op->pmreplstart->ix;
545 } elsif ($op->name eq 'pushre') {
546 $rrop = "op_pmreplrootpo";
547 $rrarg = $op->pmreplroot;
549 $op->B::BINOP::bsave($ix);
550 asm "op_pmstashpv", pvix $op->pmstashpv;
552 $rrop = "op_pmreplrootgv";
553 $rrarg = $op->pmreplroot->ix;
554 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
555 my $stashix = $op->pmstash->ix;
556 $op->B::BINOP::bsave($ix);
557 asm "op_pmstash", $stashix;
560 asm $rrop, $rrarg if $rrop;
561 asm "op_pmreplstart", $rstart if $rstart;
563 asm "op_pmflags", $op->pmflags;
564 asm "op_pmpermflags", $op->pmpermflags;
565 asm "op_pmdynflags", $op->pmdynflags;
566 # asm "op_pmnext", $pmnextix; # XXX
567 asm "newpv", pvstring $op->precomp;
573 my $svix = $op->sv->ix;
575 $op->B::OP::bsave($ix);
579 sub B::PADOP::bsave {
582 $op->B::OP::bsave($ix);
583 asm "op_padix", $op->padix;
588 $op->B::OP::bsave($ix);
589 return unless my $pv = $op->pv;
591 if ($op->name eq 'trans') {
592 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
594 asm "newpv", pvstring $pv;
601 my $nextix = $op->nextop->ix;
602 my $lastix = $op->lastop->ix;
603 my $redoix = $op->redoop->ix;
605 $op->B::BINOP::bsave($ix);
606 asm "op_redoop", $redoix;
607 asm "op_nextop", $nextix;
608 asm "op_lastop", $lastix;
613 my $warnix = $cop->warnings->ix;
614 my $ioix = $cop->io->ix;
616 $cop->B::OP::bsave($ix);
617 asm "cop_stashpv", pvix $cop->stashpv;
618 asm "cop_file", pvix $cop->file;
620 my $stashix = $cop->stash->ix;
621 my $fileix = $cop->filegv->ix(1);
622 $cop->B::OP::bsave($ix);
623 asm "cop_stash", $stashix;
624 asm "cop_filegv", $fileix;
626 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
627 asm "cop_seq", $cop->cop_seq;
628 asm "cop_arybase", $cop->arybase;
629 asm "cop_line", $cop->line;
630 asm "cop_warnings", $warnix;
636 my $ix = $optab{$$op};
637 defined($ix) ? $ix : do {
639 my @oplist = $op->oplist;
641 $ix = $_->ix while $_ = pop @oplist;
642 while ($_ = pop @cloop) {
643 asm "ldop", $optab{$$_};
644 asm "op_next", $optab{${$_->next}};
650 #################################################
654 if (($av=begin_av)->isa("B::AV")) {
657 next unless $_->FILE eq $0;
658 asm "push_begin", $_->ix;
662 next unless $_->FILE eq $0;
663 # XXX BEGIN { goto A while 1; A: }
664 for (my $op = $_->START; $$op; $op = $op->next) {
665 next unless $op->name eq 'require' ||
666 # this kludge needed for tests
667 $op->name eq 'gv' && do {
668 my $gv = class($op) eq 'SVOP' ?
670 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
671 $$gv && $gv->NAME =~ /use_ok|plan/
673 asm "push_begin", $_->ix;
679 if (($av=init_av)->isa("B::AV")) {
681 next unless $_->FILE eq $0;
682 asm "push_init", $_->ix;
685 if (($av=end_av)->isa("B::AV")) {
687 next unless $_->FILE eq $0;
688 asm "push_end", $_->ix;
694 my ($head, $scan, $T_inhinc, $keep_syn);
699 *B::OP::bsave = *B::OP::bsave_fat;
700 *B::UNOP::bsave = *B::UNOP::bsave_fat;
701 *B::BINOP::bsave = *B::BINOP::bsave_fat;
702 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
704 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
708 *newasm = *endasm = sub { };
709 *asm = sub { print " @_\n" };
710 *nice = sub ($) { print "\n@_\n" };
713 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
716 } elsif (/^-o(.*)$/) {
717 open STDOUT, ">$1" or die "open $1: $!";
718 } elsif (/^-f(.*)$/) {
720 } elsif (/^-s(.*)$/) {
721 $scan = length($1) ? $1 : $0;
724 # this is here for the testsuite
727 } elsif (/^-TF(.*)/) {
729 *B::COP::file = sub { $thatfile };
731 bwarn "Ignoring '$_' option";
736 if (open $f, $scan) {
738 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
740 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
741 bwarn "keeping the syntax tree: \"goto\" op found";
746 bwarn "cannot rescan '$scan'";
752 print $head if $head;
753 newasm sub { print @_ };
756 asm "main_start", main_start->opwalk;
757 asm "main_root", main_root->ix;
758 asm "main_cv", main_cv->ix;
759 asm "curpad", (comppadlist->ARRAY)[1]->ix;
761 asm "signal", cstring "__WARN__" # XXX
763 asm "incav", inc_gv->AV->ix if $T_inhinc;
765 asm "incav", inc_gv->AV->ix if $T_inhinc;
766 asm "dowarn", dowarn;
771 my $dh = *{defstash->NAME."::DATA"};
789 B::Bytecode - Perl compiler's bytecode backend
793 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
797 Compiles a Perl script into a bytecode format that could be loaded
798 later by the ByteLoader module and executed as a regular Perl script.
802 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
812 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
813 other files (ex. C<use Foo;>) are saved.
817 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
821 keep the syntax tree - it is stripped by default.
823 =item B<-o>I<outfile>
825 put the bytecode in <outfile> instead of dumping it to STDOUT.
829 scan the script for C<# line ..> directives and for <goto LABEL>
830 expressions. When gotos are found keep the syntax tree.
840 C<BEGIN { goto A: while 1; A: }> won't even compile.
844 C<?...?> and C<reset> do not work as expected.
848 variables in C<(?{ ... })> constructs are not properly scoped.
852 scripts that use source filters will fail miserably.
858 There are also undocumented bugs and options.
860 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
864 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
865 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
867 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.