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 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');
244 asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
245 "0 but true" : $sv->IVX;
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');
260 asm "xnv", sprintf "%.40g", $sv->NVX;
263 sub B::PVMG::domagic {
266 my @mglist = $sv->MAGIC;
269 push @mgix, $_->OBJ->ix;
270 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
273 nice '-'.class($sv).'-',
274 asm "ldsv", $varix = $ix unless $ix == $varix;
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;
282 asm "newpv", pvstring $_->PTR;
290 my $stashix = $sv->SvSTASH->ix;
291 $sv->B::PVNV::bsave($ix);
292 asm "xmg_stash", $stashix;
293 $sv->domagic($ix) if $sv->MAGICAL;
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;
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;
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
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;
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;
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;
364 $form->B::CV::bsave($ix);
365 asm "xfm_lines", $form->LINES;
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;
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;
383 asm "xmg_stash", $stashix;
389 $files{$gv->FILE} && $gv->LINE
390 || ${$cv = $gv->CV} && $files{$cv->FILE}
391 || ${$form = $gv->FORM} && $files{$form->FILE}
396 return if $walked{$$hv}++;
397 my %stash = $hv->ARRAY;
398 while (my($k,$v) = each %stash) {
399 if ($v->SvTYPE == SVt_PVGV) {
401 if ($$hash && $hash->NAME) {
404 $v->ix(1) if desired $v;
407 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
408 $svtab{$$v} = $varix = $tix;
410 asm "sv_flags", $v->FLAGS;
415 ######################################################
418 sub B::OP::bsave_thin {
420 my $next = $op->next;
421 my $nextix = $optab{$$next};
422 $nextix = 0, push @cloop, $op unless defined $nextix;
424 nice '-'.$op->name.'-',
425 asm "ldop", $opix = $ix;
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;
434 *B::OP::bsave = *B::OP::bsave_thin;
438 my $name = $op->name;
439 my $flags = $op->flags;
440 my $first = $op->first;
444 || (!ITHREADS && $name eq 'regcomp')
445 # trick for /$a/o in pp_regcomp
447 && $op->flags & OPf_MOD
448 && $op->private & OPpLVAL_INTRO
449 # change #18774 made my life hard
453 $op->B::OP::bsave($ix);
454 asm "op_first", $firstix;
457 sub B::BINOP::bsave {
459 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
460 my $last = $op->last;
462 local *B::OP::bsave = *B::OP::bsave_fat;
463 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
466 asm "ldop", $lastix unless $lastix == $opix;
467 asm "op_targ", $last->targ;
468 $op->B::OP::bsave($ix);
469 asm "op_last", $lastix;
471 $op->B::OP::bsave($ix);
475 # not needed if no pseudohashes
477 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
479 # deal with sort / formline
481 sub B::LISTOP::bsave {
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;
491 my $leaveix = $leave->ix;
493 my $rvgvix = $rvgv->ix;
494 asm "ldop", $rvgvix unless $rvgvix == $opix;
495 asm "op_first", $leaveix;
497 my $pushmarkix = $pushmark->ix;
498 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
499 asm "op_first", $rvgvix;
501 my $firstix = $first->ix;
502 asm "ldop", $firstix unless $firstix == $opix;
503 asm "op_sibling", $pushmarkix;
505 $op->B::OP::bsave($ix);
506 asm "op_first", $firstix;
507 } elsif ($name eq 'formline') {
508 $op->B::UNOP::bsave_fat($ix);
510 $op->B::OP::bsave($ix);
516 sub B::OP::bsave_fat {
518 my $siblix = $op->sibling->ix;
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
525 sub B::UNOP::bsave_fat {
527 my $firstix = $op->first->ix;
529 $op->B::OP::bsave($ix);
530 asm "op_first", $firstix;
533 sub B::BINOP::bsave_fat {
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;
542 $op->B::UNOP::bsave($ix);
543 asm "op_last", $lastix;
546 sub B::LOGOP::bsave {
548 my $otherix = $op->other->ix;
550 $op->B::UNOP::bsave($ix);
551 asm "op_other", $otherix;
556 my ($rrop, $rrarg, $rstart);
558 # my $pmnextix = $op->pmnext->ix; # XXX
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;
569 $op->B::BINOP::bsave($ix);
570 asm "op_pmstashpv", pvix $op->pmstashpv;
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;
580 asm $rrop, $rrarg if $rrop;
581 asm "op_pmreplstart", $rstart if $rstart;
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;
593 my $svix = $op->sv->ix;
595 $op->B::OP::bsave($ix);
599 sub B::PADOP::bsave {
602 $op->B::OP::bsave($ix);
603 asm "op_padix", $op->padix;
608 $op->B::OP::bsave($ix);
609 return unless my $pv = $op->pv;
611 if ($op->name eq 'trans') {
612 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
614 asm "newpv", pvstring $pv;
621 my $nextix = $op->nextop->ix;
622 my $lastix = $op->lastop->ix;
623 my $redoix = $op->redoop->ix;
625 $op->B::BINOP::bsave($ix);
626 asm "op_redoop", $redoix;
627 asm "op_nextop", $nextix;
628 asm "op_lastop", $lastix;
633 my $warnix = $cop->warnings->ix;
634 my $ioix = $cop->io->ix;
636 $cop->B::OP::bsave($ix);
637 asm "cop_stashpv", pvix $cop->stashpv;
638 asm "cop_file", pvix $cop->file;
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;
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;
656 my $ix = $optab{$$op};
657 defined($ix) ? $ix : do {
659 my @oplist = $op->oplist;
661 $ix = $_->ix while $_ = pop @oplist;
662 while ($_ = pop @cloop) {
663 asm "ldop", $optab{$$_};
664 asm "op_next", $optab{${$_->next}};
670 #################################################
674 if (($av=begin_av)->isa("B::AV")) {
677 next unless $_->FILE eq $0;
678 asm "push_begin", $_->ix;
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' ?
690 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
691 $$gv && $gv->NAME =~ /use_ok|plan/
693 asm "push_begin", $_->ix;
699 if (($av=init_av)->isa("B::AV")) {
701 next unless $_->FILE eq $0;
702 asm "push_init", $_->ix;
705 if (($av=end_av)->isa("B::AV")) {
707 next unless $_->FILE eq $0;
708 asm "push_end", $_->ix;
714 my ($head, $scan, $T_inhinc, $keep_syn);
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;
724 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
728 *newasm = *endasm = sub { };
729 *asm = sub { print " @_\n" };
730 *nice = sub ($) { print "\n@_\n" };
733 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
736 } elsif (/^-o(.*)$/) {
737 open STDOUT, ">$1" or die "open $1: $!";
738 } elsif (/^-f(.*)$/) {
740 } elsif (/^-s(.*)$/) {
741 $scan = length($1) ? $1 : $0;
744 # this is here for the testsuite
747 } elsif (/^-TF(.*)/) {
749 *B::COP::file = sub { $thatfile };
751 bwarn "Ignoring '$_' option";
756 if (open $f, $scan) {
758 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
760 if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
761 bwarn "keeping the syntax tree: \"goto\" op found";
766 bwarn "cannot rescan '$scan'";
772 print $head if $head;
773 newasm sub { print @_ };
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;
781 asm "signal", cstring "__WARN__" # XXX
783 asm "incav", inc_gv->AV->ix if $T_inhinc;
785 asm "incav", inc_gv->AV->ix if $T_inhinc;
786 asm "dowarn", dowarn;
791 my $dh = *{defstash->NAME."::DATA"};
809 B::Bytecode - Perl compiler's bytecode backend
813 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
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.
822 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
832 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
833 other files (ex. C<use Foo;>) are saved.
837 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
841 keep the syntax tree - it is stripped by default.
843 =item B<-o>I<outfile>
845 put the bytecode in <outfile> instead of dumping it to STDOUT.
849 scan the script for C<# line ..> directives and for <goto LABEL>
850 expressions. When gotos are found keep the syntax tree.
860 C<BEGIN { goto A: while 1; A: }> won't even compile.
864 C<?...?> and C<reset> do not work as expected.
868 variables in C<(?{ ... })> constructs are not properly scoped.
872 scripts that use source filters will fail miserably.
878 There are also undocumented bugs and options.
880 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
884 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
885 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
887 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.