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", $_)
176 asm "xmg_stash", $stashix;
177 asm "xhv_riter", $hv->RITER;
179 asm "sv_refcnt", $hv->REFCNT;
186 $$sv ? $sv->B::SV::ix : 0;
189 sub B::NULL::opwalk { 0 }
191 #################################################
196 nice '-'.class($sv).'-',
197 asm "ldsv", $varix = $ix unless $ix == $varix;
198 asm "sv_refcnt", $sv->REFCNT;
202 *B::SV::bsave = *B::NULL::bsave;
206 my $rvix = $sv->RV->ix;
207 $sv->B::NULL::bsave($ix);
213 $sv->B::NULL::bsave($ix);
214 asm "newpv", pvstring $sv->PVBM;
220 $sv->B::NULL::bsave($ix);
226 $sv->B::NULL::bsave($ix);
227 asm "xnv", sprintf "%.40g", $sv->NVX;
233 $sv->B::PV::bsave($ix):
235 $sv->B::RV::bsave($ix):
236 $sv->B::NULL::bsave($ix);
237 asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
238 "0 but true" : $sv->IVX;
243 $sv->B::PVIV::bsave($ix);
244 asm "xnv", sprintf "%.40g", $sv->NVX;
247 sub B::PVMG::domagic {
250 my @mglist = $sv->MAGIC;
253 push @mgix, $_->OBJ->ix;
254 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
257 nice '-'.class($sv).'-',
258 asm "ldsv", $varix = $ix unless $ix == $varix;
260 asm "sv_magic", cstring $_->TYPE;
261 asm "mg_obj", shift @mgix;
262 my $length = $_->LENGTH;
263 if ($length == B::HEf_SVKEY) {
264 asm "mg_namex", shift @namix;
266 asm "newpv", pvstring $_->PTR;
274 my $stashix = $sv->SvSTASH->ix;
275 $sv->B::PVNV::bsave($ix);
276 asm "xmg_stash", $stashix;
277 $sv->domagic($ix) if $sv->MAGICAL;
282 my $targix = $sv->TARG->ix;
283 $sv->B::PVMG::bsave($ix);
284 asm "xlv_targ", $targix;
285 asm "xlv_targoff", $sv->TARGOFF;
286 asm "xlv_targlen", $sv->TARGLEN;
287 asm "xlv_type", $sv->TYPE;
293 $sv->B::PVMG::bsave($ix);
294 asm "xpv_cur", $sv->CUR;
295 asm "xbm_useful", $sv->USEFUL;
296 asm "xbm_previous", $sv->PREVIOUS;
297 asm "xbm_rare", $sv->RARE;
302 my $topix = $io->TOP_GV->ix;
303 my $fmtix = $io->FMT_GV->ix;
304 my $bottomix = $io->BOTTOM_GV->ix;
305 $io->B::PVMG::bsave($ix);
306 asm "xio_lines", $io->LINES;
307 asm "xio_page", $io->PAGE;
308 asm "xio_page_len", $io->PAGE_LEN;
309 asm "xio_lines_left", $io->LINES_LEFT;
310 asm "xio_top_name", pvix $io->TOP_NAME;
311 asm "xio_top_gv", $topix;
312 asm "xio_fmt_name", pvix $io->FMT_NAME;
313 asm "xio_fmt_gv", $fmtix;
314 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
315 asm "xio_bottom_gv", $bottomix;
316 asm "xio_subprocess", $io->SUBPROCESS;
317 asm "xio_type", ord $io->IoTYPE;
318 # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
323 my $stashix = $cv->STASH->ix;
324 my $gvix = $cv->GV->ix;
325 my $padlistix = $cv->PADLIST->ix;
326 my $outsideix = $cv->OUTSIDE->ix;
327 my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
328 my $startix = $cv->START->opwalk;
329 my $rootix = $cv->ROOT->ix;
331 $cv->B::PVMG::bsave($ix);
332 asm "xcv_stash", $stashix;
333 asm "xcv_start", $startix;
334 asm "xcv_root", $rootix;
335 asm "xcv_xsubany", $constix;
337 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
338 asm "xcv_padlist", $padlistix;
339 asm "xcv_outside", $outsideix;
340 asm "xcv_flags", $cv->CvFLAGS;
341 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
342 asm "xcv_depth", $cv->DEPTH;
348 $form->B::CV::bsave($ix);
349 asm "xfm_lines", $form->LINES;
354 return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
355 my @array = $av->ARRAY;
356 $_ = $_->ix for @array;
357 my $stashix = $av->SvSTASH->ix;
360 asm "ldsv", $varix = $ix unless $ix == $varix;
361 asm "av_extend", $av->MAX if $av->MAX >= 0;
362 asm "av_pushx", $_ for @array;
363 asm "sv_refcnt", $av->REFCNT;
364 asm "xmg_stash", $stashix;
370 $files{$gv->FILE} && $gv->LINE
371 || ${$cv = $gv->CV} && $files{$cv->FILE}
372 || ${$form = $gv->FORM} && $files{$form->FILE}
377 return if $walked{$$hv}++;
378 my %stash = $hv->ARRAY;
379 while (my($k,$v) = each %stash) {
380 if ($v->SvTYPE == SVt_PVGV) {
382 if ($$hash && $hash->NAME) {
385 $v->ix(1) if desired $v;
388 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
389 $svtab{$$v} = $varix = $tix;
391 asm "sv_flags", $v->FLAGS;
396 ######################################################
399 sub B::OP::bsave_thin {
401 my $next = $op->next;
402 my $nextix = $optab{$$next};
403 $nextix = 0, push @cloop, $op unless defined $nextix;
405 nice '-'.$op->name.'-',
406 asm "ldop", $opix = $ix;
408 asm "op_next", $nextix;
409 asm "op_targ", $op->targ if $op->type; # tricky
410 asm "op_flags", $op->flags;
411 asm "op_private", $op->private;
415 *B::OP::bsave = *B::OP::bsave_thin;
419 my $name = $op->name;
420 my $flags = $op->flags;
421 my $first = $op->first;
425 || (!ITHREADS && $name eq 'regcomp')
426 # trick for /$a/o in pp_regcomp
428 && $op->flags & OPf_MOD
429 && $op->private & OPpLVAL_INTRO
430 # change #18774 made my life hard
434 $op->B::OP::bsave($ix);
435 asm "op_first", $firstix;
438 sub B::BINOP::bsave {
440 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
441 my $last = $op->last;
443 local *B::OP::bsave = *B::OP::bsave_fat;
444 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
447 asm "ldop", $lastix unless $lastix == $opix;
448 asm "op_targ", $last->targ;
449 $op->B::OP::bsave($ix);
450 asm "op_last", $lastix;
452 $op->B::OP::bsave($ix);
456 # not needed if no pseudohashes
458 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
460 # deal with sort / formline
462 sub B::LISTOP::bsave {
464 my $name = $op->name;
465 sub blocksort() { OPf_SPECIAL|OPf_STACKED }
466 if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
467 my $first = $op->first;
468 my $pushmark = $first->sibling;
469 my $rvgv = $pushmark->first;
470 my $leave = $rvgv->first;
472 my $leaveix = $leave->ix;
474 my $rvgvix = $rvgv->ix;
475 asm "ldop", $rvgvix unless $rvgvix == $opix;
476 asm "op_first", $leaveix;
478 my $pushmarkix = $pushmark->ix;
479 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
480 asm "op_first", $rvgvix;
482 my $firstix = $first->ix;
483 asm "ldop", $firstix unless $firstix == $opix;
484 asm "op_sibling", $pushmarkix;
486 $op->B::OP::bsave($ix);
487 asm "op_first", $firstix;
488 } elsif ($name eq 'formline') {
489 $op->B::UNOP::bsave_fat($ix);
491 $op->B::OP::bsave($ix);
497 sub B::OP::bsave_fat {
499 my $siblix = $op->sibling->ix;
501 $op->B::OP::bsave_thin($ix);
502 asm "op_sibling", $siblix;
503 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
506 sub B::UNOP::bsave_fat {
508 my $firstix = $op->first->ix;
510 $op->B::OP::bsave($ix);
511 asm "op_first", $firstix;
514 sub B::BINOP::bsave_fat {
516 my $last = $op->last;
517 my $lastix = $op->last->ix;
518 if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
519 asm "ldop", $lastix unless $lastix == $opix;
520 asm "op_targ", $last->targ;
523 $op->B::UNOP::bsave($ix);
524 asm "op_last", $lastix;
527 sub B::LOGOP::bsave {
529 my $otherix = $op->other->ix;
531 $op->B::UNOP::bsave($ix);
532 asm "op_other", $otherix;
537 my ($rrop, $rrarg, $rstart);
539 # my $pmnextix = $op->pmnext->ix; # XXX
542 if ($op->name eq 'subst') {
543 $rrop = "op_pmreplroot";
544 $rrarg = $op->pmreplroot->ix;
545 $rstart = $op->pmreplstart->ix;
546 } elsif ($op->name eq 'pushre') {
547 $rrop = "op_pmreplrootpo";
548 $rrarg = $op->pmreplroot;
550 $op->B::BINOP::bsave($ix);
551 asm "op_pmstashpv", pvix $op->pmstashpv;
553 $rrop = "op_pmreplrootgv";
554 $rrarg = $op->pmreplroot->ix;
555 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
556 my $stashix = $op->pmstash->ix;
557 $op->B::BINOP::bsave($ix);
558 asm "op_pmstash", $stashix;
561 asm $rrop, $rrarg if $rrop;
562 asm "op_pmreplstart", $rstart if $rstart;
564 asm "op_pmflags", $op->pmflags;
565 asm "op_pmpermflags", $op->pmpermflags;
566 asm "op_pmdynflags", $op->pmdynflags;
567 # asm "op_pmnext", $pmnextix; # XXX
568 asm "newpv", pvstring $op->precomp;
574 my $svix = $op->sv->ix;
576 $op->B::OP::bsave($ix);
580 sub B::PADOP::bsave {
583 $op->B::OP::bsave($ix);
584 asm "op_padix", $op->padix;
589 $op->B::OP::bsave($ix);
590 return unless my $pv = $op->pv;
592 if ($op->name eq 'trans') {
593 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
595 asm "newpv", pvstring $pv;
602 my $nextix = $op->nextop->ix;
603 my $lastix = $op->lastop->ix;
604 my $redoix = $op->redoop->ix;
606 $op->B::BINOP::bsave($ix);
607 asm "op_redoop", $redoix;
608 asm "op_nextop", $nextix;
609 asm "op_lastop", $lastix;
614 my $warnix = $cop->warnings->ix;
615 my $ioix = $cop->io->ix;
617 $cop->B::OP::bsave($ix);
618 asm "cop_stashpv", pvix $cop->stashpv;
619 asm "cop_file", pvix $cop->file;
621 my $stashix = $cop->stash->ix;
622 my $fileix = $cop->filegv->ix(1);
623 $cop->B::OP::bsave($ix);
624 asm "cop_stash", $stashix;
625 asm "cop_filegv", $fileix;
627 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
628 asm "cop_seq", $cop->cop_seq;
629 asm "cop_arybase", $cop->arybase;
630 asm "cop_line", $cop->line;
631 asm "cop_warnings", $warnix;
637 my $ix = $optab{$$op};
638 defined($ix) ? $ix : do {
640 my @oplist = $op->oplist;
642 $ix = $_->ix while $_ = pop @oplist;
643 while ($_ = pop @cloop) {
644 asm "ldop", $optab{$$_};
645 asm "op_next", $optab{${$_->next}};
651 #################################################
655 if (($av=begin_av)->isa("B::AV")) {
658 next unless $_->FILE eq $0;
659 asm "push_begin", $_->ix;
663 next unless $_->FILE eq $0;
664 # XXX BEGIN { goto A while 1; A: }
665 for (my $op = $_->START; $$op; $op = $op->next) {
666 next unless $op->name eq 'require' ||
667 # this kludge needed for tests
668 $op->name eq 'gv' && do {
669 my $gv = class($op) eq 'SVOP' ?
671 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
672 $$gv && $gv->NAME =~ /use_ok|plan/
674 asm "push_begin", $_->ix;
680 if (($av=init_av)->isa("B::AV")) {
682 next unless $_->FILE eq $0;
683 asm "push_init", $_->ix;
686 if (($av=end_av)->isa("B::AV")) {
688 next unless $_->FILE eq $0;
689 asm "push_end", $_->ix;
695 my ($head, $scan, $T_inhinc, $keep_syn);
700 *B::OP::bsave = *B::OP::bsave_fat;
701 *B::UNOP::bsave = *B::UNOP::bsave_fat;
702 *B::BINOP::bsave = *B::BINOP::bsave_fat;
703 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
705 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
709 *newasm = *endasm = sub { };
710 *asm = sub { print " @_\n" };
711 *nice = sub ($) { print "\n@_\n" };
714 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
717 } elsif (/^-o(.*)$/) {
718 open STDOUT, ">$1" or die "open $1: $!";
719 } elsif (/^-f(.*)$/) {
721 } elsif (/^-s(.*)$/) {
722 $scan = length($1) ? $1 : $0;
725 # this is here for the testsuite
728 } elsif (/^-TF(.*)/) {
730 *B::COP::file = sub { $thatfile };
732 bwarn "Ignoring '$_' option";
737 if (open $f, $scan) {
739 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
741 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
742 bwarn "keeping the syntax tree: \"goto\" op found";
747 bwarn "cannot rescan '$scan'";
753 print $head if $head;
754 newasm sub { print @_ };
757 asm "main_start", main_start->opwalk;
758 asm "main_root", main_root->ix;
759 asm "main_cv", main_cv->ix;
760 asm "curpad", (comppadlist->ARRAY)[1]->ix;
762 asm "signal", cstring "__WARN__" # XXX
764 asm "incav", inc_gv->AV->ix if $T_inhinc;
766 asm "incav", inc_gv->AV->ix if $T_inhinc;
767 asm "dowarn", dowarn;
772 my $dh = *{defstash->NAME."::DATA"};
790 B::Bytecode - Perl compiler's bytecode backend
794 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
798 Compiles a Perl script into a bytecode format that could be loaded
799 later by the ByteLoader module and executed as a regular Perl script.
803 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
813 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
814 other files (ex. C<use Foo;>) are saved.
818 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
822 keep the syntax tree - it is stripped by default.
824 =item B<-o>I<outfile>
826 put the bytecode in <outfile> instead of dumping it to STDOUT.
830 scan the script for C<# line ..> directives and for <goto LABEL>
831 expressions. When gotos are found keep the syntax tree.
841 C<BEGIN { goto A: while 1; A: }> won't even compile.
845 C<?...?> and C<reset> do not work as expected.
849 variables in C<(?{ ... })> constructs are not properly scoped.
853 scripts that use source filters will fail miserably.
859 There are also undocumented bugs and options.
861 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
865 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
866 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
868 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.