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.
12 use B qw(class main_cv main_root main_start cstring comppadlist
13 defstash curstash begin_av init_av end_av inc_gv warnhook diehook
14 dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
15 OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
16 use B::Asmdata qw(@specialsv_name);
17 use B::Assembler qw(asm newasm endasm);
20 #################################################
22 my $ithreads = $Config{'useithreads'} eq 'define';
23 my ($varix, $opix, $savebegins);
35 #################################################
39 defined($pv) ? cstring ($pv."\0") : "\"\"";
43 my $str = pvstring shift;
44 my $ix = $strtab{$str};
45 defined($ix) ? $ix : do {
47 asm "stpv", $strtab{$str} = $tix;
54 my $ix = $optab{$$op};
55 defined($ix) ? $ix : do {
56 nice '['.$op->name.']';
57 asm "newopx", $op->size | $op->type <<7;
58 $optab{$$op} = $opix = $ix = $tix++;
66 my $ix = $spectab{$$spec};
67 defined($ix) ? $ix : do {
68 nice '['.$specialsv_name[$$spec].']';
69 asm "ldspecsvx", $$spec;
70 $spectab{$$spec} = $varix = $tix++;
76 my $ix = $svtab{$$sv};
77 defined($ix) ? $ix : do {
78 nice '['.class($sv).']';
79 asm "newsvx", $sv->FLAGS;
80 $svtab{$$sv} = $varix = $ix = $tix++;
87 my ($gv,$desired) = @_;
88 my $ix = $svtab{$$gv};
89 defined($ix) ? $ix : do {
91 my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
93 my $name = $gv->STASH->NAME . "::" . $gv->NAME;
94 asm "gv_fetchpvx", cstring $name;
95 $svtab{$$gv} = $varix = $ix = $tix++;
96 asm "sv_flags", $gv->FLAGS;
97 asm "sv_refcnt", $gv->REFCNT;
98 asm "xgv_flags", $gv->GvFLAGS;
100 asm "gp_refcnt", $gv->GvREFCNT;
101 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
103 unless $desired || desired $gv;
110 $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
111 my $form = $gv->FORM;
112 $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
114 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
118 asm "ldsv", $varix = $ix unless $ix == $varix;
124 asm "gp_cvgen", $gv->CVGEN;
125 asm "gp_form", $formix;
126 asm "gp_file", pvix $gv->FILE;
127 asm "gp_line", $gv->LINE;
128 asm "formfeed", $svix if $name eq "main::\cL";
131 asm "newsvx", $gv->FLAGS;
132 $svtab{$$gv} = $varix = $ix = $tix++;
133 my $stashix = $gv->STASH->ix;
134 $gv->B::PVMG::bsave($ix);
135 asm "xgv_flags", $gv->GvFLAGS;
136 asm "xgv_stash", $stashix;
144 my $ix = $svtab{$$hv};
145 defined($ix) ? $ix : do {
147 my $name = $hv->NAME;
150 asm "gv_stashpvx", cstring $name;
151 asm "sv_flags", $hv->FLAGS;
152 $svtab{$$hv} = $varix = $ix = $tix++;
153 asm "xhv_name", pvix $name;
154 # my $pmrootix = $hv->PMROOT->ix; # XXX
155 asm "ldsv", $varix = $ix unless $ix == $varix;
156 # asm "xhv_pmroot", $pmrootix; # XXX
159 asm "newsvx", $hv->FLAGS;
160 $svtab{$$hv} = $varix = $ix = $tix++;
161 my $stashix = $hv->SvSTASH->ix;
162 for (@array = $hv->ARRAY) {
167 asm "ldsv", $varix = $ix unless $ix == $varix;
168 ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
171 asm "xmg_stash", $stashix;
173 asm "sv_refcnt", $hv->REFCNT;
180 $$sv ? $sv->B::SV::ix : 0;
183 sub B::NULL::opwalk { 0 }
185 #################################################
190 nice '-'.class($sv).'-',
191 asm "ldsv", $varix = $ix unless $ix == $varix;
192 asm "sv_refcnt", $sv->REFCNT;
196 *B::SV::bsave = *B::NULL::bsave;
200 my $rvix = $sv->RV->ix;
201 $sv->B::NULL::bsave($ix);
207 $sv->B::NULL::bsave($ix);
208 asm "newpv", pvstring $sv->PVBM;
214 $sv->B::NULL::bsave($ix);
220 $sv->B::NULL::bsave($ix);
221 asm "xnv", sprintf "%.40g", $sv->NVX;
227 $sv->B::PV::bsave($ix):
229 $sv->B::RV::bsave($ix):
230 $sv->B::NULL::bsave($ix);
231 asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
232 "0 but true" : $sv->IVX;
237 $sv->B::PVIV::bsave($ix);
238 asm "xnv", sprintf "%.40g", $sv->NVX;
241 sub B::PVMG::domagic {
244 my @mglist = $sv->MAGIC;
247 push @mgix, $_->OBJ->ix;
248 push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
251 nice '-'.class($sv).'-',
252 asm "ldsv", $varix = $ix unless $ix == $varix;
254 asm "sv_magic", cstring $_->TYPE;
255 asm "mg_obj", shift @mgix;
256 my $length = $_->LENGTH;
257 if ($length == B::HEf_SVKEY) {
258 asm "mg_namex", shift @namix;
260 asm "newpv", pvstring $_->PTR;
268 my $stashix = $sv->SvSTASH->ix;
269 $sv->B::PVNV::bsave($ix);
270 asm "xmg_stash", $stashix;
271 $sv->domagic($ix) if $sv->MAGICAL;
276 my $targix = $sv->TARG->ix;
277 $sv->B::PVMG::bsave($ix);
278 asm "xlv_targ", $targix;
279 asm "xlv_targoff", $sv->TARGOFF;
280 asm "xlv_targlen", $sv->TARGLEN;
281 asm "xlv_type", $sv->TYPE;
287 $sv->B::PVMG::bsave($ix);
288 asm "xpv_cur", $sv->CUR;
289 asm "xbm_useful", $sv->USEFUL;
290 asm "xbm_previous", $sv->PREVIOUS;
291 asm "xbm_rare", $sv->RARE;
296 my $topix = $io->TOP_GV->ix;
297 my $fmtix = $io->FMT_GV->ix;
298 my $bottomix = $io->BOTTOM_GV->ix;
299 $io->B::PVMG::bsave($ix);
300 asm "xio_lines", $io->LINES;
301 asm "xio_page", $io->PAGE;
302 asm "xio_page_len", $io->PAGE_LEN;
303 asm "xio_lines_left", $io->LINES_LEFT;
304 asm "xio_top_name", pvix $io->TOP_NAME;
305 asm "xio_top_gv", $topix;
306 asm "xio_fmt_name", pvix $io->FMT_NAME;
307 asm "xio_fmt_gv", $fmtix;
308 asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
309 asm "xio_bottom_gv", $bottomix;
310 asm "xio_subprocess", $io->SUBPROCESS;
311 asm "xio_type", ord $io->IoTYPE;
312 # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
317 my $stashix = $cv->STASH->ix;
318 my $gvix = $cv->GV->ix;
319 my $padlistix = $cv->PADLIST->ix;
320 my $outsideix = $cv->OUTSIDE->ix;
321 my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
322 my $startix = $cv->START->opwalk;
323 my $rootix = $cv->ROOT->ix;
325 $cv->B::PVMG::bsave($ix);
326 asm "xcv_stash", $stashix;
327 asm "xcv_start", $startix;
328 asm "xcv_root", $rootix;
329 asm "xcv_xsubany", $constix;
331 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
332 asm "xcv_padlist", $padlistix;
333 asm "xcv_outside", $outsideix;
334 asm "xcv_flags", $cv->CvFLAGS;
335 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
336 asm "xcv_depth", $cv->DEPTH;
342 $form->B::CV::bsave($ix);
343 asm "xfm_lines", $form->LINES;
348 return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
349 my @array = $av->ARRAY;
350 $_ = $_->ix for @array;
351 my $stashix = $av->SvSTASH->ix;
354 asm "ldsv", $varix = $ix unless $ix == $varix;
355 asm "av_extend", $av->MAX;
356 asm "av_pushx", $_ for @array;
357 asm "sv_refcnt", $av->REFCNT;
358 asm "xav_flags", $av->AvFLAGS;
359 asm "xmg_stash", $stashix;
365 $files{$gv->FILE} && $gv->LINE
366 || ${$cv = $gv->CV} && $files{$cv->FILE}
367 || ${$form = $gv->FORM} && $files{$form->FILE}
372 return if $walked{$$hv}++;
373 my %stash = $hv->ARRAY;
374 while (my($k,$v) = each %stash) {
375 if ($v->SvTYPE == SVt_PVGV) {
377 if ($$hash && $hash->NAME) {
380 $v->ix(1) if desired $v;
383 asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
384 $svtab{$$v} = $varix = $tix;
386 asm "sv_flags", $v->FLAGS;
391 ######################################################
394 sub B::OP::bsave_thin {
396 my $next = $op->next;
397 my $nextix = $optab{$$next};
398 $nextix = 0, push @cloop, $op unless defined $nextix;
400 nice '-'.$op->name.'-',
401 asm "ldop", $opix = $ix;
403 asm "op_next", $nextix;
404 asm "op_targ", $op->targ if $op->type; # tricky
405 asm "op_flags", $op->flags;
406 asm "op_private", $op->private;
410 *B::OP::bsave = *B::OP::bsave_thin;
414 my $name = $op->name;
415 my $flags = $op->flags;
416 my $first = $op->first;
420 || (!$ithreads && $name eq 'regcomp')
421 # trick for /$a/o in pp_regcomp
423 && $op->flags & OPf_MOD
424 && $op->private & OPpLVAL_INTRO
425 # change #18774 made my life hard
429 $op->B::OP::bsave($ix);
430 asm "op_first", $firstix;
433 sub B::BINOP::bsave {
435 if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
436 my $last = $op->last;
438 local *B::OP::bsave = *B::OP::bsave_fat;
439 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
442 asm "ldop", $lastix unless $lastix == $opix;
443 asm "op_targ", $last->targ;
444 $op->B::OP::bsave($ix);
445 asm "op_last", $lastix;
447 $op->B::OP::bsave($ix);
451 # not needed if no pseudohashes
453 *B::BINOP::bsave = *B::OP::bsave if $] >= 5.009;
455 # deal with sort / formline
457 sub B::LISTOP::bsave {
459 my $name = $op->name;
460 if ($name eq 'sort' && $op->flags & (OPf_SPECIAL|OPf_STACKED)) {
461 my $first = $op->first;
462 my $firstix = $first->ix;
463 my $firstsiblix = do {
464 local *B::UNOP::bsave = *B::UNOP::bsave_fat;
465 local *B::LISTOP::bsave = *B::UNOP::bsave_fat;
468 asm "ldop", $firstix unless $firstix == $opix;
469 asm "op_sibling", $firstsiblix;
470 $op->B::OP::bsave($ix);
471 asm "op_first", $firstix;
472 } elsif ($name eq 'formline') {
473 $op->B::UNOP::bsave_fat($ix);
475 $op->B::OP::bsave($ix);
481 sub B::OP::bsave_fat {
483 my $siblix = $op->sibling->ix;
485 $op->B::OP::bsave_thin($ix);
486 asm "op_sibling", $siblix;
487 # asm "op_seq", -1; XXX don't allocate OPs piece by piece
490 sub B::UNOP::bsave_fat {
492 my $firstix = $op->first->ix;
494 $op->B::OP::bsave($ix);
495 asm "op_first", $firstix;
498 sub B::BINOP::bsave_fat {
500 my $last = $op->last;
501 my $lastix = $op->last->ix;
502 if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
503 asm "ldop", $lastix unless $lastix == $opix;
504 asm "op_targ", $last->targ;
507 $op->B::UNOP::bsave($ix);
508 asm "op_last", $lastix;
511 sub B::LOGOP::bsave {
513 my $otherix = $op->other->ix;
515 $op->B::UNOP::bsave($ix);
516 asm "op_other", $otherix;
521 my ($rrop, $rrarg, $rstart);
523 # my $pmnextix = $op->pmnext->ix; # XXX
526 if ($op->name eq 'subst') {
527 $rrop = "op_pmreplroot";
528 $rrarg = $op->pmreplroot->ix;
529 $rstart = $op->pmreplstart->ix;
530 } elsif ($op->name eq 'pushre') {
531 $rrop = "op_pmreplrootpo";
532 $rrarg = $op->pmreplroot;
534 $op->B::BINOP::bsave($ix);
535 asm "op_pmstashpv", pvix $op->pmstashpv;
537 $rrop = "op_pmreplrootgv";
538 $rrarg = $op->pmreplroot->ix;
539 $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
540 my $stashix = $op->pmstash->ix;
541 $op->B::BINOP::bsave($ix);
542 asm "op_pmstash", $stashix;
545 asm $rrop, $rrarg if $rrop;
546 asm "op_pmreplstart", $rstart if $rstart;
548 asm "op_pmflags", $op->pmflags;
549 asm "op_pmpermflags", $op->pmpermflags;
550 asm "op_pmdynflags", $op->pmdynflags;
551 # asm "op_pmnext", $pmnextix; # XXX
552 asm "newpv", pvstring $op->precomp;
558 my $svix = $op->sv->ix;
560 $op->B::OP::bsave($ix);
564 sub B::PADOP::bsave {
567 $op->B::OP::bsave($ix);
568 asm "op_padix", $op->padix;
573 $op->B::OP::bsave($ix);
574 return unless my $pv = $op->pv;
576 if ($op->name eq 'trans') {
577 asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
579 asm "newpv", pvstring $pv;
586 my $nextix = $op->nextop->ix;
587 my $lastix = $op->lastop->ix;
588 my $redoix = $op->redoop->ix;
590 $op->B::BINOP::bsave($ix);
591 asm "op_redoop", $redoix;
592 asm "op_nextop", $nextix;
593 asm "op_lastop", $lastix;
598 my $warnix = $cop->warnings->ix;
599 my $ioix = $cop->io->ix;
601 $cop->B::OP::bsave($ix);
602 asm "cop_stashpv", pvix $cop->stashpv;
603 asm "cop_file", pvix $cop->file;
605 my $stashix = $cop->stash->ix;
606 my $fileix = $cop->filegv->ix(1);
607 $cop->B::OP::bsave($ix);
608 asm "cop_stash", $stashix;
609 asm "cop_filegv", $fileix;
611 asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
612 asm "cop_seq", $cop->cop_seq;
613 asm "cop_arybase", $cop->arybase;
614 asm "cop_line", $cop->line;
615 asm "cop_warnings", $warnix;
621 my $ix = $optab{$$op};
622 defined($ix) ? $ix : do {
624 my @oplist = $op->oplist;
626 $ix = $_->ix while $_ = pop @oplist;
627 while ($_ = pop @cloop) {
628 asm "ldop", $optab{$$_};
629 asm "op_next", $optab{${$_->next}};
635 #################################################
639 if (($av=begin_av)->isa("B::AV")) {
642 next unless $_->FILE eq $0;
643 asm "push_begin", $_->ix;
647 next unless $_->FILE eq $0;
648 # XXX BEGIN { goto A while 1; A: }
649 for (my $op = $_->START; $$op; $op = $op->next) {
650 next unless $op->name eq 'require' ||
651 # this kludge needed for tests
652 $op->name eq 'gv' && do {
653 my $gv = class($op) eq 'SVOP' ?
655 (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
656 $$gv && $gv->NAME =~ /use_ok|plan/
658 asm "push_begin", $_->ix;
664 if (($av=init_av)->isa("B::AV")) {
666 next unless $_->FILE eq $0;
667 asm "push_init", $_->ix;
670 if (($av=end_av)->isa("B::AV")) {
672 next unless $_->FILE eq $0;
673 asm "push_end", $_->ix;
679 my ($head, $scan, $T_inhinc, $keep_syn);
684 *B::OP::bsave = *B::OP::bsave_fat;
685 *B::UNOP::bsave = *B::UNOP::bsave_fat;
686 *B::BINOP::bsave = *B::BINOP::bsave_fat;
687 *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
689 sub bwarn { print STDERR "Bytecode.pm: @_\n" }
693 *newasm = *endasm = sub { };
694 *asm = sub { print " @_\n" };
695 *nice = sub ($) { print "\n@_\n" };
698 $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
701 } elsif (/^-o(.*)$/) {
702 open STDOUT, ">$1" or die "open $1: $!";
703 } elsif (/^-f(.*)$/) {
705 } elsif (/^-s(.*)$/) {
706 $scan = length($1) ? $1 : $0;
709 # this is here for the testsuite
712 } elsif (/^-TF(.*)/) {
714 *B::COP::file = sub { $thatfile };
716 bwarn "Ignoring '$_' option";
722 or bwarn("cannot rescan '$_'"), next;
724 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
726 if (/\bgoto\b/ && !$keep_syn) {
727 bwarn "keeping the syntax tree: \"goto\" op found";
735 print $head if $head;
736 newasm sub { print @_ };
739 asm "main_start", main_start->opwalk;
740 asm "main_root", main_root->ix;
741 asm "main_cv", main_cv->ix;
742 asm "curpad", (comppadlist->ARRAY)[1]->ix;
744 asm "signal", cstring "__WARN__" # XXX
746 asm "incav", inc_gv->AV->ix if $T_inhinc;
748 asm "incav", inc_gv->AV->ix if $T_inhinc;
749 asm "dowarn", dowarn;
754 my $dh = *{defstash->NAME."::DATA"};
756 if (length (my $data = <$dh>)) {
772 B::Bytecode - Perl compiler's bytecode backend
776 B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
780 Compiles a Perl script into a bytecode format that could be loaded
781 later by the ByteLoader module and executed as a regular Perl script.
785 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
795 Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
796 other files (ex. C<use Foo;>) are saved.
800 prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
804 keep the syntax tree - it is stripped by default.
806 =item B<-o>I<outfile>
808 put the bytecode in <outfile> instead of dumping it to STDOUT.
812 scan the script for C<# line ..> directives and for <goto LABEL>
813 expressions. When gotos are found keep the syntax tree.
823 C<BEGIN { goto A: while 1; A: }> won't even compile.
827 C<?...?> and C<reset> do not work as expected.
831 variables in C<(?{ ... })> constructs are not properly scoped.
835 scripts that use source filters will fail miserably.
841 There are also undocumented bugs and options.
843 THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
847 Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
848 modified by Benjamin Stuhl <sho_pi@hotmail.com>.
850 Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.