From: Benjamin Stuhl Date: Tue, 6 Jun 2000 23:01:50 +0000 (+0000) Subject: B::Bytecode patches X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e8fcef166ae70cf67e42f1eda262b271a3daca03;p=p5sagit%2Fp5-mst-13.2.git B::Bytecode patches To: gsar@activestate.com, jhi@iki.fi Cc: perl5-porters@perl.org Message-ID: <20000602202526.48694.qmail@hotmail.com> (MUA had mangled many lines by wordwrapping) p4raw-id: //depot/cfgperl@6204 --- diff --git a/bytecode.pl b/bytecode.pl index d1e1c70..f847298 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -13,7 +13,7 @@ my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). -my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); +my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); my (%alias_from, $from, $tos); while (($from, $tos) = each %alias_to) { @@ -82,7 +82,7 @@ print BYTERUN_C $c_header, <<'EOT'; #include "bytecode.h" -static int optype_size[] = { +static const int optype_size[] = { EOT my $i = 0; for ($i = 0; $i < @optype - 1; $i++) { @@ -92,12 +92,8 @@ printf BYTERUN_C " sizeof(%s)\n", $optype[$i], $i; print BYTERUN_C <<'EOT'; }; -static SV *specialsv_list[4]; - static int bytecode_iv_overflows = 0; -static SV *bytecode_sv; -static XPV bytecode_pv; -static void **bytecode_obj_list; +static void **bytecode_obj_list = Null(void**); static I32 bytecode_obj_list_fill = -1; void * @@ -105,9 +101,9 @@ bset_obj_store(pTHXo_ void *obj, I32 ix) { if (ix > bytecode_obj_list_fill) { if (bytecode_obj_list_fill == -1) - New(666, bytecode_obj_list, ix + 1, void*); + New(666, bytecode_obj_list, ix + 32, void*); else - Renew(bytecode_obj_list, ix + 1, void*); + Renew(bytecode_obj_list, ix + 32, void*); bytecode_obj_list_fill = ix; } bytecode_obj_list[ix] = obj; @@ -115,11 +111,20 @@ bset_obj_store(pTHXo_ void *obj, I32 ix) } void -byterun(pTHXo_ struct bytestream bs) +byterun(pTHXo) { dTHR; int insn; - + SV *bytecode_sv; + XPV bytecode_pv; + SV *specialsv_list[6]; + ENTER; + SAVEVPTR(bytecode_obj_list); + SAVEI32(bytecode_obj_list_fill); + bytecode_obj_list = Null(void**); + bytecode_obj_list_fill = -1; + + BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ EOT for (my $i = 0; $i < @specialsv; $i++) { @@ -198,7 +203,7 @@ EOT # open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!"; print BYTERUN_H $c_header, <<'EOT'; -struct bytestream { +struct bytestream { /* XXX: not currently used - too slow */ void *data; int (*pfgetc)(void *); int (*pfread)(char *, size_t, size_t, void *); @@ -234,15 +239,7 @@ for ($i = 0; $i < @optype - 1; $i++) { printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i; print BYTERUN_H <<'EOT'; -extern void byterun(pTHXo_ struct bytestream bs); - -#define INIT_SPECIALSV_LIST STMT_START { \ -EOT -for ($i = 0; $i < @specialsv; $i++) { - print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n"; -} -print BYTERUN_H <<'EOT'; - } STMT_END +extern void byterun(pTHXo); EOT # @@ -409,3 +406,6 @@ cop_warnings cCOP->cop_warnings svindex main_start PL_main_start opindex main_root PL_main_root opindex curpad PL_curpad svindex x +push_begin PL_beginav svindex x +push_init PL_initav svindex x +push_end PL_endav svindex x diff --git a/ext/B/B.pm b/ext/B/B.pm index 4512d91..50364fa 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,11 +9,12 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(minus_c ppname +@EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names main_root main_start main_cv svref_2object opnumber amagic_generation walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info init_av); + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av end_av); sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; diff --git a/ext/B/B.xs b/ext/B/B.xs index 9e29855..df5267e 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -81,7 +81,7 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ -static SV *specialsv_list[4]; +static SV *specialsv_list[6]; static opclass cc_opclass(pTHX_ OP *o) @@ -386,11 +386,15 @@ BOOT: specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_begin_av() PL_beginav_save +#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -402,6 +406,10 @@ BOOT: B::AV B_init_av() +B::AV +B_begin_av() +B::AV +B_end_av() B::CV B_main_cv() @@ -515,6 +523,10 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_minus_c |= 0x10; SV * cstring(sv) SV * sv @@ -693,8 +705,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) cSVOPo->op_sv -#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) +#define SVOP_sv(o) cSVOPo_sv +#define SVOP_gv(o) cGVOPo_gv MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm index 6c51a9a..1324f7c 100644 --- a/ext/B/B/Assembler.pm +++ b/ext/B/B/Assembler.pm @@ -8,10 +8,11 @@ package B::Assembler; use Exporter; use B qw(ppname); use B::Asmdata qw(%insn_data @insn_name); +use Config qw(%Config); @ISA = qw(Exporter); @EXPORT_OK = qw(assemble_fh assemble_insn strip_comments - parse_statement uncstring); + parse_statement uncstring gen_header); use strict; my %opnumber; @@ -49,11 +50,12 @@ sub B::Asmdata::PUT_U8 { return $c; } -sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_NV { sprintf("%lf\0", $_[0]) } -sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here +sub B::Asmdata::PUT_U16 { pack("S", $_[0]) } +sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) + # may not even be portable between compilers +sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } @@ -79,7 +81,7 @@ sub B::Asmdata::PUT_PV { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); - return pack("N", length($arg)) . $arg; + return pack("L", length($arg)) . $arg; } sub B::Asmdata::PUT_comment_t { my $arg = shift; @@ -90,7 +92,7 @@ sub B::Asmdata::PUT_comment_t { } return $arg . "\n"; } -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above sub B::Asmdata::PUT_none { my $arg = shift; error "extraneous argument: $arg" if defined $arg; @@ -103,12 +105,12 @@ sub B::Asmdata::PUT_op_tr_array { error "wrong number of arguments to op_tr_array"; @ary = (0) x 256; } - return pack("n256", @ary); + return pack("S256", @ary); } # XXX Check this works sub B::Asmdata::PUT_IV64 { my $arg = shift; - return pack("NN", $arg >> 32, $arg & 0xffffffff); + return pack("LL", $arg >> 32, $arg & 0xffffffff); } my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", @@ -138,6 +140,16 @@ sub strip_comments { return $stmt; } +sub gen_header { # create the ByteCode header + my $header = B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' + $header .= B::Asmdata::PUT_strconst($Config{archname}); + $header .= B::Asmdata::PUT_U32($Config{ivsize}); + $header .= B::Asmdata::PUT_U32($Config{nvsize}); + $header .= B::Asmdata::PUT_U32($Config{ptrsize}); + $header .= B::Asmdata::PUT_strconst($Config{byteorder}); # PV not U32 because + # of varying size + $header; +} sub parse_statement { my $stmt = shift; my ($insn, $arg) = $stmt =~ m{ @@ -186,6 +198,7 @@ sub assemble_fh { my ($line, $insn, $arg); $linenum = 0; $errors = 0; + &$out(gen_header()); while ($line = <$fh>) { $linenum++; chomp $line; diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index 941a818..8cb60ee 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -7,12 +7,14 @@ # package B::Bytecode; use strict; -use Carp; use IO::File; -use B qw(minus_c main_cv main_root main_start comppadlist +use B qw(main_cv main_root main_start comppadlist class peekop walkoptree svref_2object cstring walksymtable - SVf_POK SVp_POK SVf_IOK SVp_IOK + 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 ); use B::Asmdata qw(@optype @specialsv_name); use B::Assembler qw(assemble_fh); @@ -31,9 +33,16 @@ sub POK () { SVf_POK|SVp_POK } # 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, $module_only, $no_assemble, $debug_bc, $debug_cv); my $assembler_pid; +my @packages; # list of packages to compile # 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. @@ -100,6 +109,11 @@ sub pvstring { } } +sub nv { + # print full precision + my $str = sprintf "%.40f", $_[0]; + return $str; +} sub saved { $saved{${$_[0]}} } sub mark_saved { $saved{${$_[0]}} = 1 } sub unmark_saved { $saved{${$_[0]}} = 0 } @@ -166,7 +180,8 @@ 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); + require('Carp.pm'), Carp::croak("OP::newix: can't understand class $class") + unless defined($typenum); print "newop $typenum\t# $class\n"; stop($ix); } @@ -180,7 +195,7 @@ sub B::OP::bytecode { my $op = shift; my $next = $op->next; my $nextix; - my $sibix = $op->sibling->objix; + my $sibix = $op->sibling->objix unless $strip_syntree; my $ix = $op->objix; my $type = $op->type; @@ -203,7 +218,7 @@ sub B::OP::bytecode { sub B::UNOP::bytecode { my $op = shift; - my $firstix = $op->first->objix; + my $firstix = $op->first->objix unless $strip_syntree; $op->B::OP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { print "op_first $firstix\n"; @@ -251,7 +266,7 @@ sub B::PVOP::bytecode { sub B::BINOP::bytecode { my $op = shift; - my $lastix = $op->last->objix; + my $lastix = $op->last->objix unless $strip_syntree; $op->B::UNOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { print "op_last $lastix\n"; @@ -260,7 +275,7 @@ sub B::BINOP::bytecode { sub B::LISTOP::bytecode { my $op = shift; - my $children = $op->children; + my $children = $op->children unless $strip_syntree; $op->B::BINOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { print "op_children $children\n"; @@ -278,14 +293,16 @@ sub B::LOOP::bytecode { sub B::COP::bytecode { my $op = shift; - my $stashpv = $op->stashpv; my $file = $op->file; my $line = $op->line; - my $warnings = $op->warnings; - my $warningsix = $warnings->objix; - if ($debug_bc) { + if ($debug_bc) { # do this early to aid debugging printf "# line %s:%d\n", $file, $line; } + my $stashpv = $op->stashpv; + my $warnings = $op->warnings; + my $warningsix; + $warningsix = $warnings->objix; + $warnings->bytecode; $op->B::OP::bytecode; printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; newpv %s @@ -359,14 +376,14 @@ sub B::IV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::SV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV } sub B::NV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf "xnv %s\n", $sv->NVX; + printf "xnv %s\n", nv($sv->NVX); } sub B::RV::bytecode { @@ -404,7 +421,7 @@ sub B::PVNV::bytecode { } else { my $pv = $sv->PV; $sv->B::IV::bytecode; - printf "xnv %s\n", $sv->NVX; + printf "xnv %s\n", nv($sv->NVX); if ($flag == 1) { $pv .= "\0" . $sv->TABLE; printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; @@ -461,6 +478,7 @@ sub B::BM::bytecode { sub B::GV::bytecode { my $gv = shift; return if saved($gv); + return unless grep { $_ eq $gv->STASH->NAME; } @packages; my $ix = $gv->objix; mark_saved($gv); ldsv($ix); @@ -488,6 +506,10 @@ EOT 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 @@ -510,6 +532,7 @@ sub B::HV::bytecode { mark_saved($hv); my $name = $hv->NAME; my $ix = $hv->objix; + printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; 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. @@ -526,7 +549,6 @@ sub B::HV::bytecode { printf("newpv %s\nhv_store %d\n", pvstring($contents[$i]), $ixes[$i / 2]); } - printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; } } @@ -551,6 +573,7 @@ sub B::AV::bytecode { # create an AV with NEWSV and SvUPGRADE rather than doing newAV # which is what sets AvMAX and AvFILL. ldsv($ix); + printf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; if ($fill > -1) { my $elix; @@ -562,11 +585,13 @@ sub B::AV::bytecode { print "av_extend $max\n"; } } + printf "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 $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; @@ -628,8 +653,7 @@ sub B::SPECIAL::bytecode { } sub bytecompile_object { - my $sv; - foreach $sv (@_) { + for my $sv (@_) { svref_2object($sv)->bytecode; } } @@ -646,30 +670,64 @@ sub B::GV::bytecodecv { } } +sub save_call_queues { + if (ref(begin_av()) eq "B::AV") { # this is just to save 'use Foo;' calls + for my $cv (begin_av->ARRAY) { + my $name = $cv->STASH->NAME; + next unless grep { $_ eq $name } @packages; + my $op = $cv->START; + $op = $op->next while ($$op && ref $op ne "B::UNOP"); + if ($$op && $op->name eq 'require') { # should be first UNOP + $cv->bytecode; + printf "push_begin %d\n", $cv->objix; + } + } + } + if (ref(init_av()) eq "B::AV") { + for my $cv (init_av->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME } @packages; + $cv->bytecode; + printf "push_init %d\n", $cv->objix; + } + } + if (ref(end_av()) eq "B::AV") { + for my $cv (end_av->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME } @packages; + $cv->bytecode; + printf "push_end %d\n", $cv->objix; + } + } +} + +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; - walkoptree(main_root, "bytecode"); + walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; warn "done main program, now walking symbol table\n" if $debug_bc; - my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings - attributes File::Spec SelectSaver blib Cwd)) - { - $exclude{$pack."::"} = 1; - } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "bytecodecv", sub { - warn "considering $_[0]\n" if $debug_bc; - return !defined($exclude{$_[0]}); - }); - if (!$module_only) { - printf "main_root %d\n", main_root->objix; - printf "main_start %d\n", main_start->objix; - printf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? + if (@packages) { + no strict qw(refs); + our %packages; + walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); + } else { + die "No packages requested for compilation!\n"; } + save_call_queues; + printf "main_root %d\n", main_root->objix; + printf "main_start %d\n", main_start->objix; + printf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? } sub prepare_assemble { @@ -727,7 +785,7 @@ sub compile { } } elsif ($opt eq "v") { $verbose = 1; - } elsif ($opt eq "m") { + } elsif ($opt eq "m") { # XXX: NOP $module_only = 1; } elsif ($opt eq "S") { $no_assemble = 1; @@ -757,9 +815,16 @@ sub compile { $compress_nullops = 1; $omit_seq = 1; } + } elsif ($opt eq "P") { + $arg ||= shift @options; + push @packages, $arg; } } - if (@options) { + if (! @packages) { + warn "No package specified for compilation, assuming main::\n"; + @packages = qw(main); + } + if (@options) { # XXX: unsupported and untested! return sub { my $objname; my $newfh; @@ -887,33 +952,33 @@ Prints each CV taken from the final symbol tree walk. Output (bytecode) assembler source rather than piping it through the assembler and outputting bytecode. -=item B<-m> - -Compile as a module rather than a standalone program. Currently this -just means that the bytecodes for initialising C, -C and C are omitted. - +=item B<-Ppackage> + +Stores package in the output. + =back =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-ofoo.plc,-Pmain foo.pl - perl -MO=Bytecode,-S foo.pl > foo.S + perl -MO=Bytecode,-S,-Pmain foo.pl > foo.S assemble foo.S > foo.plc Note that C lives in the C subdirectory of your perl library directory. The utility called perlcc may also be used to help make use of this compiler. - perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-PFoo,-oFoo.pmc Foo.pm =head1 BUGS -Plenty. Current status: experimental. +Output is still huge and there are still occasional crashes during +either compilation or ByteLoading. Current status: experimental. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C +Benjamin Stuhl, C =cut diff --git a/ext/B/O.pm b/ext/B/O.pm index 352f8d4..98fdcf6 100644 --- a/ext/B/O.pm +++ b/ext/B/O.pm @@ -11,6 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; + save_BEGINs; eval 'CHECK { &$compilesub() }'; } else { die $compilesub; diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index 7c3746b..cfabf33 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -4,47 +4,14 @@ #include "XSUB.h" #include "byterun.h" -static int -xgetc(PerlIO *io) -{ - dTHX; - return PerlIO_getc(io); -} - -static int -xfread(char *buf, size_t size, size_t n, PerlIO *io) -{ - dTHX; - int i = PerlIO_read(io, buf, n * size); - if (i > 0) - i /= size; - return i; -} - -static void -freadpv(U32 len, void *data, XPV *pv) -{ - dTHX; - New(666, pv->xpv_pv, len, char); - PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len); - pv->xpv_len = len; - pv->xpv_cur = len - 1; -} - static I32 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) { dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; - struct bytestream bs; - - bs.data = PL_rsfp; - bs.pfgetc = (int(*) (void*))xgetc; - bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; - bs.pfreadpv = freadpv; - byterun(aTHXo_ bs); + byterun(aTHXo); if (PL_in_eval) { OP *o; diff --git a/intrpvar.h b/intrpvar.h index 8ed93f8..d7e4025 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -443,5 +443,6 @@ PERLVAR(IProc, struct IPerlProc*) #if defined(USE_ITHREADS) PERLVAR(Iptr_table, PTR_TBL_t*) #endif +PERLVARI(Ibeginav_save, AV*, Nullav) /* save BEGIN{}s when compiling */ PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ diff --git a/perl.c b/perl.c index 4e0e1e1..b40e617 100644 --- a/perl.c +++ b/perl.c @@ -3667,7 +3667,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - SAVEFREESV(cv); + if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) { + /* save PL_beginav for compiler */ + if (! PL_beginav_save) + PL_beginav_save = newAV(); + av_push(PL_beginav_save, (SV*)cv); + } else { + SAVEFREESV(cv); + } #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else