From: Adrian M. Enache Date: Fri, 18 Jul 2003 23:15:37 +0000 (+0300) Subject: Re: [perl #22984] perl-5.8.1-RC2: TEST -bytecompile won't work at all X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1df3498620ecc1df99a2455e631a135f1710416f;p=p5sagit%2Fp5-mst-13.2.git Re: [perl #22984] perl-5.8.1-RC2: TEST -bytecompile won't work at all Message-ID: <20030718201537.GA1574@ratsnest.hole> p4raw-id: //depot/perl@20220 --- diff --git a/Makefile.SH b/Makefile.SH index 08707c5..8fc5cac 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -1043,7 +1043,7 @@ makedepend: makedepend.SH config.sh utest ucheck test.utf8 check.utf8 test.torture torturetest \ test.third check.third utest.third ucheck.third test_notty.third \ test.deparse test_notty.deparse test_harness test_harness_notty \ - minitest coretest + test.bytecompile minitest coretest # Cannot delegate rebuilding of t/perl to make # to allow interlaced test and minitest @@ -1116,6 +1116,11 @@ utest.third ucheck.third: test_prep.third perl.third test_notty.third: test_prep.third perl.third PERL=./perl.third $(MAKE) PERL_DEBUG=PERL_3LOG=1 _test_notty +# Targets for Bytecode/ByteLoader testing. + +test.bytecompile: test_prep + PERL=./perl TEST_ARGS=-bytecompile $(MAKE) _test + # Targets for Deparse testing. test.deparse: test_prep diff --git a/bytecode.pl b/bytecode.pl index 0fd0362..e375961 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -100,7 +100,7 @@ bset_obj_store(pTHX_ struct byteloader_state *bstate, void *obj, I32 ix) return obj; } -void +int byterun(pTHX_ register struct byteloader_state *bstate) { register int insn; @@ -110,6 +110,7 @@ byterun(pTHX_ register struct byteloader_state *bstate) BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ bstate->bs_obj_list_fill = 31; + bstate->bs_obj_list[0] = NULL; /* first is always Null */ EOT @@ -127,8 +128,11 @@ EOT my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype); while () { + if (/^\s*#/) { + print BYTERUN_C if /^\s*#\s*(?:if|endif|el)/; + next; + } chop; - s/#.*//; # remove comments next unless length; if (/^%number\s+(.*)/) { $insn_num = $1; @@ -181,6 +185,7 @@ print BYTERUN_C <<'EOT'; /* NOTREACHED */ } } + return 0; } EOT @@ -206,7 +211,7 @@ struct byteloader_state { int bl_getc(struct byteloader_fdata *); int bl_read(struct byteloader_fdata *, char *, size_t, size_t); -extern void byterun(pTHX_ struct byteloader_state *); +extern int byterun(pTHX_ struct byteloader_state *); enum { EOT @@ -325,6 +330,7 @@ comment arg comment_t # Then make ord("\n") into a no-op %number 10 nop none none + # Now for the rest of the ordinary ones, beginning with \0 which is # ret so that \0-terminated strings can be read properly as bytecode. %number 0 @@ -350,8 +356,9 @@ sv_refcnt_add SvREFCNT(bstate->bs_sv) I32 x sv_flags SvFLAGS(bstate->bs_sv) U32 xrv SvRV(bstate->bs_sv) svindex xpv bstate->bs_sv none x -xiv32 SvIVX(bstate->bs_sv) I32 -xiv64 SvIVX(bstate->bs_sv) IV64 +xpv_cur SvCUR(bstate->bs_sv) STRLEN +xpv_len SvLEN(bstate->bs_sv) STRLEN +xiv SvIVX(bstate->bs_sv) IV xnv SvNVX(bstate->bs_sv) NV xlv_targoff LvTARGOFF(bstate->bs_sv) STRLEN xlv_targlen LvTARGLEN(bstate->bs_sv) STRLEN @@ -365,15 +372,16 @@ xio_lines IoLINES(bstate->bs_sv) IV xio_page IoPAGE(bstate->bs_sv) IV xio_page_len IoPAGE_LEN(bstate->bs_sv) IV xio_lines_left IoLINES_LEFT(bstate->bs_sv) IV -xio_top_name IoTOP_NAME(bstate->bs_sv) pvcontents +xio_top_name IoTOP_NAME(bstate->bs_sv) pvindex xio_top_gv *(SV**)&IoTOP_GV(bstate->bs_sv) svindex -xio_fmt_name IoFMT_NAME(bstate->bs_sv) pvcontents +xio_fmt_name IoFMT_NAME(bstate->bs_sv) pvindex xio_fmt_gv *(SV**)&IoFMT_GV(bstate->bs_sv) svindex -xio_bottom_name IoBOTTOM_NAME(bstate->bs_sv) pvcontents +xio_bottom_name IoBOTTOM_NAME(bstate->bs_sv) pvindex xio_bottom_gv *(SV**)&IoBOTTOM_GV(bstate->bs_sv) svindex xio_subprocess IoSUBPROCESS(bstate->bs_sv) short xio_type IoTYPE(bstate->bs_sv) char xio_flags IoFLAGS(bstate->bs_sv) char +xcv_xsubany *(SV**)&CvXSUBANY(bstate->bs_sv).any_ptr svindex xcv_stash *(SV**)&CvSTASH(bstate->bs_sv) svindex xcv_start CvSTART(bstate->bs_sv) opindex xcv_root CvROOT(bstate->bs_sv) opindex @@ -385,18 +393,21 @@ xcv_outside *(SV**)&CvOUTSIDE(bstate->bs_sv) svindex xcv_outside_seq CvOUTSIDE_SEQ(bstate->bs_sv) U32 xcv_flags CvFLAGS(bstate->bs_sv) U16 av_extend bstate->bs_sv SSize_t x +av_pushx bstate->bs_sv svindex x av_push bstate->bs_sv svindex x xav_fill AvFILLp(bstate->bs_sv) SSize_t xav_max AvMAX(bstate->bs_sv) SSize_t xav_flags AvFLAGS(bstate->bs_sv) U8 xhv_riter HvRITER(bstate->bs_sv) I32 -xhv_name HvNAME(bstate->bs_sv) pvcontents +xhv_name HvNAME(bstate->bs_sv) pvindex +xhv_pmroot *(OP**)&HvPMROOT(bstate->bs_sv) opindex hv_store bstate->bs_sv svindex x sv_magic bstate->bs_sv char x mg_obj SvMAGIC(bstate->bs_sv)->mg_obj svindex mg_private SvMAGIC(bstate->bs_sv)->mg_private U16 mg_flags SvMAGIC(bstate->bs_sv)->mg_flags U8 -mg_pv SvMAGIC(bstate->bs_sv) pvcontents x +mg_name SvMAGIC(bstate->bs_sv) pvcontents x +mg_namex SvMAGIC(bstate->bs_sv) svindex x xmg_stash *(SV**)&SvSTASH(bstate->bs_sv) svindex gv_fetchpv bstate->bs_sv strconst x gv_stashpv bstate->bs_sv strconst x @@ -425,12 +436,19 @@ op_first cUNOP->op_first opindex op_last cBINOP->op_last opindex op_other cLOGOP->op_other opindex op_pmreplroot cPMOP->op_pmreplroot opindex -op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex op_pmreplstart cPMOP->op_pmreplstart opindex op_pmnext *(OP**)&cPMOP->op_pmnext opindex +#ifdef USE_ITHREADS +op_pmstashpv cPMOP->op_pmstashpv pvindex +op_pmreplrootpo (PADOFFSET)cPMOP->op_pmreplroot PADOFFSET +#else +op_pmstash *(SV**)&cPMOP->op_pmstash svindex +op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex +#endif pregcomp PL_op pvcontents x op_pmflags cPMOP->op_pmflags U16 op_pmpermflags cPMOP->op_pmpermflags U16 +op_pmdynflags cPMOP->op_pmdynflags U8 op_sv cSVOP->op_sv svindex op_padix cPADOP->op_padix PADOFFSET op_pv cPVOP->op_pv pvcontents @@ -439,15 +457,36 @@ op_redoop cLOOP->op_redoop opindex op_nextop cLOOP->op_nextop opindex op_lastop cLOOP->op_lastop opindex cop_label cCOP->cop_label pvindex +#ifdef USE_ITHREADS cop_stashpv cCOP pvindex x cop_file cCOP pvindex x +#else +cop_stash cCOP svindex x +cop_filegv cCOP svindex x +#endif cop_seq cCOP->cop_seq U32 cop_arybase cCOP->cop_arybase I32 -cop_line cCOP line_t x +cop_line cCOP->cop_line line_t +cop_io cCOP->cop_io svindex cop_warnings cCOP->cop_warnings svindex main_start PL_main_start opindex main_root PL_main_root opindex +main_cv *(SV**)&PL_main_cv svindex curpad PL_curpad svindex x push_begin PL_beginav svindex x push_init PL_initav svindex x push_end PL_endav svindex x +curstash *(SV**)&PL_curstash svindex +defstash *(SV**)&PL_defstash svindex +data none U8 x +incav *(SV**)&GvAVn(PL_incgv) svindex +load_glob none svindex x +#ifdef USE_ITHREADS +regex_padav *(SV**)&PL_regex_padav svindex +#endif +dowarn PL_dowarn U8 +comppad_name *(SV**)&PL_comppad_name svindex +xgv_stash *(SV**)&GvSTASH(bstate->bs_sv) svindex +signal bstate->bs_sv strconst x +# to be removed +formfeed PL_formfeed svindex diff --git a/ext/B/B.xs b/ext/B/B.xs index 0decceb..cfe0079 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -411,6 +411,44 @@ walkoptree(pTHX_ SV *opsv, char *method) } } +SV ** +oplist(pTHX_ OP *o, SV **SP) +{ + for(; o; o = o->op_next) { + SV *opsv; + if (o->op_seq == 0) + break; + o->op_seq = 0; + opsv = sv_newmortal(); + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); + XPUSHs(opsv); + switch (o->op_type) { + case OP_SUBST: + SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP); + continue; + case OP_SORT: + if (o->op_flags & (OPf_STACKED|OPf_SPECIAL)) { + OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */ + kid = kUNOP->op_first; /* pass rv2gv */ + kid = kUNOP->op_first; /* pass leave */ + SP = oplist(aTHX_ kid, SP); + } + continue; + } + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { + case OA_LOGOP: + SP = oplist(aTHX_ cLOGOPo->op_other, SP); + break; + case OA_LOOP: + SP = oplist(aTHX_ cLOOPo->op_lastop, SP); + SP = oplist(aTHX_ cLOOPo->op_nextop, SP); + SP = oplist(aTHX_ cLOOPo->op_redoop, SP); + break; + } + } + return SP; +} + typedef OP *B__OP; typedef UNOP *B__UNOP; typedef BINOP *B__BINOP; @@ -431,6 +469,7 @@ typedef SV *B__PVMG; typedef SV *B__PVLV; typedef SV *B__BM; typedef SV *B__RV; +typedef SV *B__FM; typedef AV *B__AV; typedef HV *B__HV; typedef CV *B__CV; @@ -474,6 +513,7 @@ BOOT: #define B_sv_undef() &PL_sv_undef #define B_sv_yes() &PL_sv_yes #define B_sv_no() &PL_sv_no +#define B_formfeed() PL_formfeed #ifdef USE_ITHREADS #define B_regex_padav() PL_regex_padav #endif @@ -533,6 +573,9 @@ B_defstash() U8 B_dowarn() +B::SV +B_formfeed() + void B_warnhook() CODE: @@ -740,6 +783,12 @@ U8 OP_private(o) B::OP o +void +OP_oplist(o) + B::OP o + PPCODE: + SP = oplist(aTHX_ o, SP); + #define UNOP_first(o) o->op_first MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ @@ -944,6 +993,7 @@ LOOP_lastop(o) #define COP_stashpv(o) CopSTASHPV(o) #define COP_stash(o) CopSTASH(o) #define COP_file(o) CopFILE(o) +#define COP_filegv(o) CopFILEGV(o) #define COP_cop_seq(o) o->cop_seq #define COP_arybase(o) o->cop_arybase #define COP_line(o) CopLINE(o) @@ -968,6 +1018,11 @@ char * COP_file(o) B::COP o +B::GV +COP_filegv(o) + B::COP o + + U32 COP_cop_seq(o) B::COP o @@ -1307,9 +1362,13 @@ B::IO GvIO(gv) B::GV gv -B::CV +B::FM GvFORM(gv) B::GV gv + CODE: + RETVAL = (SV*)GvFORM(gv); + OUTPUT: + RETVAL B::AV GvAV(gv) @@ -1465,6 +1524,12 @@ U8 AvFLAGS(av) B::AV av +MODULE = B PACKAGE = B::FM PREFIX = Fm + +IV +FmLINES(form) + B::FM form + MODULE = B PACKAGE = B::CV PREFIX = Cv U32 diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm index 429405f..504f880 100644 --- a/ext/B/B/Assembler.pm +++ b/ext/B/B/Assembler.pm @@ -12,8 +12,10 @@ use B::Asmdata qw(%insn_data @insn_name); use Config qw(%Config); require ByteLoader; # we just need its $VERSIOM +no warnings; # XXX + @ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh newasm endasm assemble); +@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm); $VERSION = 0.04; use strict; @@ -128,19 +130,12 @@ sub B::Asmdata::PUT_none { return ""; } sub B::Asmdata::PUT_op_tr_array { - my $arg = shift; - my @ary = split(/\s*,\s*/, $arg); - if (@ary != 256) { - error "wrong number of arguments to op_tr_array"; - @ary = (0) x 256; - } - return pack("S256", @ary); + my @ary = split /\s*,\s*/, shift; + return pack "S*", @ary; } -# XXX Check this works -# Note: $arg >> 32 is a no-op on 32-bit systems + sub B::Asmdata::PUT_IV64 { - my $arg = shift; - return pack("LL", ($arg >> 16) >>16 , $arg & 0xffffffff); + return pack "Q", shift; } sub B::Asmdata::PUT_IV { @@ -285,6 +280,18 @@ sub assemble { } } +### temporary workaround + +sub asm { + return if $_[0] =~ /\s*\W/; + if (defined $_[1]) { + return if $_[1] eq "0" and $_[0] !~ /^(?:newsv|av_pushx?|xav_flags)$/; + return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/; + } + # warn "@_\n"; + assemble "@_"; +} + 1; __END__ diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index d1125bd..164c10f 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -1,1001 +1,749 @@ -# 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 ""; + 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 function -in the F 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 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). - -=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 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,-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 -Benjamin Stuhl, C - -=cut diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm index a50b48f..a563715 100644 --- a/ext/B/B/Disassembler.pm +++ b/ext/B/B/Disassembler.pm @@ -137,7 +137,8 @@ sub GET_none {} sub GET_op_tr_array { my $fh = shift; - my @ary = unpack("S256", $fh->readn(256 * 2)); + my $len = unpack "S", $fh->readn(2); + my @ary = unpack "S*", $fh->readn($len*2); return join(",", @ary); } diff --git a/ext/B/typemap b/ext/B/typemap index 77a92ea..99aec73 100644 --- a/ext/B/typemap +++ b/ext/B/typemap @@ -25,6 +25,7 @@ B::CV T_SV_OBJ B::HV T_SV_OBJ B::AV T_SV_OBJ B::IO T_SV_OBJ +B::FM T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV diff --git a/ext/ByteLoader/ByteLoader.pm b/ext/ByteLoader/ByteLoader.pm index 9c8c84d..08a53a6 100644 --- a/ext/ByteLoader/ByteLoader.pm +++ b/ext/ByteLoader/ByteLoader.pm @@ -2,15 +2,12 @@ package ByteLoader; use XSLoader (); -$VERSION = 0.04; +our $VERSION = '0.04'; XSLoader::load 'ByteLoader', $VERSION; -# Preloaded methods go here. - 1; __END__ - =head1 NAME ByteLoader - load byte compiled perl code @@ -20,18 +17,20 @@ ByteLoader - load byte compiled perl code use ByteLoader 0.04; - use ByteLoader 0.04; - + or just + + perl -MByteLoader bytecode_file =head1 DESCRIPTION -This module is used to load byte compiled perl code. It uses the source -filter mechanism to read the byte code and insert it into the compiled -code at the appropriate point. +This module is used to load byte compiled perl code as produced by +C. It uses the source filter mechanism to read +the byte code and insert it into the compiled code at the appropriate point. =head1 AUTHOR Tom Hughes based on the ideas of Tim Bunce and others. +Many changes by Enache Adrian 2003 a.d. =head1 SEE ALSO diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index 4588b02..e71b7cd 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -1,4 +1,3 @@ -#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -27,7 +26,7 @@ bl_getc(struct byteloader_fdata *data) /* Else there must be at least one byte present, which is good enough */ } - return *((char *) SvPV_nolen (data->datasv) + data->next_out++); + return *((U8 *) SvPV_nolen (data->datasv) + data->next_out++); } int @@ -81,6 +80,7 @@ byteloader_filter(pTHX_ int idx, SV *buf_sv, int maxlen) OP *savestart = PL_main_start; struct byteloader_state bstate; struct byteloader_fdata data; + int len; data.next_out = 0; data.datasv = FILTER_DATA(idx); @@ -92,7 +92,14 @@ byteloader_filter(pTHX_ int idx, SV *buf_sv, int maxlen) bstate.bs_sv = Nullsv; bstate.bs_iv_overflows = 0; - byterun(aTHX_ &bstate); +/* KLUDGE */ + if (byterun(aTHX_ &bstate) + && (len = SvCUR(data.datasv) - (STRLEN)data.next_out)) + { + PerlIO_seek(PL_rsfp, -len, SEEK_CUR); + PL_rsfp = NULL; + } + filter_del(byteloader_filter); if (PL_in_eval) { OP *o; @@ -125,9 +132,3 @@ import(package="ByteLoader", ...) if (!sv) croak ("Could not allocate ByteLoader buffers"); filter_add(byteloader_filter, sv); - -void -unimport(package="ByteLoader", ...) - char *package - PPCODE: - filter_del(byteloader_filter); diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h index 1c94b66..4602a68 100644 --- a/ext/ByteLoader/bytecode.h +++ b/ext/ByteLoader/bytecode.h @@ -6,25 +6,29 @@ typedef int comment_t; 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 { \ @@ -51,39 +55,12 @@ typedef IV IV64; 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) @@ -126,7 +103,10 @@ typedef IV IV64; #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); \ @@ -136,14 +116,45 @@ typedef IV IV64; #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() : \ @@ -151,17 +162,70 @@ typedef IV IV64; 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 /* @@ -179,40 +243,54 @@ typedef IV IV64; 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 diff --git a/installperl b/installperl index 52df9c1..67d4530 100755 --- a/installperl +++ b/installperl @@ -756,7 +756,7 @@ sub installlib { # ignore patch backups, RCS files, emacs backup & temp files and the # .exists files, .PL files, and test files. - return if $name =~ m{\.orig$|\.rej$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.t$|^test\.pl$} || + return if $name =~ m{\.orig$|\.rej$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.plc$|\.t$|^test\.pl$} || $dir =~ m{/t(?:/|$)}; # ignore the cpan script in lib/CPAN/bin (installed later with other utils) return if $name eq 'cpan'; diff --git a/t/TEST b/t/TEST index 92a9d8f..014fa12 100755 --- a/t/TEST +++ b/t/TEST @@ -21,7 +21,7 @@ if ($#ARGV >= 0) { $verbose = 1 if $1 eq 'v'; $torture = 1 if $1 eq 'torture'; $with_utf= 1 if $1 eq 'utf8'; - $byte_compile = 1 if $1 eq 'bytecompile'; + $bytecompile = 1 if $1 eq 'bytecompile'; $compile = 1 if $1 eq 'compile'; if ($1 =~ /^deparse(,.+)?$/) { $deparse = 1; @@ -125,9 +125,11 @@ unless (@ARGV) { if ($deparse) { _testprogs('deparse', '', @ARGV); } -elsif( $compile || $byte_compile ) { - _testprogs('compile', '', @ARGV) if $compile; - _testprogs('compile', '-B', @ARGV) if $byte_compile; +elsif( $compile ) { + _testprogs('compile', '', @ARGV); +} +elsif( $bytecompile ) { + _testprogs('bytecompile', '', @ARGV); } else { _testprogs('compile', '', @ARGV) if -e "../testcompile"; @@ -151,6 +153,12 @@ TESTING DEPARSER ------------------------------------------------------------------------------ EOT + print <<'EOT' if ($type eq 'bytecompile'); +------------------------------------------------------------------------------ +TESTING BYTECODE COMPILER +------------------------------------------------------------------------------ +EOT + $ENV{PERLCC_TIMEOUT} = 120 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); @@ -235,6 +243,25 @@ EOT open(RESULTS, $deparse) or print "can't deparse '$deparse': $!.\n"; } + elsif ($type eq 'bytecompile') { + my $perl = $ENV{PERL} || './perl'; + my $redir = ($^O eq 'VMS' ? '2>&1' : ''); + my $bswitch = "-MO=Bytecode,-H,-s,-TD`pwd`,"; + $bswitch .= "-TF," + if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB); + $bswitch .= "-k," + if $test =~ m(deparse|terse|ext/Storable/t/code); + $bswitch .= "-k," + if $] < 5.009 && $test =~ m(avhv|hashwarn); + $bswitch .= "-b," + if $test =~ m(op/getpid); + my $bytecompile = + "$perl $testswitch $switch -I../lib $bswitch". + "-o$test.plc $test 2>/dev/null &&". + "$perl $testswitch $switch $utf $test.plc $redir|"; + open(RESULTS,$bytecompile) + or print "can't byte-compile '$bytecompile': $!.\n"; + } elsif ($type eq 'perl') { my $perl = $ENV{PERL} || './perl'; my $redir = ($^O eq 'VMS' ? '2>&1' : ''); diff --git a/utils/perlcc.PL b/utils/perlcc.PL index 15a276a..313a972 100644 --- a/utils/perlcc.PL +++ b/utils/perlcc.PL @@ -225,53 +225,18 @@ sub compile_module { } sub compile_byte { - require ByteLoader; - my $stash = grab_stash(); - my $command = "$BinPerl -MO=Bytecode,$stash $Input"; - # The -a option means we'd have to close the file and lose the - # lock, which would create the tiniest of races. Instead, append - # the output ourselves. - vprint 1, "Writing on $Output"; - - my $openflags = O_WRONLY | O_CREAT; - $openflags |= O_BINARY if eval { O_BINARY; 1 }; - $openflags |= O_EXLOCK if eval { O_EXLOCK; 1 }; - - # these dies are not "$0: .... \n" because they "can't happen" - - sysopen(OUT, $Output, $openflags) - or die "can't write to $Output: $!"; - - # this is blocking; hold on; why are we doing this?? - # flock OUT, LOCK_EX or die "can't lock $Output: $!" - # unless eval { O_EXLOCK; 1 }; - - truncate(OUT, 0) - or die "couldn't trunc $Output: $!"; - - print OUT <