-# Bytecode.pm
-#
-# Copyright (c) 1996-1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B::Bytecode;
+# B::Bytecode.pm
+# Copyright (c) 2003 Enache Adrian. All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# Based on the original Bytecode.pm module written by Malcolm Beattie.
-our $VERSION = '1.00';
+package B::Bytecode;
use strict;
-use Carp;
-use B qw(main_cv main_root main_start comppadlist
- class peekop walkoptree svref_2object cstring walksymtable
- init_av begin_av end_av
- SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
- SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
- GVf_IMPORTED_SV SVTYPEMASK
- );
-use B::Asmdata qw(@optype @specialsv_name);
-use B::Assembler qw(newasm endasm assemble);
-
-my %optype_enum;
-my $i;
-for ($i = 0; $i < @optype; $i++) {
- $optype_enum{$optype[$i]} = $i;
-}
-
-# Following is SVf_POK|SVp_POK
-# XXX Shouldn't be hardwired
-sub POK () { SVf_POK|SVp_POK }
-
-# Following is SVf_IOK|SVp_IOK
-# XXX Shouldn't be hardwired
-sub IOK () { SVf_IOK|SVp_IOK }
-
-# Following is SVf_NOK|SVp_NOK
-# XXX Shouldn't be hardwired
-sub NOK () { SVf_NOK|SVp_NOK }
-
-# nonexistant flags (see B::GV::bytecode for usage)
-sub GVf_IMPORTED_IO () { 0; }
-sub GVf_IMPORTED_FORM () { 0; }
-
-my ($verbose, $no_assemble, $debug_bc, $debug_cv);
-my @packages; # list of packages to compile
-
-sub asm (@) { # print replacement that knows about assembling
- if ($no_assemble) {
- print @_;
- } else {
- my $buf = join '', @_;
- assemble($_) for (split /\n/, $buf);
- }
-}
+use Config;
+use B qw(class main_cv main_root main_start cstring comppadlist
+ defstash curstash begin_av init_av end_av inc_gv warnhook diehook
+ dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
+ OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
+use B::Asmdata qw(@specialsv_name);
+use B::Assembler qw(asm newasm endasm);
+no warnings; # XXX
+
+#################################################
+
+my $ithreads = $Config{'useithreads'} eq 'define';
+my ($varix, $opix, $savebegins);
+my %strtab = (0,0);
+my %svtab = (0,0);
+my %optab = (0,0);
+my %spectab = (0,0);
+my %walked;
+my @cloop;
+my $tix = 1;
+sub asm;
+sub nice ($) { }
+my %files;
+
+#################################################
-sub asmf (@) { # printf replacement that knows about assembling
- if ($no_assemble) {
- printf shift(), @_;
- } else {
- my $format = shift;
- my $buf = sprintf $format, @_;
- assemble($_) for (split /\n/, $buf);
- }
+sub pvstring {
+ my $pv = shift;
+ defined($pv) ? cstring ($pv."\0") : "\"\"";
}
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($compress_nullops, $omit_seq, $bypass_nullops);
-my %optimise = (compress_nullops => \$compress_nullops,
- omit_sequence_numbers => \$omit_seq,
- bypass_nullops => \$bypass_nullops);
-
-my $strip_syntree; # this is left here in case stripping the
- # syntree ever becomes safe again
- # -- BKS, June 2000
-
-my $nextix = 0;
-my %symtable; # maps object addresses to object indices.
- # Filled in at allocation (newsv/newop) time.
-
-my %saved; # maps object addresses (for SVish classes) to "saved yet?"
- # flag. Set at FOO::bytecode time usually by SV::bytecode.
- # Manipulated via saved(), mark_saved(), unmark_saved().
-
-my %strtable; # maps shared strings to object indices
- # Filled in at allocation (pvix) time
-
-my $svix = -1; # we keep track of when the sv register contains an element
- # of the object table to avoid unnecessary repeated
- # consecutive ldsv instructions.
-
-my $opix = -1; # Ditto for the op register.
-
-sub ldsv {
- my $ix = shift;
- if ($ix != $svix) {
- asm "ldsv $ix\n";
- $svix = $ix;
+sub pvix {
+ my $str = pvstring shift;
+ my $ix = $strtab{$str};
+ defined($ix) ? $ix : do {
+ asm "newpv", $str;
+ asm "stpv", $strtab{$str} = $tix;
+ $tix++;
}
}
-sub stsv {
- my $ix = shift;
- asm "stsv $ix\n";
- $svix = $ix;
-}
-
-sub set_svix {
- $svix = shift;
-}
-
-sub ldop {
- my $ix = shift;
- if ($ix != $opix) {
- asm "ldop $ix\n";
- $opix = $ix;
+sub B::OP::ix {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ nice '['.$op->name.']';
+ asm "newop", $op->size;
+ asm "stop", $optab{$$op} = $opix = $ix = $tix++;
+ $op->bsave($ix);
+ $ix;
}
}
-sub stop {
- my $ix = shift;
- asm "stop $ix\n";
- $opix = $ix;
+sub B::SPECIAL::ix {
+ my $spec = shift;
+ my $ix = $spectab{$$spec};
+ defined($ix) ? $ix : do {
+ nice '['.$specialsv_name[$$spec].']';
+ asm "ldspecsv", $$spec;
+ asm "stsv", $spectab{$$spec} = $varix = $tix;
+ $tix++;
+ }
}
-sub set_opix {
- $opix = shift;
+sub B::SV::ix {
+ my $sv = shift;
+ my $ix = $svtab{$$sv};
+ defined($ix) ? $ix : do {
+ nice '['.class($sv).']';
+ asm "newsv", $sv->SvTYPE;
+ asm "stsv", $svtab{$$sv} = $varix = $ix = $tix++;
+ $sv->bsave($ix);
+ $ix;
+ }
+}
+
+sub B::GV::ix {
+ my ($gv,$desired) = @_;
+ my $ix = $svtab{$$gv};
+ defined($ix) ? $ix : do {
+ if ($gv->GP) {
+ my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
+ nice "[GV]";
+ my $name = $gv->STASH->NAME . "::" . $gv->NAME;
+ asm "gv_fetchpv", cstring $name;
+ asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
+ asm "sv_flags", $gv->FLAGS;
+ asm "sv_refcnt", $gv->REFCNT;
+ asm "xgv_flags", $gv->GvFLAGS;
+
+ asm "gp_refcnt", $gv->GvREFCNT;
+ asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
+ return $ix
+ unless $desired || desired $gv;
+ $svix = $gv->SV->ix;
+ $avix = $gv->AV->ix;
+ $hvix = $gv->HV->ix;
+
+ # TODO: kludge
+ my $cv = $gv->CV;
+ $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
+ my $form = $gv->FORM;
+ $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
+
+ $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; # XXX
+
+ nice "-GV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "gp_sv", $svix;
+ asm "gp_av", $avix;
+ asm "gp_hv", $hvix;
+ asm "gp_cv", $cvix;
+ asm "gp_io", $ioix;
+ asm "gp_cvgen", $gv->CVGEN;
+ asm "gp_form", $formix;
+ asm "gp_file", pvix $gv->FILE;
+ asm "gp_line", $gv->LINE;
+ asm "formfeed", $svix if $name eq "main::\cL";
+ } else {
+ nice "[GV]";
+ asm "newsv", SVt_PVGV;
+ asm "stsv", $svtab{$$gv} = $varix = $ix = $tix++;
+ my $stashix = $gv->STASH->ix;
+ $gv->B::PVMG::bsave($ix);
+ asm "xgv_flags", $gv->GvFLAGS;
+ asm "xgv_stash", $stashix;
+ }
+ $ix;
+ }
}
-sub pvstring {
- my $str = shift;
- if (defined($str)) {
- return cstring($str . "\0");
- } else {
- return '""';
+sub B::HV::ix {
+ my $hv = shift;
+ my $ix = $svtab{$$hv};
+ defined($ix) ? $ix : do {
+ my ($ix,$i,@array);
+ my $name = $hv->NAME;
+ if ($name) {
+ nice "[STASH]";
+ asm "gv_stashpv", cstring $name;
+ asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
+ asm "xhv_name", pvix $name;
+ # my $pmrootix = $hv->PMROOT->ix; # XXX
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ # asm "xhv_pmroot", $pmrootix; # XXX
+ } else {
+ nice "[HV]";
+ asm "newsv", SVt_PVHV;
+ asm "stsv", $svtab{$$hv} = $varix = $ix = $tix++;
+ my $stashix = $hv->SvSTASH->ix;
+ for (@array = $hv->ARRAY) {
+ next if $i = not $i;
+ $_ = $_->ix;
+ }
+ nice "-HV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
+ for @array;
+ asm "xnv", $hv->NVX;
+ asm "xmg_stash", $stashix;
+ }
+ asm "sv_refcnt", $hv->REFCNT;
+ asm "sv_flags", $hv->FLAGS;
+ $ix;
}
}
-sub nv {
- # print full precision
- my $str = sprintf "%.40f", $_[0];
- $str =~ s/0+$//; # remove trailing zeros
- $str =~ s/\.$/.0/;
- return $str;
+sub B::NULL::ix {
+ my $sv = shift;
+ $$sv ? $sv->B::SV::ix : 0;
}
-sub saved { $saved{${$_[0]}} }
-sub mark_saved { $saved{${$_[0]}} = 1 }
-sub unmark_saved { $saved{${$_[0]}} = 0 }
+sub B::NULL::opwalk { 0 }
-sub debug { $debug_bc = shift }
+#################################################
-sub pvix { # save a shared PV (mainly for COPs)
- return $strtable{$_[0]} if defined($strtable{$_[0]});
- asmf "newpv %s\n", pvstring($_[0]);
- my $ix = $nextix++;
- $strtable{$_[0]} = $ix;
- asmf "stpv %d\n", $ix;
- return $ix;
-}
+sub B::NULL::bsave {
+ my ($sv,$ix) = @_;
-sub B::OBJECT::nyi {
- my $obj = shift;
- warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
- class($obj), $$obj);
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "sv_refcnt", $sv->REFCNT;
+ asm "sv_flags", $sv->FLAGS;
}
-#
-# objix may stomp on the op register (for op objects)
-# or the sv register (for SV objects)
-#
-sub B::OBJECT::objix {
- my $obj = shift;
- my $ix = $symtable{$$obj};
- if (defined($ix)) {
- return $ix;
- } else {
- $obj->newix($nextix);
- return $symtable{$$obj} = $nextix++;
- }
-}
+sub B::SV::bsave;
+ *B::SV::bsave = *B::NULL::bsave;
-sub B::SV::newix {
- my ($sv, $ix) = @_;
- asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv);
- stsv($ix);
+sub B::RV::bsave {
+ my ($sv,$ix) = @_;
+ my $rvix = $sv->RV->ix;
+ $sv->B::NULL::bsave($ix);
+ asm "xrv", $rvix;
}
-sub B::GV::newix {
- my ($gv, $ix) = @_;
- my $gvname = $gv->NAME;
- my $name = cstring($gv->STASH->NAME . "::" . $gvname);
- asm "gv_fetchpv $name\n";
- stsv($ix);
+sub B::PV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "newpv", pvstring $sv->PVBM;
+ asm "xpv";
}
-sub B::HV::newix {
- my ($hv, $ix) = @_;
- my $name = $hv->NAME;
- if ($name) {
- # It's a stash
- asmf "gv_stashpv %s\n", cstring($name);
- stsv($ix);
- } else {
- # It's an ordinary HV. Fall back to ordinary newix method
- $hv->B::SV::newix($ix);
- }
+sub B::IV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xiv", $sv->IVX;
}
-sub B::SPECIAL::newix {
- my ($sv, $ix) = @_;
- # Special case. $$sv is not the address of the SV but an
- # index into svspecialsv_list.
- asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
- stsv($ix);
+sub B::NV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xnv", sprintf "%.40g", $sv->NVX;
}
-sub B::OP::newix {
- my ($op, $ix) = @_;
- my $class = class($op);
- my $typenum = $optype_enum{$class};
- croak("OP::newix: can't understand class $class") unless defined($typenum);
- asm "newop $typenum\t# $class\n";
- stop($ix);
+sub B::PVIV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->POK ?
+ $sv->B::PV::bsave($ix):
+ $sv->ROK ?
+ $sv->B::RV::bsave($ix):
+ $sv->B::NULL::bsave($ix);
+ asm "xiv", !$ithreads && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
+ "0 but true" : $sv->IVX;
}
-sub B::OP::walkoptree_debug {
- my $op = shift;
- warn(sprintf("walkoptree: %s\n", peekop($op)));
+sub B::PVNV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVIV::bsave($ix);
+ asm "xnv", sprintf "%.40g", $sv->NVX;
}
-sub B::OP::bytecode {
- my $op = shift;
- my $next = $op->next;
- my $nextix;
- my $sibix = $op->sibling->objix unless $strip_syntree;
- my $ix = $op->objix;
- my $type = $op->type;
-
- if ($bypass_nullops) {
- $next = $next->next while $$next && $next->type == 0;
+sub B::PVMG::domagic {
+ my ($sv,$ix) = @_;
+ nice '-MAGICAL-';
+ my @mglist = $sv->MAGIC;
+ my (@mgix, @namix);
+ for (@mglist) {
+ push @mgix, $_->OBJ->ix;
+ push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
}
- $nextix = $next->objix;
-
- asmf "# %s\n", peekop($op) if $debug_bc;
- ldop($ix);
- asm "op_next $nextix\n";
- asm "op_sibling $sibix\n" unless $strip_syntree;
- asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
- asmf("op_seq %d\n", $op->seq) unless $omit_seq;
- if ($type || !$compress_nullops) {
- asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
- $op->targ, $op->flags, $op->private;
- }
-}
-sub B::UNOP::bytecode {
- my $op = shift;
- my $firstix = $op->first->objix unless $strip_syntree;
- $op->B::OP::bytecode;
- if (($op->type || !$compress_nullops) && !$strip_syntree) {
- asm "op_first $firstix\n";
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ for (@mglist) {
+ asm "sv_magic", cstring $_->TYPE;
+ asm "mg_obj", shift @mgix;
+ my $length = $_->LENGTH;
+ if ($length == B::HEf_SVKEY) {
+ asm "mg_namex", shift @namix;
+ } elsif ($length) {
+ asm "newpv", pvstring $_->PTR;
+ asm "mg_name";
+ }
}
}
-sub B::LOGOP::bytecode {
- my $op = shift;
- my $otherix = $op->other->objix;
- $op->B::UNOP::bytecode;
- asm "op_other $otherix\n";
+sub B::PVMG::bsave {
+ my ($sv,$ix) = @_;
+ my $stashix = $sv->SvSTASH->ix;
+ $sv->B::PVNV::bsave($ix);
+ asm "xmg_stash", $stashix;
+ $sv->domagic($ix) if $sv->MAGICAL;
+}
+
+sub B::PVLV::bsave {
+ my ($sv,$ix) = @_;
+ my $targix = $sv->TARG->ix;
+ $sv->B::PVMG::bsave($ix);
+ asm "xlv_targ", $targix;
+ asm "xlv_targoff", $sv->TARGOFF;
+ asm "xlv_targlen", $sv->TARGLEN;
+ asm "xlv_type", $sv->TYPE;
+
+}
+
+sub B::BM::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVMG::bsave($ix);
+ asm "xpv_cur", $sv->CUR;
+ asm "xbm_useful", $sv->USEFUL;
+ asm "xbm_previous", $sv->PREVIOUS;
+ asm "xbm_rare", $sv->RARE;
+}
+
+sub B::IO::bsave {
+ my ($io,$ix) = @_;
+ my $topix = $io->TOP_GV->ix;
+ my $fmtix = $io->FMT_GV->ix;
+ my $bottomix = $io->BOTTOM_GV->ix;
+ $io->B::PVMG::bsave($ix);
+ asm "xio_lines", $io->LINES;
+ asm "xio_page", $io->PAGE;
+ asm "xio_page_len", $io->PAGE_LEN;
+ asm "xio_lines_left", $io->LINES_LEFT;
+ asm "xio_top_name", pvix $io->TOP_NAME;
+ asm "xio_top_gv", $topix;
+ asm "xio_fmt_name", pvix $io->FMT_NAME;
+ asm "xio_fmt_gv", $fmtix;
+ asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
+ asm "xio_bottom_gv", $bottomix;
+ asm "xio_subprocess", $io->SUBPROCESS;
+ asm "xio_type", ord $io->IoTYPE;
+ # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
+}
+
+sub B::CV::bsave {
+ my ($cv,$ix) = @_;
+ my $stashix = $cv->STASH->ix;
+ my $startix = $cv->START->opwalk;
+ my $rootix = $cv->ROOT->ix;
+ my $gvix = $cv->GV->ix;
+ my $padlistix = $cv->PADLIST->ix;
+ my $outsideix = $cv->OUTSIDE->ix;
+ my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
+
+ $cv->B::PVMG::bsave($ix);
+ asm "xcv_stash", $stashix;
+ asm "xcv_start", $startix;
+ asm "xcv_root", $rootix;
+ asm "xcv_xsubany", $constix;
+ asm "xcv_gv", $gvix;
+ asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
+ asm "xcv_padlist", $padlistix;
+ asm "xcv_outside", $outsideix;
+ asm "xcv_flags", $cv->CvFLAGS;
+ asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
+ asm "xcv_depth", $cv->DEPTH;
+}
+
+sub B::FM::bsave {
+ my ($form,$ix) = @_;
+
+ $form->B::CV::bsave($ix);
+ asm "xfm_lines", $form->LINES;
+}
+
+sub B::AV::bsave {
+ my ($av,$ix) = @_;
+ return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
+ my @array = $av->ARRAY;
+ $_ = $_->ix for @array;
+ my $stashix = $av->SvSTASH->ix;
+
+ nice "-AV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "av_extend", $av->MAX;
+ asm "av_pushx", $_ for @array;
+ asm "sv_refcnt", $av->REFCNT;
+ asm "sv_flags", $av->FLAGS;
+ asm "xav_flags", $av->AvFLAGS;
+ asm "xmg_stash", $stashix;
+}
+
+sub B::GV::desired {
+ my $gv = shift;
+ my ($cv, $form);
+ $files{$gv->FILE} && $gv->LINE
+ || ${$cv = $gv->CV} && $files{$cv->FILE}
+ || ${$form = $gv->FORM} && $files{$form->FILE}
}
-sub B::SVOP::bytecode {
- my $op = shift;
- my $sv = $op->sv;
- my $svix = $sv->objix;
- $op->B::OP::bytecode;
- asm "op_sv $svix\n";
- $sv->bytecode;
+sub B::HV::bwalk {
+ my $hv = shift;
+ return if $walked{$$hv}++;
+ my %stash = $hv->ARRAY;
+ while (my($k,$v) = each %stash) {
+ if ($v->SvTYPE == SVt_PVGV) {
+ my $hash = $v->HV;
+ if ($$hash && $hash->NAME) {
+ $hash->bwalk;
+ }
+ $v->ix(1) if desired $v;
+ } else {
+ nice "[prototype]";
+ asm "gv_fetchpv", cstring $hv->NAME . "::$k";
+ asm "stsv", $svtab{$$v} = $varix = $tix;
+ $v->bsave($tix++);
+ }
+ }
}
-sub B::PADOP::bytecode {
- my $op = shift;
- my $padix = $op->padix;
- $op->B::OP::bytecode;
- asm "op_padix $padix\n";
-}
+######################################################
-sub B::PVOP::bytecode {
- my $op = shift;
- my $pv = $op->pv;
- $op->B::OP::bytecode;
- #
- # This would be easy except that OP_TRANS uses a PVOP to store an
- # endian-dependent array of 256 shorts instead of a plain string.
- #
- if ($op->name eq "trans") {
- my @shorts = unpack("s256", $pv); # assembler handles endianness
- asm "op_pv_tr ", join(",", @shorts), "\n";
- } else {
- asmf "newpv %s\nop_pv\n", pvstring($pv);
- }
-}
-sub B::BINOP::bytecode {
- my $op = shift;
- my $lastix = $op->last->objix unless $strip_syntree;
- $op->B::UNOP::bytecode;
- if (($op->type || !$compress_nullops) && !$strip_syntree) {
- asm "op_last $lastix\n";
+sub B::OP::bsave_thin {
+ my ($op, $ix) = @_;
+ my $next = $op->next;
+ my $nextix = $optab{$$next};
+ $nextix = 0, push @cloop, $op unless defined $nextix;
+ if ($ix != $opix) {
+ nice '-'.$op->name.'-',
+ asm "ldop", $opix = $ix;
}
+ asm "op_type", $op->type;
+ asm "op_next", $nextix;
+ asm "op_targ", $op->targ if $op->type; # tricky
+ asm "op_flags", $op->flags;
+ asm "op_private", $op->private;
}
-sub B::LOOP::bytecode {
- my $op = shift;
- my $redoopix = $op->redoop->objix;
- my $nextopix = $op->nextop->objix;
- my $lastopix = $op->lastop->objix;
- $op->B::LISTOP::bytecode;
- asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
-}
+sub B::OP::bsave;
+ *B::OP::bsave = *B::OP::bsave_thin;
-sub B::COP::bytecode {
- my $op = shift;
- my $file = $op->file;
- my $line = $op->line;
- if ($debug_bc) { # do this early to aid debugging
- asmf "# line %s:%d\n", $file, $line;
- }
- my $stashpv = $op->stashpv;
- my $warnings = $op->warnings;
- my $warningsix = $warnings->objix;
- my $labelix = pvix($op->label);
- my $stashix = pvix($stashpv);
- my $fileix = pvix($file);
- $warnings->bytecode;
- $op->B::OP::bytecode;
- asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase;
-cop_label %d
-cop_stashpv %d
-cop_seq %d
-cop_file %d
-cop_arybase %d
-cop_line $line
-cop_warnings $warningsix
-EOT
-}
-
-sub B::PMOP::bytecode {
- my $op = shift;
- my $replroot = $op->pmreplroot;
- my $replrootix = $replroot->objix;
- my $replstartix = $op->pmreplstart->objix;
- my $opname = $op->name;
- # pmnext is corrupt in some PMOPs (see misc.t for example)
- #my $pmnextix = $op->pmnext->objix;
-
- if ($$replroot) {
- # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
- # argument to a split) stores a GV in op_pmreplroot instead
- # of a substitution syntax tree. We don't want to walk that...
- if ($opname eq "pushre") {
- $replroot->bytecode;
- } else {
- walkoptree($replroot, "bytecode");
- }
- }
- $op->B::LISTOP::bytecode;
- if ($opname eq "pushre") {
- asmf "op_pmreplrootgv $replrootix\n";
+sub B::UNOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ my $flags = $op->flags;
+ my $first = $op->first;
+ my $firstix =
+ $name =~ /fl[io]p/
+ # that's just neat
+ || (!$ithreads && $name =~ /regcomp/)
+ # trick for /$a/o in pp_regcomp
+ || $name eq 'rv2sv'
+ && $op->flags & OPf_MOD
+ && $op->private & OPpLVAL_INTRO
+ # change #18774 made my life hard
+ ? $first->ix
+ : 0;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+}
+
+sub B::BINOP::bsave;
+ *B::BINOP::bsave = *B::OP::bsave;
+
+# deal with sort / formline
+
+sub B::LISTOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ if ($name eq 'sort' && $op->flags & (OPf_SPECIAL|OPf_STACKED)) {
+ my $first = $op->first;
+ my $firstix = $first->ix;
+ my $firstsiblix = do {
+ local *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ local *B::LISTOP::bsave = *B::UNOP::bsave_fat;
+ $first->sibling->ix;
+ };
+ asm "ldop", $firstix unless $firstix == $opix;
+ asm "op_sibling", $firstsiblix;
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+ } elsif ($name eq 'formline') {
+ $op->B::UNOP::bsave_fat($ix);
} else {
- asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+ $op->B::OP::bsave($ix);
}
- my $re = pvstring($op->precomp);
- # op_pmnext omitted since a perl bug means it's sometime corrupt
- asmf <<"EOT", $op->pmflags, $op->pmpermflags;
-op_pmflags 0x%x
-op_pmpermflags 0x%x
-newpv $re
-pregcomp
-EOT
}
-sub B::SV::bytecode {
- my $sv = shift;
- return if saved($sv);
- my $ix = $sv->objix;
- my $refcnt = $sv->REFCNT;
- my $flags = sprintf("0x%x", $sv->FLAGS);
- ldsv($ix);
- asm "sv_refcnt $refcnt\nsv_flags $flags\n";
- mark_saved($sv);
-}
+# fat versions
-sub B::PV::bytecode {
- my $sv = shift;
- return if saved($sv);
- $sv->B::SV::bytecode;
- asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
-}
-
-sub B::IV::bytecode {
- my $sv = shift;
- return if saved($sv);
- my $iv = $sv->IVX;
- $sv->B::SV::bytecode;
- asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
-}
+sub B::OP::bsave_fat {
+ my ($op, $ix) = @_;
+ my $siblix = $op->sibling->ix;
-sub B::NV::bytecode {
- my $sv = shift;
- return if saved($sv);
- $sv->B::SV::bytecode;
- asmf "xnv %s\n", nv($sv->NVX);
+ $op->B::OP::bsave_thin($ix);
+ asm "op_sibling", $siblix;
+ # asm "op_seq", -1; XXX don't allocate OPs piece by piece
}
-sub B::RV::bytecode {
- my $sv = shift;
- return if saved($sv);
- my $rv = $sv->RV;
- my $rvix = $rv->objix;
- $rv->bytecode;
- $sv->B::SV::bytecode;
- asm "xrv $rvix\n";
-}
+sub B::UNOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $firstix = $op->first->ix;
-sub B::PVIV::bytecode {
- my $sv = shift;
- return if saved($sv);
- my $iv = $sv->IVX;
- $sv->B::PV::bytecode;
- asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
}
-sub B::PVNV::bytecode {
- my $sv = shift;
- my $flag = shift || 0;
- # The $flag argument is passed through PVMG::bytecode by BM::bytecode
- # and AV::bytecode and indicates special handling. $flag = 1 is used by
- # BM::bytecode and means that we should ensure we save the whole B-M
- # table. It consists of 257 bytes (256 char array plus a final \0)
- # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
- # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
- # call SV::bytecode instead of saving PV and calling NV::bytecode since
- # PV/NV/IV stuff is different for AVs.
- return if saved($sv);
- if ($flag == 2) {
- $sv->B::SV::bytecode;
- } else {
- my $pv = $sv->PV;
- $sv->B::IV::bytecode;
- asmf "xnv %s\n", nv($sv->NVX);
- if ($flag == 1) {
- $pv .= "\0" . $sv->TABLE;
- asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
- } else {
- asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
- }
+sub B::BINOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $last = $op->last;
+ my $lastix = $op->last->ix;
+ if ($] < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
+ asm "ldop", $lastix unless $lastix == $opix;
+ asm "op_targ", $last->targ;
}
-}
-sub B::PVMG::bytecode {
- my ($sv, $flag) = @_;
- # See B::PVNV::bytecode for an explanation of $flag.
- return if saved($sv);
- # XXX We assume SvSTASH is already saved and don't save it later ourselves
- my $stashix = $sv->SvSTASH->objix;
- my @mgchain = $sv->MAGIC;
- my (@mgobjix, $mg);
- #
- # We need to traverse the magic chain and get objix for each OBJ
- # field *before* we do B::PVNV::bytecode since objix overwrites
- # the sv register. However, we need to write the magic-saving
- # bytecode *after* B::PVNV::bytecode since sv isn't initialised
- # to refer to $sv until then.
- #
- @mgobjix = map($_->OBJ->objix, @mgchain);
- $sv->B::PVNV::bytecode($flag);
- asm "xmg_stash $stashix\n";
- foreach $mg (@mgchain) {
- asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
- cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
- }
+ $op->B::UNOP::bsave($ix);
+ asm "op_last", $lastix;
}
-sub B::PVLV::bytecode {
- my $sv = shift;
- return if saved($sv);
- $sv->B::PVMG::bytecode;
- asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
-xlv_targoff %d
-xlv_targlen %d
-xlv_type %s
-EOT
-}
+sub B::LOGOP::bsave {
+ my ($op,$ix) = @_;
+ my $otherix = $op->other->ix;
-sub B::BM::bytecode {
- my $sv = shift;
- return if saved($sv);
- # See PVNV::bytecode for an explanation of what the argument does
- $sv->B::PVMG::bytecode(1);
- asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
- $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
+ $op->B::UNOP::bsave($ix);
+ asm "op_other", $otherix;
}
-sub empty_gv { # is a GV empty except for imported stuff?
- my $gv = shift;
+sub B::PMOP::bsave {
+ my ($op,$ix) = @_;
+ my ($rrop, $rrarg, $rstart);
- return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL
- my @subfield_names = qw(AV HV CV FORM IO);
- @subfield_names = grep {;
- no strict 'refs';
- !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()};
- } @subfield_names;
- return scalar @subfield_names;
-}
+ # my $pmnextix = $op->pmnext->ix; # XXX
-sub B::GV::bytecode {
- my $gv = shift;
- return if saved($gv);
- return unless grep { $_ eq $gv->STASH->NAME; } @packages;
- return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt
- my $ix = $gv->objix;
- mark_saved($gv);
- ldsv($ix);
- asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
-sv_flags 0x%x
-xgv_flags 0x%x
-EOT
- my $refcnt = $gv->REFCNT;
- asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
- return if $gv->is_empty;
- asmf <<"EOT", $gv->LINE, pvix($gv->FILE);
-gp_line %d
-gp_file %d
-EOT
- my $gvname = $gv->NAME;
- my $name = cstring($gv->STASH->NAME . "::" . $gvname);
- my $egv = $gv->EGV;
- my $egvix = $egv->objix;
- my $gvrefcnt = $gv->GvREFCNT;
- asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
- if ($gvrefcnt > 1 && $ix != $egvix) {
- asm "gp_share $egvix\n";
- } else {
- if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
- my $i;
- my @subfield_names = qw(SV AV HV CV FORM IO);
- @subfield_names = grep {;
- no strict 'refs';
- !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->());
- } @subfield_names;
- my @subfields = map($gv->$_(), @subfield_names);
- my @ixes = map($_->objix, @subfields);
- # Reset sv register for $gv
- ldsv($ix);
- for ($i = 0; $i < @ixes; $i++) {
- asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
- }
- # Now save all the subfields
- my $sv;
- foreach $sv (@subfields) {
- $sv->bytecode;
- }
+ if ($ithreads) {
+ if ($op->name eq 'subst') {
+ $rrop = "op_pmreplroot";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix;
+ } elsif ($op->name eq 'pushre') {
+ $rrop = "op_pmreplrootpo";
+ $rrarg = $op->pmreplroot;
}
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstashpv", pvix $op->pmstashpv;
+ } else {
+ $rrop = "op_pmreplrootgv";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
+ my $stashix = $op->pmstash->ix;
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstash", $stashix;
}
+
+ asm $rrop, $rrarg if $rrop;
+ asm "op_pmreplstart", $rstart if $rstart;
+
+ asm "op_pmflags", $op->pmflags;
+ asm "op_pmpermflags", $op->pmpermflags;
+ asm "op_pmdynflags", $op->pmdynflags;
+ # asm "op_pmnext", $pmnextix; # XXX
+ asm "newpv", pvstring $op->precomp;
+ asm "pregcomp";
}
-sub B::HV::bytecode {
- my $hv = shift;
- return if saved($hv);
- mark_saved($hv);
- my $name = $hv->NAME;
- my $ix = $hv->objix;
- if (!$name) {
- # It's an ordinary HV. Stashes have NAME set and need no further
- # saving beyond the gv_stashpv that $hv->objix already ensures.
- my @contents = $hv->ARRAY;
- my ($i, @ixes);
- for ($i = 1; $i < @contents; $i += 2) {
- push(@ixes, $contents[$i]->objix);
- }
- for ($i = 1; $i < @contents; $i += 2) {
- $contents[$i]->bytecode;
- }
- ldsv($ix);
- for ($i = 0; $i < @contents; $i += 2) {
- asmf("newpv %s\nhv_store %d\n",
- pvstring($contents[$i]), $ixes[$i / 2]);
- }
- asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
- }
+sub B::SVOP::bsave {
+ my ($op,$ix) = @_;
+ my $svix = $op->sv->ix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_sv", $svix;
}
-sub B::AV::bytecode {
- my $av = shift;
- return if saved($av);
- my $ix = $av->objix;
- my $fill = $av->FILL;
- my $max = $av->MAX;
- my (@array, @ixes);
- if ($fill > -1) {
- @array = $av->ARRAY;
- @ixes = map($_->objix, @array);
- my $sv;
- foreach $sv (@array) {
- $sv->bytecode;
- }
- }
- # See PVNV::bytecode for the meaning of the flag argument of 2.
- $av->B::PVMG::bytecode(2);
- # Recover sv register and set AvMAX and AvFILL to -1 (since we
- # create an AV with NEWSV and SvUPGRADE rather than doing newAV
- # which is what sets AvMAX and AvFILL.
- ldsv($ix);
- asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
- asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
- if ($fill > -1) {
- my $elix;
- foreach $elix (@ixes) {
- asm "av_push $elix\n";
- }
- } else {
- if ($max > -1) {
- asm "av_extend $max\n";
- }
- }
- asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
-}
-
-sub B::CV::bytecode {
- my $cv = shift;
- return if saved($cv);
- return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV);
- my $fileix = pvix($cv->FILE);
- my $ix = $cv->objix;
- $cv->B::PVMG::bytecode;
- my $i;
- my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
- my @subfields = map($cv->$_(), @subfield_names);
- my @ixes = map($_->objix, @subfields);
- # Save OP tree from CvROOT (first element of @subfields)
- my $root = shift @subfields;
- if ($$root) {
- walkoptree($root, "bytecode");
- }
- # Reset sv register for $cv (since above ->objix calls stomped on it)
- ldsv($ix);
- for ($i = 0; $i < @ixes; $i++) {
- asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
- }
- asmf "xcv_depth %d\nxcv_flags 0x%x\nxcv_outside_seq 0x%x",
- $cv->DEPTH, $cv->CvFLAGS, $cv->OUTSIDE_SEQ;
- asmf "xcv_file %d\n", $fileix;
- # Now save all the subfields (except for CvROOT which was handled
- # above) and CvSTART (now the initial element of @subfields).
- shift @subfields; # bye-bye CvSTART
- my $sv;
- foreach $sv (@subfields) {
- $sv->bytecode;
- }
+sub B::PADOP::bsave {
+ my ($op,$ix) = @_;
+
+ $op->B::OP::bsave($ix);
+ asm "op_padix", $op->padix;
}
-sub B::IO::bytecode {
- my $io = shift;
- return if saved($io);
- my $ix = $io->objix;
- my $top_gv = $io->TOP_GV;
- my $top_gvix = $top_gv->objix;
- my $fmt_gv = $io->FMT_GV;
- my $fmt_gvix = $fmt_gv->objix;
- my $bottom_gv = $io->BOTTOM_GV;
- my $bottom_gvix = $bottom_gv->objix;
-
- $io->B::PVMG::bytecode;
- ldsv($ix);
- asm "xio_top_gv $top_gvix\n";
- asm "xio_fmt_gv $fmt_gvix\n";
- asm "xio_bottom_gv $bottom_gvix\n";
- my $field;
- foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
- asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
- }
- foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
- asmf "xio_%s %d\n", lc($field), $io->$field();
+sub B::PVOP::bsave {
+ my ($op,$ix) = @_;
+ $op->B::OP::bsave($ix);
+ return unless my $pv = $op->pv;
+
+ if ($op->name eq 'trans') {
+ asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
+ } else {
+ asm "newpv", pvstring $pv;
+ asm "op_pv";
}
- asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
- $top_gv->bytecode;
- $fmt_gv->bytecode;
- $bottom_gv->bytecode;
}
-sub B::SPECIAL::bytecode {
- # nothing extra needs doing
+sub B::LOOP::bsave {
+ my ($op,$ix) = @_;
+ my $nextix = $op->nextop->ix;
+ my $lastix = $op->lastop->ix;
+ my $redoix = $op->redoop->ix;
+
+ $op->B::BINOP::bsave($ix);
+ asm "op_redoop", $redoix;
+ asm "op_nextop", $nextix;
+ asm "op_lastop", $lastix;
}
-sub bytecompile_object {
- for my $sv (@_) {
- svref_2object($sv)->bytecode;
+sub B::COP::bsave {
+ my ($cop,$ix) = @_;
+ my $warnix = $cop->warnings->ix;
+ my $ioix = $cop->io->ix;
+ if ($ithreads) {
+ $cop->B::OP::bsave($ix);
+ asm "cop_stashpv", pvix $cop->stashpv;
+ asm "cop_file", pvix $cop->file;
+ } else {
+ my $stashix = $cop->stash->ix;
+ my $fileix = $cop->filegv->ix(1);
+ $cop->B::OP::bsave($ix);
+ asm "cop_stash", $stashix;
+ asm "cop_filegv", $fileix;
}
+ asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
+ asm "cop_seq", $cop->cop_seq;
+ asm "cop_arybase", $cop->arybase;
+ asm "cop_line", $cop->line;
+ asm "cop_warnings", $warnix;
+ asm "cop_io", $ioix;
}
-sub B::GV::bytecodecv {
- my $gv = shift;
- my $cv = $gv->CV;
- if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) {
- if ($debug_cv) {
- warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
- $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
+sub B::OP::opwalk {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ my $ix;
+ my @oplist = $op->oplist;
+ push @cloop, undef;
+ $ix = $_->ix while $_ = pop @oplist;
+ while ($_ = pop @cloop) {
+ asm "ldop", $optab{$$_};
+ asm "op_next", $optab{${$_->next}};
}
- $gv->bytecode;
+ $ix;
}
}
-sub save_call_queues {
- if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls
- for my $cv (begin_av()->ARRAY) {
- next unless grep { $_ eq $cv->STASH->NAME; } @packages;
- my $op = $cv->START;
-OPLOOP:
- while ($$op) {
- if ($op->name eq 'require') { # save any BEGIN that does a require
- $cv->bytecode;
- asmf "push_begin %d\n", $cv->objix;
- last OPLOOP;
+#################################################
+
+sub save_cq {
+ my $av;
+ if (($av=begin_av)->isa("B::AV")) {
+ if ($savebegins) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_begin", $_->ix;
+ }
+ } else {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ # XXX BEGIN { exit while 1 }
+ for (my $op = $_->START; $$op; $op = $op->next) {
+ next unless $op->name =~ /require/;
+ asm "push_begin", $_->ix;
+ last;
}
- $op = $op->next;
}
}
}
- if (init_av()->isa("B::AV")) {
- for my $cv (init_av()->ARRAY) {
- next unless grep { $_ eq $cv->STASH->NAME; } @packages;
- $cv->bytecode;
- asmf "push_init %d\n", $cv->objix;
+ if (($av=init_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_init", $_->ix;
}
}
- if (end_av()->isa("B::AV")) {
- for my $cv (end_av()->ARRAY) {
- next unless grep { $_ eq $cv->STASH->NAME; } @packages;
- $cv->bytecode;
- asmf "push_end %d\n", $cv->objix;
+ if (($av=end_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_end", $_->ix;
}
}
}
-sub symwalk {
- no strict 'refs';
- my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
- if (grep { /^$_[0]/; } @packages) {
- walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
- }
- warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
- if $debug_bc;
- $ok;
-}
-
-sub bytecompile_main {
- my $curpad = (comppadlist->ARRAY)[1];
- my $curpadix = $curpad->objix;
- $curpad->bytecode;
- save_call_queues();
- walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
- warn "done main program, now walking symbol table\n" if $debug_bc;
- if (@packages) {
- no strict qw(refs);
- walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
- } else {
- die "No packages requested for compilation!\n";
- }
- asmf "main_root %d\n", main_root->objix;
- asmf "main_start %d\n", main_start->objix;
- asmf "curpad $curpadix\n";
- # XXX Do min_intro_pending and max_intro_pending matter?
-}
-
sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- open(OUT, ">&STDOUT");
- binmode OUT;
- select OUT;
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
+ my ($head, $scan, $T_inhinc, $T_thatfile, $keep_syn);
+ my $cwd = '';
+ $files{$0} = 1;
+ sub keep_syn {
+ $keep_syn = 1;
+ *B::OP::bsave = *B::OP::bsave_fat;
+ *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ *B::BINOP::bsave = *B::BINOP::bsave_fat;
+ *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
+ }
+ sub bwarn { print STDERR "Bytecode.pm: @_\n" }
+
+ for (@_) {
+ if (/^-S/) {
+ *newasm = *endasm = sub { };
+ *asm = sub { print " @_\n" };
+ *nice = sub ($) { print "\n@_\n" };
+ } elsif (/^-H/) {
+ require ByteLoader;
+ $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
+ } elsif (/^-k/) {
+ keep_syn;
+ } elsif (/^-o(.*)$/) {
+ my $ofile = $1;
+ open STDOUT, ">$ofile" or die "open $ofile: $!";
+ *B::COP::file = sub { $ofile } if $T_thatfile;
+ } elsif (/^-f(.*)$/) {
+ $files{$1} = 1;
+ } elsif (/^-s/) {
+ $scan = 1;
+ } elsif (/^-b/) {
+ $savebegins = 1;
+ # these are here for the testsuite
+ } elsif (/^-TD(.*)/) {
+ $T_inhinc = 1;
+ $cwd = $1;
+ } elsif (/^-TF/) {
+ $T_thatfile = 1;
} else {
- unshift @options, $option;
- last OPTION;
+ bwarn "Ignoring '$_' option";
}
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(OUT, ">$arg") or return "$arg: $!\n";
- binmode OUT;
- } elsif ($opt eq "a") {
- $arg ||= shift @options;
- open(OUT, ">>$arg") or return "$arg: $!\n";
- binmode OUT;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "b") {
- $| = 1;
- debug(1);
- } elsif ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "a") {
- B::Assembler::debug(1);
- } elsif ($arg eq "C") {
- $debug_cv = 1;
+ }
+ if ($scan) {
+ for(keys %files) {
+ my $f;
+ # KLUDGE
+ open($f, $_) or open ($f, "$cwd/$_")
+ or bwarn("cannot rescan '$_'"), next;
+ while (<$f>) {
+ /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
+ /^#/ and next;
+ if (/\bgoto\b/ && !$keep_syn) {
+ bwarn "keeping the syntax tree: \"goto\" op found";
+ keep_syn;
}
}
- } elsif ($opt eq "v") {
- $verbose = 1;
- } elsif ($opt eq "S") {
- $no_assemble = 1;
- } elsif ($opt eq "f") {
- $arg ||= shift @options;
- my $value = $arg !~ s/^no-//;
- $arg =~ s/-/_/g;
- my $ref = $optimise{$arg};
- if (defined($ref)) {
- $$ref = $value;
+ close $f;
+ }
+ }
+ binmode STDOUT;
+ return sub {
+ print $head if $head;
+ newasm sub { print @_ };
+
+ defstash->bwalk;
+ asm "main_start", main_start->opwalk;
+ asm "main_root", main_root->ix;
+ asm "main_cv", main_cv->ix;
+ asm "curpad", (comppadlist->ARRAY)[1]->ix;
+
+ asm "signal", cstring "__WARN__" # XXX
+ if warnhook->ix;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ save_cq;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ asm "dowarn", dowarn;
+
+ {
+ no strict 'refs';
+ nice "<DATA>";
+ my $dh = *{defstash->NAME."::DATA"};
+ local undef $/;
+ if (length (my $data = <$dh>)) {
+ asm "data", ord 'D';
+ print $data;
} else {
- warn qq(ignoring unknown optimisation option "$arg"\n);
+ asm "ret";
}
- } elsif ($opt eq "O") {
- $arg = 1 if $arg eq "";
- my $ref;
- foreach $ref (values %optimise) {
- $$ref = 0;
- }
- if ($arg >= 2) {
- $bypass_nullops = 1;
- }
- if ($arg >= 1) {
- $compress_nullops = 1;
- $omit_seq = 1;
- }
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- push @packages, $arg;
- } else {
- warn qq(ignoring unknown option "$opt$arg"\n);
}
- }
- if (! @packages) {
- warn "No package specified for compilation, assuming main::\n";
- @packages = qw(main);
- }
- if (@options) {
- die "Extraneous options left on B::Bytecode commandline: @options\n";
- } else {
- return sub {
- newasm(\&apr) unless $no_assemble;
- bytecompile_main();
- endasm() unless $no_assemble;
- };
+
+ endasm;
}
}
-sub apr { print @_; }
-
1;
-
-__END__
-
-=head1 NAME
-
-B::Bytecode - Perl compiler's bytecode backend
-
-=head1 SYNOPSIS
-
- perl -MO=Bytecode[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates a
-platform-independent bytecode encapsulating code to load the
-internal structures perl uses to run your program. When the
-generated bytecode is loaded in, your program is ready to run,
-reducing the time which perl would have taken to load and parse
-your program into its internal semi-compiled form. That means that
-compiling with this backend will not help improve the runtime
-execution speed of your program but may improve the start-up time.
-Depending on the environment in which your program runs this may
-or may not be a help.
-
-The resulting bytecode can be run with a special byteperl executable
-or (for non-main programs) be loaded via the C<byteload_fh> function
-in the F<B> module.
-
-=head1 OPTIONS
-
-If there are any non-option arguments, they are taken to be names of
-objects to be saved (probably doesn't work properly yet). Without
-extra arguments, it saves the main program.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT.
-
-=item B<-afilename>
-
-Append output to filename.
-
-=item B<-->
-
-Force end of options.
-
-=item B<-f>
-
-Force optimisations on or off one at a time. Each can be preceded
-by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
-
-=item B<-fcompress-nullops>
-
-Only fills in the necessary fields of ops which have
-been optimised away by perl's internal compiler.
-
-=item B<-fomit-sequence-numbers>
-
-Leaves out code to fill in the op_seq field of all ops
-which is only used by perl's internal compiler.
-
-=item B<-fbypass-nullops>
-
-If op->op_next ever points to a NULLOP, replaces the op_next field
-with the first non-NULLOP in the path of execution.
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
-B<-O2> adds B<-fbypass-nullops>.
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Do>
-
-Prints each OP as it's processed.
-
-=item B<-Db>
-
-Print debugging information about bytecompiler progress.
-
-=item B<-Da>
-
-Tells the (bytecode) assembler to include source assembler lines
-in its output as bytecode comments.
-
-=item B<-DC>
-
-Prints each CV taken from the final symbol tree walk.
-
-=item B<-S>
-
-Output (bytecode) assembler source rather than piping it
-through the assembler and outputting bytecode.
-
-=item B<-upackage>
-
-Stores package in the output.
-
-=back
-
-=head1 EXAMPLES
-
- perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl
-
- perl -MO=Bytecode,-S,-umain foo.pl > foo.S
- assemble foo.S > foo.plc
-
-Note that C<assemble> lives in the C<B> subdirectory of your perl
-library directory. The utility called perlcc may also be used to
-help make use of this compiler.
-
- perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm
-
-=head1 BUGS
-
-Output is still huge and there are still occasional crashes during
-either compilation or ByteLoading. Current status: experimental.
-
-=head1 AUTHORS
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-Benjamin Stuhl, C<sho_pi@hotmail.com>
-
-=cut
typedef SV *svindex;
typedef OP *opindex;
typedef char *pvindex;
-typedef IV IV64;
#define BGET_FREAD(argp, len, nelem) \
bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem))
#define BGET_FGETC() bl_getc(bstate->bs_fdata)
-#define BGET_U32(arg) \
- BGET_FREAD(&arg, sizeof(U32), 1)
-#define BGET_I32(arg) \
- BGET_FREAD(&arg, sizeof(I32), 1)
+/* all this should be made endianness-agnostic */
+
+#define BGET_U8(arg) arg = BGET_FGETC()
#define BGET_U16(arg) \
BGET_FREAD(&arg, sizeof(U16), 1)
-#define BGET_U8(arg) arg = BGET_FGETC()
+#define BGET_U32(arg) \
+ BGET_FREAD(&arg, sizeof(U32), 1)
+#define BGET_UV(arg) \
+ BGET_FREAD(&arg, sizeof(UV), 1)
+
+#define BGET_I32(arg) BGET_U32(arg)
+#define BGET_IV(arg) BGET_UV(arg)
#define BGET_PV(arg) STMT_START { \
BGET_U32(arg); \
if (arg) { \
New(666, bstate->bs_pv.xpv_pv, arg, char); \
- bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \
+ bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1);\
bstate->bs_pv.xpv_len = arg; \
bstate->bs_pv.xpv_cur = arg - 1; \
} else { \
do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
#endif
-/*
- * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
- * machines such that 32-bit machine compilers don't whine about the shift
- * count being too high even though the code is never reached there.
- */
-#define BGET_IV64(arg) STMT_START { \
- U32 hi, lo; \
- BGET_U32(hi); \
- BGET_U32(lo); \
- if (sizeof(IV) == 8) \
- arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \
- else if (((I32)hi == -1 && (I32)lo < 0) \
- || ((I32)hi == 0 && (I32)lo >= 0)) { \
- arg = (I32)lo; \
- } \
- else { \
- bstate->bs_iv_overflows++; \
- arg = 0; \
- } \
- } STMT_END
-
-#if IVSIZE == 4
-# define BGET_IV(arg) BGET_I32(arg)
-#else
-# if IVSIZE == 8
-# define BGET_IV(arg) BGET_IV64(arg)
-# endif
-#endif
#define BGET_op_tr_array(arg) do { \
- unsigned short *ary; \
- New(666, ary, 256, unsigned short); \
- BGET_FREAD(ary, sizeof(unsigned short), 256); \
+ unsigned short *ary, len; \
+ BGET_U16(len); \
+ New(666, ary, len, unsigned short); \
+ BGET_FREAD(ary, sizeof(unsigned short), len); \
arg = (char *) ary; \
} while (0)
#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE)
#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
-#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur
+#define BSET_mg_name(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur
+#define BSET_mg_namex(mg, arg) \
+ (mg->mg_ptr = (char*)SvREFCNT_inc((SV*)arg), \
+ mg->mg_len = HEf_SVKEY)
#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
#define BSET_xpv(sv) do { \
SvPV_set(sv, bstate->bs_pv.xpv_pv); \
#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
#define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
+#define BSET_av_pushx(sv, arg) (AvARRAY(sv)[++AvFILLp(sv)] = arg)
#define BSET_hv_store(sv, arg) \
hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0)
#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
+
+
+#ifdef USE_ITHREADS
+
+/* copied after the code in newPMOP() */
#define BSET_pregcomp(o, arg) \
- STMT_START { \
- PM_SETRE(((PMOP*)o), (arg ? \
- CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0)); \
- } STMT_END
+ STMT_START { \
+ SV* repointer; \
+ REGEXP* rx = arg ? \
+ CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)) : \
+ Null(REGEXP*); \
+ if(av_len((AV*) PL_regex_pad[0]) > -1) { \
+ repointer = av_pop((AV*)PL_regex_pad[0]); \
+ cPMOPx(o)->op_pmoffset = SvIV(repointer); \
+ SvREPADTMP_off(repointer); \
+ sv_setiv(repointer,PTR2IV(rx)); \
+ } else { \
+ repointer = newSViv(PTR2IV(rx)); \
+ av_push(PL_regex_padav,SvREFCNT_inc(repointer)); \
+ cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
+ PL_regex_pad = AvARRAY(PL_regex_padav); \
+ } \
+ } STMT_END
+
+#else
+#define BSET_pregcomp(o, arg) \
+ STMT_START { \
+ PM_SETRE(((PMOP*)o), (arg ? \
+ CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)): \
+ Null(REGEXP*))); \
+ } STMT_END
+
+#endif /* USE_THREADS */
+
+
#define BSET_newsv(sv, arg) \
STMT_START { \
sv = (arg == SVt_PVAV ? (SV*)newAV() : \
NEWSV(666,0)); \
SvUPGRADE(sv, arg); \
} STMT_END
-#define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \
- memzero((char*)o,optype_size[arg]))
+#define BSET_newop(o, arg) \
+ ((o = (OP*)safemalloc(arg)), memzero((char*)o,arg))
#define BSET_newopn(o, arg) STMT_START { \
OP *oldop = o; \
BSET_newop(o, arg); \
oldop->op_next = o; \
} STMT_END
-#define BSET_ret(foo) STMT_START { \
- Safefree(bstate->bs_obj_list); \
- return; \
+#define BSET_ret(foo) STMT_START { \
+ Safefree(bstate->bs_obj_list); \
+ return 0; \
+ } STMT_END
+
+/*
+ * stolen from toke.c: better if that was a function.
+ * in toke.c there are also #ifdefs for dosish systems and i/o layers
+ */
+
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+#define set_clonex(fp) \
+ STMT_START { \
+ int fd = PerlIO_fileno(fp); \
+ fcntl(fd,F_SETFD,fd >= 3); \
+ } STMT_END
+#else
+#define set_clonex(fp)
+#endif
+
+#define BSET_data(dummy,arg) \
+ STMT_START { \
+ GV *gv; \
+ char *pname = "main"; \
+ if (arg == 'D') \
+ pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); \
+ gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);\
+ GvMULTI_on(gv); \
+ if (!GvIO(gv)) \
+ GvIOp(gv) = newIO(); \
+ IoIFP(GvIOp(gv)) = PL_rsfp; \
+ set_clonex(PL_rsfp); \
+ /* Mark this internal pseudo-handle as clean */ \
+ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; \
+ if (PL_preprocess) \
+ IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; \
+ else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) \
+ IoTYPE(GvIOp(gv)) = IoTYPE_STD; \
+ else \
+ IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; \
+ Safefree(bstate->bs_obj_list); \
+ return 1; \
+ } STMT_END
+
+/* stolen from op.c */
+#define BSET_load_glob(foo, gv) \
+ STMT_START { \
+ GV *glob_gv; \
+ ENTER; \
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, \
+ newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); \
+ glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); \
+ GvCV(gv) = GvCV(glob_gv); \
+ SvREFCNT_inc((SV*)GvCV(gv)); \
+ GvIMPORTED_CV_on(gv); \
+ LEAVE; \
} STMT_END
/*
PL_comppad = (AV *)arg; \
pad = AvARRAY(arg); \
} STMT_END
-/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc()
- -- BKS 6-2-2000 */
+
+#ifdef USE_ITHREADS
#define BSET_cop_file(cop, arg) CopFILE_set(cop,arg)
-#define BSET_cop_line(cop, arg) CopLINE_set(cop,arg)
#define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg)
+#else
+/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc()
+ -- BKS 6-2-2000 */
+/* that really meant the actual CopFILEGV_set */
+#define BSET_cop_filegv(cop, arg) CopFILEGV_set(cop,arg)
+#define BSET_cop_stash(cop,arg) CopSTASH_set(cop,(HV*)arg)
+#endif
/* this is simply stolen from the code in newATTRSUB() */
#define BSET_push_begin(ary,cv) \
STMT_START { \
- I32 oldscope = PL_scopestack_ix; \
- ENTER; \
- SAVECOPFILE(&PL_compiling); \
- SAVECOPLINE(&PL_compiling); \
- if (!PL_beginav) \
- PL_beginav = newAV(); \
- av_push(PL_beginav, cv); \
- call_list(oldscope, PL_beginav); \
- PL_curcop = &PL_compiling; \
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);\
- LEAVE; \
+ I32 oldscope = PL_scopestack_ix; \
+ ENTER; \
+ SAVECOPFILE(&PL_compiling); \
+ SAVECOPLINE(&PL_compiling); \
+ if (!PL_beginav) \
+ PL_beginav = newAV(); \
+ av_push(PL_beginav, (SV*)cv); \
+ GvCV(CvGV(cv)) = 0; /* cv has been hijacked */\
+ call_list(oldscope, PL_beginav); \
+ PL_curcop = &PL_compiling; \
+ PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);\
+ LEAVE; \
} STMT_END
-#define BSET_push_init(ary,cv) \
- STMT_START { \
- av_unshift((PL_initav ? PL_initav : (PL_initav = newAV(), PL_initav)), 1); \
- av_store(PL_initav, 0, cv); \
+#define BSET_push_init(ary,cv) \
+ STMT_START { \
+ av_unshift((PL_initav ? PL_initav : \
+ (PL_initav = newAV(), PL_initav)), 1); \
+ av_store(PL_initav, 0, cv); \
} STMT_END
-#define BSET_push_end(ary,cv) \
- STMT_START { \
- av_unshift((PL_endav ? PL_endav : (PL_endav = newAV(), PL_endav)), 1); \
- av_store(PL_endav, 0, cv); \
+#define BSET_push_end(ary,cv) \
+ STMT_START { \
+ av_unshift((PL_endav ? PL_endav : \
+ (PL_endav = newAV(), PL_endav)), 1); \
+ av_store(PL_endav, 0, cv); \
} STMT_END
#define BSET_OBJ_STORE(obj, ix) \
(I32)ix > bstate->bs_obj_list_fill ? \
- bset_obj_store(aTHX_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj)
+ bset_obj_store(aTHX_ bstate, obj, (I32)ix) : \
+ (bstate->bs_obj_list[ix] = obj)
+
+#define BSET_signal(cv, name) \
+ mg_set(*hv_store(GvHV(gv_fetchpv("SIG", TRUE, SVt_PVHV)), \
+ name, strlen(name), cv, 0))
/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about
* what version of Perl it's being called under, it should do a 'use 5.006_001' or
projects / p5sagit/p5-mst-13.2.git / commitdiff