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);
22 #################################################
24 my $ithreads = $Config{'useithreads'} eq 'define';
25 my ($varix, $opix, $savebegins);
37 #################################################
41 defined($pv) ? cstring ($pv."\0") : "\"\"";
45 my $str = pvstring shift;
46 my $ix = $strtab{$str};
47 defined($ix) ? $ix : do {
49 asm "stpv", $strtab{$str} = $tix;
56 my $ix = $optab{$$op};
57 defined($ix) ? $ix : do {
58 nice '['.$op->name.']';
59 asm "newopx", $op->size | $op->type <<7;
60 $optab{$$op} = $opix = $ix = $tix++;
68 my $ix = $spectab{$$spec};
69 defined($ix) ? $ix : do {
70 nice '['.$specialsv_name[$$spec].']';
71 asm "ldspecsvx", $$spec;
72 $spectab{$$spec} = $varix = $tix++;
78 my $ix = $svtab{$$sv};
79 defined($ix) ? $ix : do {
80 nice '['.class($sv).']';
81 asm "newsvx", $sv->FLAGS;
82 $svtab{$$sv} = $varix = $ix = $tix++;
89 my ($gv,$desired) = @_;
90 my $ix = $svtab{$$gv};
91 defined($ix) ? $ix : do {
93 my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
95 my $name = $gv->STASH->NAME . "::" . $gv->NAME;
96 asm "gv_fetchpvx", cstring $name;
97 $svtab{$$gv} = $varix = $ix = $tix++;
98 asm "sv_flags", $gv->FLAGS;
99 asm "sv_refcnt", $gv->REFCNT;
100 asm "xgv_flags", $gv->GvFLAGS;
102 asm "gp_refcnt", $gv->GvREFCNT;
103 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
105 unless $desired || desired $gv;
112 $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
113 my $form = $gv->FORM;
114 $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
116 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
120 asm "ldsv", $varix = $ix unless $ix == $varix;
126 asm "gp_cvgen", $gv->CVGEN;
127 asm "gp_form", $formix;
128 asm "gp_file", pvix $gv->FILE;
129 asm "gp_line", $gv->LINE;
130 asm "formfeed", $svix if $name eq "main::\cL";
133 asm "newsvx", $gv->FLAGS;
134 $svtab{$$gv} = $varix = $ix = $tix++;
135 my $stashix = $gv->STASH->ix;
136 $gv->B::PVMG::bsave($ix);
137 asm "xgv_flags", $gv->GvFLAGS;
138 asm "xgv_stash", $stashix;
146 my $ix = $svtab{$$hv};
147 defined($ix) ? $ix : do {
149 my $name = $hv->NAME;
152 asm "gv_stashpvx", cstring $name;
153 asm "sv_flags", $hv->FLAGS;
154 $svtab{$$hv} = $varix = $ix = $tix++;
155 asm "xhv_name", pvix $name;
156 # my $pmrootix = $hv->PMROOT->ix; # XXX
157 asm "ldsv", $varix = $ix unless $ix == $varix;
158 # asm "xhv_pmroot", $pmrootix; # XXX
161 asm "newsvx", $hv->FLAGS;
162 $svtab{$$hv} = $varix = $ix = $tix++;
163 my $stashix = $hv->SvSTASH->ix;
164 for (@array = $hv->ARRAY) {
169 asm "ldsv", $varix = $ix unless $ix == $varix;
170 ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
173 asm "xmg_stash", $stashix;
175 asm "sv_refcnt", $hv->REFCNT;
182 $$sv ? $sv->B::SV::ix : 0;
185 sub B::NULL::opwalk { 0 }
187 #################################################
192 nice '-'.class($sv).'-',
193 asm "ldsv", $varix = $ix unless $ix == $varix;
194 asm "sv_refcnt", $sv->REFCNT;
198 *B::SV::bsave = *B::NULL::bsave;
202 my $rvix = $sv->RV->ix;
203 $sv->B::NULL::bsave($ix);
209 $sv->B::NULL::bsave($ix);
210 asm "newpv", pvstring $sv->PVBM;
216 $sv->B::NULL::bsave($ix);
222 $sv->B::NULL::bsave($ix);
223 asm "xnv", sprintf "%.40g", $sv->NVX;
229 $sv->B::PV::bsave($ix):
231 $sv->B::RV::bsave($ix):
232 $sv->B::NULL::bsave($ix);
233 asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
234 "0 but true" : $sv->IVX;
239 $sv->B::PVIV::bsave($ix);
240 asm "xnv", sprintf "%.40g", $sv->NVX;
243 sub B::PVMG::domagic {
246 my @mglist = $sv->MAGIC;
249 push @mgix, $_->OBJ->ix;
250 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
253 nice '-'.class($sv).'-',
254 asm "ldsv", $varix = $ix unless $ix == $varix;
256 asm "sv_magic", cstring $_->TYPE;
257 asm "mg_obj", shift @mgix;
258 my $length = $_->LENGTH;
259 if ($length == B::HEf_SVKEY) {
260 asm "mg_namex", shift @namix;
262 asm "newpv", pvstring $_->PTR;
270 my $stashix = $sv->SvSTASH->ix;
271 $sv->B::PVNV::bsave($ix);
272 asm "xmg_stash", $stashix;
273 $sv->domagic($ix) if $sv->MAGICAL;
278 my $targix = $sv->TARG->ix;
279 $sv->B::PVMG::bsave($ix);
280 asm "xlv_targ", $targix;
281 asm "xlv_targoff", $sv->TARGOFF;
282 asm "xlv_targlen", $sv->TARGLEN;
283 asm "xlv_type", $sv->TYPE;
289 $sv->B::PVMG::bsave($ix);
290 asm "xpv_cur", $sv->CUR;
291 asm "xbm_useful", $sv->USEFUL;
292 asm "xbm_previous", $sv->PREVIOUS;
293 asm "xbm_rare", $sv->RARE;
298 my $topix = $io->TOP_GV->ix;
299 my $fmtix = $io->FMT_GV->ix;
300 my $bottomix = $io->BOTTOM_GV->ix;
301 $io->B::PVMG::bsave($ix);
302 asm "xio_lines", $io->LINES;
303 asm "xio_page", $io->PAGE;
304 asm "xio_page_len", $io->PAGE_LEN;
305 asm "xio_lines_left", $io->LINES_LEFT;
306 asm "xio_top_name", pvix $io->TOP_NAME;
307 asm "xio_top_gv", $topix;
308 asm "xio_fmt_name", pvix $io->FMT_NAME;
309 asm "xio_fmt_gv", $fmtix;
310 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
311 asm "xio_bottom_gv", $bottomix;
312 asm "xio_subprocess", $io->SUBPROCESS;
313 asm "xio_type", ord $io->IoTYPE;
314 # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
319 my $stashix = $cv->STASH->ix;
320 my $gvix = $cv->GV->ix;
321 my $padlistix = $cv->PADLIST->ix;
322 my $outsideix = $cv->OUTSIDE->ix;
323 my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
324 my $startix = $cv->START->opwalk;
325 my $rootix = $cv->ROOT->ix;
327 $cv->B::PVMG::bsave($ix);
328 asm "xcv_stash", $stashix;
329 asm "xcv_start", $startix;
330 asm "xcv_root", $rootix;
331 asm "xcv_xsubany", $constix;
333 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
334 asm "xcv_padlist", $padlistix;
335 asm "xcv_outside", $outsideix;
336 asm "xcv_flags", $cv->CvFLAGS;
337 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
338 asm "xcv_depth", $cv->DEPTH;
344 $form->B::CV::bsave($ix);
345 asm "xfm_lines", $form->LINES;
350 return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
351 my @array = $av->ARRAY;
352 $_ = $_->ix for @array;
353 my $stashix = $av->SvSTASH->ix;
356 asm "ldsv", $varix = $ix unless $ix == $varix;
357 asm "av_extend", $av->MAX;
358 asm "av_pushx", $_ for @array;
359 asm "sv_refcnt", $av->REFCNT;
360 asm "xav_flags", $av->AvFLAGS;
361 asm "xmg_stash", $stashix;
367 $files{$gv->FILE} && $gv->LINE
368 || ${$cv = $gv->CV} && $files{$cv->FILE}
369 || ${$form = $gv->FORM} && $files{$form->FILE}
374 return if $walked{$$hv}++;
375 my %stash = $hv->ARRAY;
376 while (my($k,$v) = each %stash) {
377 if ($v->SvTYPE == SVt_PVGV) {
379 if ($$hash && $hash->NAME) {
382 $v->ix(1) if desired $v;
385 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
386 $svtab{$$v} = $varix = $tix;
388 asm "sv_flags", $v->FLAGS;
393 ######################################################
396 sub B::OP::bsave_thin {
398 my $next = $op->next;
399 my $nextix = $optab{$$next};
400 $nextix = 0, push @cloop, $op unless defined $nextix;
402 nice '-'.$op->name.'-',
403 asm "ldop", $opix = $ix;
405 asm "op_next", $nextix;
406 asm "op_targ", $op->targ if $op->type; # tricky
407 asm "op_flags", $op->flags;
408 asm "op_private", $op->private;
412 *B::OP::bsave = *B::OP::bsave_thin;
416 my $name = $op->name;
417 my $flags = $op->flags;
418 my $first = $op->first;
422 || (!$ithreads && $name eq 'regcomp')
423 # trick for /$a/o in pp_regcomp
425 && $op->flags & OPf_MOD
426 && $op->private & OPpLVAL_INTRO
427 # change #18774 made my life hard
431 $op->B::OP::bsave($ix);
432 asm "op_first", $firstix;
435 sub B::BINOP::bsave {
437 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
438 my $last = $op->last;
440 local *B::OP::bsave = *B::OP::bsave_fat;
441 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
444 asm "ldop", $lastix unless $lastix == $opix;
445 asm "op_targ", $last->targ;
446 $op->B::OP::bsave($ix);
447 asm "op_last", $lastix;
449 $op->B::OP::bsave($ix);
453 # not needed if no pseudohashes
455 *B::BINOP::bsave = *B::OP::bsave if $] >= 5.009;
457 # deal with sort / formline
459 sub B::LISTOP::bsave {
461 my $name = $op->name;
462 if ($name eq 'sort' && $op->flags & (OPf_SPECIAL|OPf_STACKED)) {
463 my $first = $op->first;
464 my $firstix = $first->ix;
465 my $firstsiblix = do {
466 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
467 local *B::LISTOP::bsave = *B::UNOP::bsave_fat;
470 asm "ldop", $firstix unless $firstix == $opix;
471 asm "op_sibling", $firstsiblix;
472 $op->B::OP::bsave($ix);
473 asm "op_first", $firstix;
474 } elsif ($name eq 'formline') {
475 $op->B::UNOP::bsave_fat($ix);
477 $op->B::OP::bsave($ix);
483 sub B::OP::bsave_fat {
485 my $siblix = $op->sibling->ix;
487 $op->B::OP::bsave_thin($ix);
488 asm "op_sibling", $siblix;
489 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
492 sub B::UNOP::bsave_fat {
494 my $firstix = $op->first->ix;
496 $op->B::OP::bsave($ix);
497 asm "op_first", $firstix;
500 sub B::BINOP::bsave_fat {
502 my $last = $op->last;
503 my $lastix = $op->last->ix;
504 if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
505 asm "ldop", $lastix unless $lastix == $opix;
506 asm "op_targ", $last->targ;
509 $op->B::UNOP::bsave($ix);
510 asm "op_last", $lastix;
513 sub B::LOGOP::bsave {
515 my $otherix = $op->other->ix;
517 $op->B::UNOP::bsave($ix);
518 asm "op_other", $otherix;
523 my ($rrop, $rrarg, $rstart);
525 # my $pmnextix = $op->pmnext->ix; # XXX
528 if ($op->name eq 'subst') {
529 $rrop = "op_pmreplroot";
530 $rrarg = $op->pmreplroot->ix;
531 $rstart = $op->pmreplstart->ix;
532 } elsif ($op->name eq 'pushre') {
533 $rrop = "op_pmreplrootpo";
534 $rrarg = $op->pmreplroot;
536 $op->B::BINOP::bsave($ix);
537 asm "op_pmstashpv", pvix $op->pmstashpv;
539 $rrop = "op_pmreplrootgv";
540 $rrarg = $op->pmreplroot->ix;
541 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
542 my $stashix = $op->pmstash->ix;
543 $op->B::BINOP::bsave($ix);
544 asm "op_pmstash", $stashix;
547 asm $rrop, $rrarg if $rrop;
548 asm "op_pmreplstart", $rstart if $rstart;
550 asm "op_pmflags", $op->pmflags;
551 asm "op_pmpermflags", $op->pmpermflags;
552 asm "op_pmdynflags", $op->pmdynflags;
553 # asm "op_pmnext", $pmnextix; # XXX
554 asm "newpv", pvstring $op->precomp;
560 my $svix = $op->sv->ix;
562 $op->B::OP::bsave($ix);
566 sub B::PADOP::bsave {
569 $op->B::OP::bsave($ix);
570 asm "op_padix", $op->padix;
575 $op->B::OP::bsave($ix);
576 return unless my $pv = $op->pv;
578 if ($op->name eq 'trans') {
579 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
581 asm "newpv", pvstring $pv;
588 my $nextix = $op->nextop->ix;
589 my $lastix = $op->lastop->ix;
590 my $redoix = $op->redoop->ix;
592 $op->B::BINOP::bsave($ix);
593 asm "op_redoop", $redoix;
594 asm "op_nextop", $nextix;
595 asm "op_lastop", $lastix;
600 my $warnix = $cop->warnings->ix;
601 my $ioix = $cop->io->ix;
603 $cop->B::OP::bsave($ix);
604 asm "cop_stashpv", pvix $cop->stashpv;
605 asm "cop_file", pvix $cop->file;
607 my $stashix = $cop->stash->ix;
608 my $fileix = $cop->filegv->ix(1);
609 $cop->B::OP::bsave($ix);
610 asm "cop_stash", $stashix;
611 asm "cop_filegv", $fileix;
613 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
614 asm "cop_seq", $cop->cop_seq;
615 asm "cop_arybase", $cop->arybase;
616 asm "cop_line", $cop->line;
617 asm "cop_warnings", $warnix;
623 my $ix = $optab{$$op};
624 defined($ix) ? $ix : do {
626 my @oplist = $op->oplist;
628 $ix = $_->ix while $_ = pop @oplist;
629 while ($_ = pop @cloop) {
630 asm "ldop", $optab{$$_};
631 asm "op_next", $optab{${$_->next}};
637 #################################################
641 if (($av=begin_av)->isa("B::AV")) {
644 next unless $_->FILE eq $0;
645 asm "push_begin", $_->ix;
649 next unless $_->FILE eq $0;
650 # XXX BEGIN { goto A while 1; A: }
651 for (my $op = $_->START; $$op; $op = $op->next) {
652 next unless $op->name eq 'require' ||
653 # this kludge needed for tests
654 $op->name eq 'gv' && do {
655 my $gv = class($op) eq 'SVOP' ?
657 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
658 $$gv && $gv->NAME =~ /use_ok|plan/
660 asm "push_begin", $_->ix;
666 if (($av=init_av)->isa("B::AV")) {
668 next unless $_->FILE eq $0;
669 asm "push_init", $_->ix;
672 if (($av=end_av)->isa("B::AV")) {
674 next unless $_->FILE eq $0;
675 asm "push_end", $_->ix;
681 my ($head, $scan, $T_inhinc, $keep_syn);
686 *B::OP::bsave = *B::OP::bsave_fat;
687 *B::UNOP::bsave = *B::UNOP::bsave_fat;
688 *B::BINOP::bsave = *B::BINOP::bsave_fat;
689 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
691 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
695 *newasm = *endasm = sub { };
696 *asm = sub { print " @_\n" };
697 *nice = sub ($) { print "\n@_\n" };
700 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
703 } elsif (/^-o(.*)$/) {
704 open STDOUT, ">$1" or die "open $1: $!";
705 } elsif (/^-f(.*)$/) {
707 } elsif (/^-s(.*)$/) {
708 $scan = length($1) ? $1 : $0;
711 # this is here for the testsuite
714 } elsif (/^-TF(.*)/) {
716 *B::COP::file = sub { $thatfile };
718 bwarn "Ignoring '$_' option";
724 or bwarn("cannot rescan '$_'"), next;
726 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
728 if (/\bgoto\b/ && !$keep_syn) {
729 bwarn "keeping the syntax tree: \"goto\" op found";
737 print $head if $head;
738 newasm sub { print @_ };
741 asm "main_start", main_start->opwalk;
742 asm "main_root", main_root->ix;
743 asm "main_cv", main_cv->ix;
744 asm "curpad", (comppadlist->ARRAY)[1]->ix;
746 asm "signal", cstring "__WARN__" # XXX
748 asm "incav", inc_gv->AV->ix if $T_inhinc;
750 asm "incav", inc_gv->AV->ix if $T_inhinc;
751 asm "dowarn", dowarn;
756 my $dh = *{defstash->NAME."::DATA"};
758 if (length (my $data = <$dh>)) {
774 B::Bytecode - Perl compiler's bytecode backend
778 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
782 Compiles a Perl script into a bytecode format that could be loaded
783 later by the ByteLoader module and executed as a regular Perl script.
787 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
797 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
798 other files (ex. C<use Foo;>) are saved.
802 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
806 keep the syntax tree - it is stripped by default.
808 =item B<-o>I<outfile>
810 put the bytecode in <outfile> instead of dumping it to STDOUT.
814 scan the script for C<# line ..> directives and for <goto LABEL>
815 expressions. When gotos are found keep the syntax tree.
825 C<BEGIN { goto A: while 1; A: }> won't even compile.
829 C<?...?> and C<reset> do not work as expected.
833 variables in C<(?{ ... })> constructs are not properly scoped.
837 scripts that use source filters will fail miserably.
843 There are also undocumented bugs and options.
845 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
849 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
850 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
852 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.