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 "xav_flags", $av->AvFLAGS;
365 asm "xmg_stash", $stashix;
371 $files{$gv->FILE} && $gv->LINE
372 || ${$cv = $gv->CV} && $files{$cv->FILE}
373 || ${$form = $gv->FORM} && $files{$form->FILE}
378 return if $walked{$$hv}++;
379 my %stash = $hv->ARRAY;
380 while (my($k,$v) = each %stash) {
381 if ($v->SvTYPE == SVt_PVGV) {
383 if ($$hash && $hash->NAME) {
386 $v->ix(1) if desired $v;
389 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
390 $svtab{$$v} = $varix = $tix;
392 asm "sv_flags", $v->FLAGS;
397 ######################################################
400 sub B::OP::bsave_thin {
402 my $next = $op->next;
403 my $nextix = $optab{$$next};
404 $nextix = 0, push @cloop, $op unless defined $nextix;
406 nice '-'.$op->name.'-',
407 asm "ldop", $opix = $ix;
409 asm "op_next", $nextix;
410 asm "op_targ", $op->targ if $op->type; # tricky
411 asm "op_flags", $op->flags;
412 asm "op_private", $op->private;
416 *B::OP::bsave = *B::OP::bsave_thin;
420 my $name = $op->name;
421 my $flags = $op->flags;
422 my $first = $op->first;
426 || (!ITHREADS && $name eq 'regcomp')
427 # trick for /$a/o in pp_regcomp
429 && $op->flags & OPf_MOD
430 && $op->private & OPpLVAL_INTRO
431 # change #18774 made my life hard
435 $op->B::OP::bsave($ix);
436 asm "op_first", $firstix;
439 sub B::BINOP::bsave {
441 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
442 my $last = $op->last;
444 local *B::OP::bsave = *B::OP::bsave_fat;
445 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
448 asm "ldop", $lastix unless $lastix == $opix;
449 asm "op_targ", $last->targ;
450 $op->B::OP::bsave($ix);
451 asm "op_last", $lastix;
453 $op->B::OP::bsave($ix);
457 # not needed if no pseudohashes
459 *B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
461 # deal with sort / formline
463 sub B::LISTOP::bsave {
465 my $name = $op->name;
466 sub blocksort() { OPf_SPECIAL|OPf_STACKED }
467 if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
468 my $first = $op->first;
469 my $pushmark = $first->sibling;
470 my $rvgv = $pushmark->first;
471 my $leave = $rvgv->first;
473 my $leaveix = $leave->ix;
475 my $rvgvix = $rvgv->ix;
476 asm "ldop", $rvgvix unless $rvgvix == $opix;
477 asm "op_first", $leaveix;
479 my $pushmarkix = $pushmark->ix;
480 asm "ldop", $pushmarkix unless $pushmarkix == $opix;
481 asm "op_first", $rvgvix;
483 my $firstix = $first->ix;
484 asm "ldop", $firstix unless $firstix == $opix;
485 asm "op_sibling", $pushmarkix;
487 $op->B::OP::bsave($ix);
488 asm "op_first", $firstix;
489 } elsif ($name eq 'formline') {
490 $op->B::UNOP::bsave_fat($ix);
492 $op->B::OP::bsave($ix);
498 sub B::OP::bsave_fat {
500 my $siblix = $op->sibling->ix;
502 $op->B::OP::bsave_thin($ix);
503 asm "op_sibling", $siblix;
504 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
507 sub B::UNOP::bsave_fat {
509 my $firstix = $op->first->ix;
511 $op->B::OP::bsave($ix);
512 asm "op_first", $firstix;
515 sub B::BINOP::bsave_fat {
517 my $last = $op->last;
518 my $lastix = $op->last->ix;
519 if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
520 asm "ldop", $lastix unless $lastix == $opix;
521 asm "op_targ", $last->targ;
524 $op->B::UNOP::bsave($ix);
525 asm "op_last", $lastix;
528 sub B::LOGOP::bsave {
530 my $otherix = $op->other->ix;
532 $op->B::UNOP::bsave($ix);
533 asm "op_other", $otherix;
538 my ($rrop, $rrarg, $rstart);
540 # my $pmnextix = $op->pmnext->ix; # XXX
543 if ($op->name eq 'subst') {
544 $rrop = "op_pmreplroot";
545 $rrarg = $op->pmreplroot->ix;
546 $rstart = $op->pmreplstart->ix;
547 } elsif ($op->name eq 'pushre') {
548 $rrop = "op_pmreplrootpo";
549 $rrarg = $op->pmreplroot;
551 $op->B::BINOP::bsave($ix);
552 asm "op_pmstashpv", pvix $op->pmstashpv;
554 $rrop = "op_pmreplrootgv";
555 $rrarg = $op->pmreplroot->ix;
556 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
557 my $stashix = $op->pmstash->ix;
558 $op->B::BINOP::bsave($ix);
559 asm "op_pmstash", $stashix;
562 asm $rrop, $rrarg if $rrop;
563 asm "op_pmreplstart", $rstart if $rstart;
565 asm "op_pmflags", $op->pmflags;
566 asm "op_pmpermflags", $op->pmpermflags;
567 asm "op_pmdynflags", $op->pmdynflags;
568 # asm "op_pmnext", $pmnextix; # XXX
569 asm "newpv", pvstring $op->precomp;
575 my $svix = $op->sv->ix;
577 $op->B::OP::bsave($ix);
581 sub B::PADOP::bsave {
584 $op->B::OP::bsave($ix);
585 asm "op_padix", $op->padix;
590 $op->B::OP::bsave($ix);
591 return unless my $pv = $op->pv;
593 if ($op->name eq 'trans') {
594 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
596 asm "newpv", pvstring $pv;
603 my $nextix = $op->nextop->ix;
604 my $lastix = $op->lastop->ix;
605 my $redoix = $op->redoop->ix;
607 $op->B::BINOP::bsave($ix);
608 asm "op_redoop", $redoix;
609 asm "op_nextop", $nextix;
610 asm "op_lastop", $lastix;
615 my $warnix = $cop->warnings->ix;
616 my $ioix = $cop->io->ix;
618 $cop->B::OP::bsave($ix);
619 asm "cop_stashpv", pvix $cop->stashpv;
620 asm "cop_file", pvix $cop->file;
622 my $stashix = $cop->stash->ix;
623 my $fileix = $cop->filegv->ix(1);
624 $cop->B::OP::bsave($ix);
625 asm "cop_stash", $stashix;
626 asm "cop_filegv", $fileix;
628 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
629 asm "cop_seq", $cop->cop_seq;
630 asm "cop_arybase", $cop->arybase;
631 asm "cop_line", $cop->line;
632 asm "cop_warnings", $warnix;
638 my $ix = $optab{$$op};
639 defined($ix) ? $ix : do {
641 my @oplist = $op->oplist;
643 $ix = $_->ix while $_ = pop @oplist;
644 while ($_ = pop @cloop) {
645 asm "ldop", $optab{$$_};
646 asm "op_next", $optab{${$_->next}};
652 #################################################
656 if (($av=begin_av)->isa("B::AV")) {
659 next unless $_->FILE eq $0;
660 asm "push_begin", $_->ix;
664 next unless $_->FILE eq $0;
665 # XXX BEGIN { goto A while 1; A: }
666 for (my $op = $_->START; $$op; $op = $op->next) {
667 next unless $op->name eq 'require' ||
668 # this kludge needed for tests
669 $op->name eq 'gv' && do {
670 my $gv = class($op) eq 'SVOP' ?
672 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
673 $$gv && $gv->NAME =~ /use_ok|plan/
675 asm "push_begin", $_->ix;
681 if (($av=init_av)->isa("B::AV")) {
683 next unless $_->FILE eq $0;
684 asm "push_init", $_->ix;
687 if (($av=end_av)->isa("B::AV")) {
689 next unless $_->FILE eq $0;
690 asm "push_end", $_->ix;
696 my ($head, $scan, $T_inhinc, $keep_syn);
701 *B::OP::bsave = *B::OP::bsave_fat;
702 *B::UNOP::bsave = *B::UNOP::bsave_fat;
703 *B::BINOP::bsave = *B::BINOP::bsave_fat;
704 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
706 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
710 *newasm = *endasm = sub { };
711 *asm = sub { print " @_\n" };
712 *nice = sub ($) { print "\n@_\n" };
715 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
718 } elsif (/^-o(.*)$/) {
719 open STDOUT, ">$1" or die "open $1: $!";
720 } elsif (/^-f(.*)$/) {
722 } elsif (/^-s(.*)$/) {
723 $scan = length($1) ? $1 : $0;
726 # this is here for the testsuite
729 } elsif (/^-TF(.*)/) {
731 *B::COP::file = sub { $thatfile };
733 bwarn "Ignoring '$_' option";
739 or bwarn("cannot rescan '$_'"), next;
741 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
743 if (/\bgoto\b/ && !$keep_syn) {
744 bwarn "keeping the syntax tree: \"goto\" op found";
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.