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.02';
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 if (VERSION < 5.009) {
178 asm "xmg_stash", $stashix;
179 asm "xhv_riter", $hv->RITER;
181 asm "sv_refcnt", $hv->REFCNT;
188 $$sv ? $sv->B::SV::ix : 0;
191 sub B::NULL::opwalk { 0 }
193 #################################################
198 nice '-'.class($sv).'-',
199 asm "ldsv", $varix = $ix unless $ix == $varix;
200 asm "sv_refcnt", $sv->REFCNT;
204 *B::SV::bsave = *B::NULL::bsave;
208 my $rvix = $sv->RV->ix;
209 $sv->B::NULL::bsave($ix);
215 $sv->B::NULL::bsave($ix);
216 asm "newpv", pvstring $sv->PVBM;
222 $sv->B::NULL::bsave($ix);
228 $sv->B::NULL::bsave($ix);
229 asm "xnv", sprintf "%.40g", $sv->NVX;
235 $sv->B::PV::bsave($ix):
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 return if $sv->isa('B::CV');
245 asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
246 "0 but true" : $sv->IVX;
251 $sv->B::PVIV::bsave($ix);
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 return if $sv->isa('B::CV');
261 return if $sv->isa('B::FM');
263 asm "xnv", sprintf "%.40g", $sv->NVX;
266 sub B::PVMG::domagic {
269 my @mglist = $sv->MAGIC;
272 push @mgix, $_->OBJ->ix;
273 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
276 nice '-'.class($sv).'-',
277 asm "ldsv", $varix = $ix unless $ix == $varix;
279 asm "sv_magic", cstring $_->TYPE;
280 asm "mg_obj", shift @mgix;
281 my $length = $_->LENGTH;
282 if ($length == B::HEf_SVKEY) {
283 asm "mg_namex", shift @namix;
285 asm "newpv", pvstring $_->PTR;
293 my $stashix = $sv->SvSTASH->ix;
294 $sv->B::PVNV::bsave($ix);
295 asm "xmg_stash", $stashix;
296 $sv->domagic($ix) if $sv->MAGICAL;
301 my $targix = $sv->TARG->ix;
302 $sv->B::PVMG::bsave($ix);
303 asm "xlv_targ", $targix;
304 asm "xlv_targoff", $sv->TARGOFF;
305 asm "xlv_targlen", $sv->TARGLEN;
306 asm "xlv_type", $sv->TYPE;
312 $sv->B::PVMG::bsave($ix);
313 asm "xpv_cur", $sv->CUR;
314 asm "xbm_useful", $sv->USEFUL;
315 asm "xbm_previous", $sv->PREVIOUS;
316 asm "xbm_rare", $sv->RARE;
321 my $topix = $io->TOP_GV->ix;
322 my $fmtix = $io->FMT_GV->ix;
323 my $bottomix = $io->BOTTOM_GV->ix;
324 $io->B::PVMG::bsave($ix);
325 asm "xio_lines", $io->LINES;
326 asm "xio_page", $io->PAGE;
327 asm "xio_page_len", $io->PAGE_LEN;
328 asm "xio_lines_left", $io->LINES_LEFT;
329 asm "xio_top_name", pvix $io->TOP_NAME;
330 asm "xio_top_gv", $topix;
331 asm "xio_fmt_name", pvix $io->FMT_NAME;
332 asm "xio_fmt_gv", $fmtix;
333 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
334 asm "xio_bottom_gv", $bottomix;
335 asm "xio_subprocess", $io->SUBPROCESS;
336 asm "xio_type", ord $io->IoTYPE;
337 # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
342 my $stashix = $cv->STASH->ix;
343 my $gvix = $cv->GV->ix;
344 my $padlistix = $cv->PADLIST->ix;
345 my $outsideix = $cv->OUTSIDE->ix;
346 my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
347 my $startix = $cv->START->opwalk;
348 my $rootix = $cv->ROOT->ix;
350 $cv->B::PVMG::bsave($ix);
351 asm "xcv_stash", $stashix;
352 asm "xcv_start", $startix;
353 asm "xcv_root", $rootix;
354 asm "xcv_xsubany", $constix;
356 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
357 asm "xcv_padlist", $padlistix;
358 asm "xcv_outside", $outsideix;
359 asm "xcv_flags", $cv->CvFLAGS;
360 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
361 asm "xcv_depth", $cv->DEPTH;
367 $form->B::CV::bsave($ix);
368 asm "xfm_lines", $form->LINES;
373 return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
374 my @array = $av->ARRAY;
375 $_ = $_->ix for @array;
376 my $stashix = $av->SvSTASH->ix;
379 asm "ldsv", $varix = $ix unless $ix == $varix;
380 asm "av_extend", $av->MAX if $av->MAX >= 0;
381 asm "av_pushx", $_ for @array;
382 asm "sv_refcnt", $av->REFCNT;
383 if (VERSION < 5.009) {
384 asm "xav_flags", $av->AvFLAGS;
386 asm "xmg_stash", $stashix;
392 $files{$gv->FILE} && $gv->LINE
393 || ${$cv = $gv->CV} && $files{$cv->FILE}
394 || ${$form = $gv->FORM} && $files{$form->FILE}
399 return if $walked{$$hv}++;
400 my %stash = $hv->ARRAY;
401 while (my($k,$v) = each %stash) {
402 if ($v->SvTYPE == SVt_PVGV) {
404 if ($$hash && $hash->NAME) {
407 $v->ix(1) if desired $v;
410 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
411 $svtab{$$v} = $varix = $tix;
413 asm "sv_flags", $v->FLAGS;
418 ######################################################
421 sub B::OP::bsave_thin {
423 my $next = $op->next;
424 my $nextix = $optab{$$next};
425 $nextix = 0, push @cloop, $op unless defined $nextix;
427 nice '-'.$op->name.'-',
428 asm "ldop", $opix = $ix;
430 asm "op_next", $nextix;
431 asm "op_targ", $op->targ if $op->type; # tricky
432 asm "op_flags", $op->flags;
433 asm "op_private", $op->private;
437 *B::OP::bsave = *B::OP::bsave_thin;
441 my $name = $op->name;
442 my $flags = $op->flags;
443 my $first = $op->first;
447 || (!ITHREADS && $name eq 'regcomp')
448 # trick for /$a/o in pp_regcomp
450 && $op->flags & OPf_MOD
451 && $op->private & OPpLVAL_INTRO
452 # change #18774 made my life hard
456 $op->B::OP::bsave($ix);
457 asm "op_first", $firstix;
460 sub B::BINOP::bsave {
462 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
463 my $last = $op->last;
465 local *B::OP::bsave = *B::OP::bsave_fat;
466 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
469 asm "ldop", $lastix unless $lastix == $opix;
470 asm "op_targ", $last->targ;
471 $op->B::OP::bsave($ix);
472 asm "op_last", $lastix;
474 $op->B::OP::bsave($ix);
478 # not needed if no pseudohashes
480 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
482 # deal with sort / formline
484 sub B::LISTOP::bsave {
486 my $name = $op->name;
487 sub blocksort() { OPf_SPECIAL|OPf_STACKED }
488 if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
489 my $first = $op->first;
490 my $pushmark = $first->sibling;
491 my $rvgv = $pushmark->first;
492 my $leave = $rvgv->first;
494 my $leaveix = $leave->ix;
496 my $rvgvix = $rvgv->ix;
497 asm "ldop", $rvgvix unless $rvgvix == $opix;
498 asm "op_first", $leaveix;
500 my $pushmarkix = $pushmark->ix;
501 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
502 asm "op_first", $rvgvix;
504 my $firstix = $first->ix;
505 asm "ldop", $firstix unless $firstix == $opix;
506 asm "op_sibling", $pushmarkix;
508 $op->B::OP::bsave($ix);
509 asm "op_first", $firstix;
510 } elsif ($name eq 'formline') {
511 $op->B::UNOP::bsave_fat($ix);
513 $op->B::OP::bsave($ix);
519 sub B::OP::bsave_fat {
521 my $siblix = $op->sibling->ix;
523 $op->B::OP::bsave_thin($ix);
524 asm "op_sibling", $siblix;
525 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
528 sub B::UNOP::bsave_fat {
530 my $firstix = $op->first->ix;
532 $op->B::OP::bsave($ix);
533 asm "op_first", $firstix;
536 sub B::BINOP::bsave_fat {
538 my $last = $op->last;
539 my $lastix = $op->last->ix;
540 if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
541 asm "ldop", $lastix unless $lastix == $opix;
542 asm "op_targ", $last->targ;
545 $op->B::UNOP::bsave($ix);
546 asm "op_last", $lastix;
549 sub B::LOGOP::bsave {
551 my $otherix = $op->other->ix;
553 $op->B::UNOP::bsave($ix);
554 asm "op_other", $otherix;
559 my ($rrop, $rrarg, $rstart);
561 # my $pmnextix = $op->pmnext->ix; # XXX
564 if ($op->name eq 'subst') {
565 $rrop = "op_pmreplroot";
566 $rrarg = $op->pmreplroot->ix;
567 $rstart = $op->pmreplstart->ix;
568 } elsif ($op->name eq 'pushre') {
569 $rrop = "op_pmreplrootpo";
570 $rrarg = $op->pmreplroot;
572 $op->B::BINOP::bsave($ix);
573 asm "op_pmstashpv", pvix $op->pmstashpv;
575 $rrop = "op_pmreplrootgv";
576 $rrarg = $op->pmreplroot->ix;
577 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
578 my $stashix = $op->pmstash->ix;
579 $op->B::BINOP::bsave($ix);
580 asm "op_pmstash", $stashix;
583 asm $rrop, $rrarg if $rrop;
584 asm "op_pmreplstart", $rstart if $rstart;
586 asm "op_pmflags", $op->pmflags;
587 asm "op_pmpermflags", $op->pmpermflags;
588 asm "op_pmdynflags", $op->pmdynflags;
589 # asm "op_pmnext", $pmnextix; # XXX
590 asm "newpv", pvstring $op->precomp;
596 my $svix = $op->sv->ix;
598 $op->B::OP::bsave($ix);
602 sub B::PADOP::bsave {
605 $op->B::OP::bsave($ix);
606 asm "op_padix", $op->padix;
611 $op->B::OP::bsave($ix);
612 return unless my $pv = $op->pv;
614 if ($op->name eq 'trans') {
615 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
617 asm "newpv", pvstring $pv;
624 my $nextix = $op->nextop->ix;
625 my $lastix = $op->lastop->ix;
626 my $redoix = $op->redoop->ix;
628 $op->B::BINOP::bsave($ix);
629 asm "op_redoop", $redoix;
630 asm "op_nextop", $nextix;
631 asm "op_lastop", $lastix;
636 my $warnix = $cop->warnings->ix;
638 $cop->B::OP::bsave($ix);
639 asm "cop_stashpv", pvix $cop->stashpv;
640 asm "cop_file", pvix $cop->file;
642 my $stashix = $cop->stash->ix;
643 my $fileix = $cop->filegv->ix(1);
644 $cop->B::OP::bsave($ix);
645 asm "cop_stash", $stashix;
646 asm "cop_filegv", $fileix;
648 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
649 asm "cop_seq", $cop->cop_seq;
650 asm "cop_arybase", $cop->arybase;
651 asm "cop_line", $cop->line;
652 asm "cop_warnings", $warnix;
657 my $ix = $optab{$$op};
658 defined($ix) ? $ix : do {
660 my @oplist = $op->oplist;
662 $ix = $_->ix while $_ = pop @oplist;
663 while ($_ = pop @cloop) {
664 asm "ldop", $optab{$$_};
665 asm "op_next", $optab{${$_->next}};
671 #################################################
675 if (($av=begin_av)->isa("B::AV")) {
678 next unless $_->FILE eq $0;
679 asm "push_begin", $_->ix;
683 next unless $_->FILE eq $0;
684 # XXX BEGIN { goto A while 1; A: }
685 for (my $op = $_->START; $$op; $op = $op->next) {
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' ?
691 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
692 $$gv && $gv->NAME =~ /use_ok|plan/
694 asm "push_begin", $_->ix;
700 if (($av=init_av)->isa("B::AV")) {
702 next unless $_->FILE eq $0;
703 asm "push_init", $_->ix;
706 if (($av=end_av)->isa("B::AV")) {
708 next unless $_->FILE eq $0;
709 asm "push_end", $_->ix;
715 my ($head, $scan, $T_inhinc, $keep_syn);
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;
725 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
729 *newasm = *endasm = sub { };
730 *asm = sub { print " @_\n" };
731 *nice = sub ($) { print "\n@_\n" };
734 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
737 } elsif (/^-o(.*)$/) {
738 open STDOUT, ">$1" or die "open $1: $!";
739 } elsif (/^-f(.*)$/) {
741 } elsif (/^-s(.*)$/) {
742 $scan = length($1) ? $1 : $0;
745 # this is here for the testsuite
748 } elsif (/^-TF(.*)/) {
750 *B::COP::file = sub { $thatfile };
752 bwarn "Ignoring '$_' option";
757 if (open $f, $scan) {
759 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
761 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
762 bwarn "keeping the syntax tree: \"goto\" op found";
767 bwarn "cannot rescan '$scan'";
773 print $head if $head;
774 newasm sub { print @_ };
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;
782 asm "signal", cstring "__WARN__" # XXX
784 asm "incav", inc_gv->AV->ix if $T_inhinc;
786 asm "incav", inc_gv->AV->ix if $T_inhinc;
787 asm "dowarn", dowarn;
792 my $dh = *{defstash->NAME."::DATA"};
810 B::Bytecode - Perl compiler's bytecode backend
814 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
818 Compiles a Perl script into a bytecode format that could be loaded
819 later by the ByteLoader module and executed as a regular Perl script.
823 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
833 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
834 other files (ex. C<use Foo;>) are saved.
838 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
842 keep the syntax tree - it is stripped by default.
844 =item B<-o>I<outfile>
846 put the bytecode in <outfile> instead of dumping it to STDOUT.
850 scan the script for C<# line ..> directives and for <goto LABEL>
851 expressions. When gotos are found keep the syntax tree.
861 C<BEGIN { goto A: while 1; A: }> won't even compile.
865 C<?...?> and C<reset> do not work as expected.
869 variables in C<(?{ ... })> constructs are not properly scoped.
873 scripts that use source filters will fail miserably.
879 There are also undocumented bugs and options.
881 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
885 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
886 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
888 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.