diff options
Diffstat (limited to 'contrib/perl5/ext/B')
23 files changed, 2480 insertions, 1362 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index 75dcfb3..4512d91 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -6,15 +6,15 @@ # License or the Artistic License, as specified in the README file. # package B; -require DynaLoader; +use XSLoader (); require Exporter; -@ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname +@ISA = qw(Exporter); +@EXPORT_OK = qw(minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object + 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); - +sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -38,10 +38,9 @@ use strict; @B::UNOP::ISA = 'B::OP'; @B::BINOP::ISA = 'B::UNOP'; @B::LOGOP::ISA = 'B::UNOP'; -@B::CONDOP::ISA = 'B::UNOP'; @B::LISTOP::ISA = 'B::BINOP'; @B::SVOP::ISA = 'B::OP'; -@B::GVOP::ISA = 'B::OP'; +@B::PADOP::ISA = 'B::OP'; @B::PVOP::ISA = 'B::OP'; @B::CVOP::ISA = 'B::OP'; @B::LOOP::ISA = 'B::LISTOP'; @@ -65,10 +64,6 @@ sub debug { walkoptree_debug($value); } -# sub OPf_KIDS; -# add to .xs for perl5.002 -sub OPf_KIDS () { 4 } - sub class { my $obj = shift; my $name = ref $obj; @@ -81,7 +76,7 @@ sub parents { \@parents } # For debugging sub peekop { my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); + return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); } sub walkoptree_slow { @@ -112,6 +107,11 @@ sub timing_info { } my %symtable; + +sub clearsym { + %symtable = (); +} + sub savesym { my ($obj, $value) = @_; # warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug @@ -135,37 +135,26 @@ sub walkoptree_exec { } savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); $op->$method($level); - $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) { + $ppname = $op->name; + if ($ppname =~ + /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) + { print $prefix, uc($1), " => {\n"; walkoptree_exec($op->other, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($ppname eq "match" || $ppname eq "subst") { my $pmreplstart = $op->pmreplstart; if ($$pmreplstart) { print $prefix, "PMREPLSTART => {\n"; walkoptree_exec($pmreplstart, $method, $level + 1); print $prefix, "}\n"; } - } elsif ($ppname eq "pp_substcont") { + } elsif ($ppname eq "substcont") { print $prefix, "SUBSTCONT => {\n"; walkoptree_exec($op->other->pmreplstart, $method, $level + 1); print $prefix, "}\n"; $op = $op->other; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->false; - redo; - } elsif ($ppname eq "pp_range") { - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n", $prefix, "FALSE => {\n"; - walkoptree_exec($op->false, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($ppname eq "enterloop") { print $prefix, "REDO => {\n"; walkoptree_exec($op->redoop, $method, $level + 1); print $prefix, "}\n", $prefix, "NEXT => {\n"; @@ -173,7 +162,7 @@ sub walkoptree_exec { print $prefix, "}\n", $prefix, "LAST => {\n"; walkoptree_exec($op->lastop, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_subst") { + } elsif ($ppname eq "subst") { my $replstart = $op->pmreplstart; if ($$replstart) { print $prefix, "SUBST => {\n"; @@ -187,9 +176,12 @@ sub walkoptree_exec { sub walksymtable { my ($symref, $method, $recurse, $prefix) = @_; my $sym; + my $ref; no strict 'vars'; local(*glob); - while (($sym, *glob) = each %$symref) { + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) { + *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; if ($sym ne "main::" && &$recurse($sym)) { @@ -267,7 +259,7 @@ sub walksymtable { } } -bootstrap B; +XSLoader::load 'B'; 1; @@ -428,6 +420,10 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =over 4 +=item is_empty + +This method returns TRUE if the GP field of the GV is NULL. + =item NAME =item STASH @@ -450,6 +446,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item LINE +=item FILE + =item FILEGV =item GvREFCNT @@ -518,7 +516,7 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item GV -=item FILEGV +=item FILE =item DEPTH @@ -556,8 +554,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =head2 OP-RELATED CLASSES -B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP, -B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP. +B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP, +B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP. These classes correspond in the obvious way to the underlying C structures of similar names. The inheritance hierarchy mimics the underlying C "inheritance". Access @@ -572,9 +570,14 @@ leading "class indication" prefix removed (op_). =item sibling +=item name + +This returns the op name as a string (e.g. "add", "rv2av"). + =item ppaddr -This returns the function name as a string (e.g. pp_add, pp_rv2av). +This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]", +"PL_ppaddr[OP_RV2AV]"). =item desc @@ -617,16 +620,6 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::CONDOP METHODS - -=over 4 - -=item true - -=item false - -=back - =head2 B::LISTOP METHOD =over 4 @@ -661,13 +654,15 @@ This returns the op description from the global C PL_op_desc array =item sv +=item gv + =back -=head2 B::GVOP METHOD +=head2 B::PADOP METHOD =over 4 -=item gv +=item padix =back @@ -699,7 +694,7 @@ This returns the op description from the global C PL_op_desc array =item stash -=item filegv +=item file =item cop_seq @@ -751,6 +746,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>. Returns the SV object corresponding to the C variable C<sv_no>. +=item amagic_generation + +Returns the SV object corresponding to the C variable C<amagic_generation>. + =item walkoptree(OP, METHOD) Does a tree-walk of the syntax tree based at OP and calls METHOD on @@ -817,11 +816,6 @@ preceding the first "::". This is used to turn "B::UNOP" into In a perl compiled for threads, this returns a list of the special per-thread threadsv variables. -=item byteload_fh(FILEHANDLE) - -Load the contents of FILEHANDLE as bytecode. See documentation for -the B<Bytecode> module in F<B::Backend> for how to generate bytecode. - =back =head1 AUTHOR diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 6610ae8..9e29855 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -7,18 +7,18 @@ * */ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "INTERN.h" #ifdef PERL_OBJECT -#undef op_name -#undef opargs -#undef op_desc -#define op_name (pPerl->Perl_get_op_names()) -#define opargs (pPerl->Perl_get_opargs()) -#define op_desc (pPerl->Perl_get_op_descs()) +#undef PL_op_name +#undef PL_opargs +#undef PL_op_desc +#define PL_op_name (get_op_names()) +#define PL_opargs (get_opargs()) +#define PL_op_desc (get_op_descs()) #endif #ifdef PerlIO @@ -53,15 +53,14 @@ typedef enum { OPc_UNOP, /* 2 */ OPc_BINOP, /* 3 */ OPc_LOGOP, /* 4 */ - OPc_CONDOP, /* 5 */ - OPc_LISTOP, /* 6 */ - OPc_PMOP, /* 7 */ - OPc_SVOP, /* 8 */ - OPc_GVOP, /* 9 */ - OPc_PVOP, /* 10 */ - OPc_CVOP, /* 11 */ - OPc_LOOP, /* 12 */ - OPc_COP /* 13 */ + OPc_LISTOP, /* 5 */ + OPc_PMOP, /* 6 */ + OPc_SVOP, /* 7 */ + OPc_PADOP, /* 8 */ + OPc_PVOP, /* 9 */ + OPc_CVOP, /* 10 */ + OPc_LOOP, /* 11 */ + OPc_COP /* 12 */ } opclass; static char *opclassnames[] = { @@ -70,11 +69,10 @@ static char *opclassnames[] = { "B::UNOP", "B::BINOP", "B::LOGOP", - "B::CONDOP", "B::LISTOP", "B::PMOP", "B::SVOP", - "B::GVOP", + "B::PADOP", "B::PVOP", "B::CVOP", "B::LOOP", @@ -83,8 +81,10 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ +static SV *specialsv_list[4]; + static opclass -cc_opclass(OP *o) +cc_opclass(pTHX_ OP *o) { if (!o) return OPc_NULL; @@ -95,7 +95,12 @@ cc_opclass(OP *o) if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); - switch (opargs[o->op_type] & OA_CLASS_MASK) { +#ifdef USE_ITHREADS + if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) + return OPc_PADOP; +#endif + + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: return OPc_BASEOP; @@ -108,9 +113,6 @@ cc_opclass(OP *o) case OA_LOGOP: return OPc_LOGOP; - case OA_CONDOP: - return OPc_CONDOP; - case OA_LISTOP: return OPc_LISTOP; @@ -120,11 +122,19 @@ cc_opclass(OP *o) case OA_SVOP: return OPc_SVOP; - case OA_GVOP: - return OPc_GVOP; + case OA_PADOP: + return OPc_PADOP; - case OA_PVOP: - return OPc_PVOP; + case OA_PVOP_OR_SVOP: + /* + * Character translations (tr///) are usually a PVOP, keeping a + * pointer to a table of shorts used to look up translations. + * Under utf8, however, a simple table isn't practical; instead, + * the OP is an SVOP, and the SV is a reference to a swash + * (i.e., an RV pointing to an HV). + */ + return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) + ? OPc_SVOP : OPc_PVOP; case OA_LOOP: return OPc_LOOP; @@ -150,11 +160,14 @@ cc_opclass(OP *o) * return OPc_UNOP so that walkoptree can find our children. If * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set * (no argument to the operator) it's an OP; with OPf_REF set it's - * a GVOP (and op_gv is the GV for the filehandle argument). + * an SVOP (and op_sv is the GV for the filehandle argument). */ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : - (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP); - +#ifdef USE_ITHREADS + (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); +#else + (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); +#endif case OA_LOOPEXOP: /* * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a @@ -173,47 +186,47 @@ cc_opclass(OP *o) return OPc_PVOP; } warn("can't determine class of operator %s, assuming BASEOP\n", - op_name[o->op_type]); + PL_op_name[o->op_type]); return OPc_BASEOP; } static char * -cc_opclassname(OP *o) +cc_opclassname(pTHX_ OP *o) { - return opclassnames[cc_opclass(o)]; + return opclassnames[cc_opclass(aTHX_ o)]; } static SV * -make_sv_object(SV *arg, SV *sv) +make_sv_object(pTHX_ SV *arg, SV *sv) { char *type = 0; IV iv; - for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) { - if (sv == PL_specialsv_list[iv]) { + for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { + if (sv == specialsv_list[iv]) { type = "B::SPECIAL"; break; } } if (!type) { type = svclassnames[SvTYPE(sv)]; - iv = (IV)sv; + iv = PTR2IV(sv); } sv_setiv(newSVrv(arg, type), iv); return arg; } static SV * -make_mg_object(SV *arg, MAGIC *mg) +make_mg_object(pTHX_ SV *arg, MAGIC *mg) { - sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg); + sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); return arg; } static SV * -cstring(SV *sv) +cstring(pTHX_ SV *sv) { - SV *sstr = newSVpv("", 0); + SV *sstr = newSVpvn("", 0); STRLEN len; char *s; @@ -264,9 +277,9 @@ cstring(SV *sv) } static SV * -cchar(SV *sv) +cchar(pTHX_ SV *sv) { - SV *sstr = newSVpv("'", 0); + SV *sstr = newSVpvn("'", 1); STRLEN n_a; char *s = SvPV(sv, n_a); @@ -303,76 +316,8 @@ cchar(SV *sv) return sstr; } -#ifdef INDIRECT_BGET_MACROS -void freadpv(U32 len, void *data) -{ - New(666, pv.xpv_pv, len, char); - fread(pv.xpv_pv, 1, len, (FILE*)data); - pv.xpv_len = len; - pv.xpv_cur = len - 1; -} - -void byteload_fh(InputStream fp) -{ - struct bytestream bs; - bs.data = fp; - bs.fgetc = (int(*) _((void*)))fgetc; - bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; - bs.freadpv = freadpv; - byterun(bs); -} - -static int fgetc_fromstring(void *data) -{ - char **strp = (char **)data; - return *(*strp)++; -} - -static int fread_fromstring(char *argp, size_t elemsize, size_t nelem, - void *data) -{ - char **strp = (char **)data; - size_t len = elemsize * nelem; - - memcpy(argp, *strp, len); - *strp += len; - return (int)len; -} - -static void freadpv_fromstring(U32 len, void *data) -{ - char **strp = (char **)data; - - New(666, pv.xpv_pv, len, char); - memcpy(pv.xpv_pv, *strp, len); - pv.xpv_len = len; - pv.xpv_cur = len - 1; - *strp += len; -} - -void byteload_string(char *str) -{ - struct bytestream bs; - bs.data = &str; - bs.fgetc = fgetc_fromstring; - bs.fread = fread_fromstring; - bs.freadpv = freadpv_fromstring; - byterun(bs); -} -#else -void byteload_fh(InputStream fp) -{ - byterun(fp); -} - -void byteload_string(char *str) -{ - croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string"); -} -#endif /* INDIRECT_BGET_MACROS */ - void -walkoptree(SV *opsv, char *method) +walkoptree(pTHX_ SV *opsv, char *method) { dSP; OP *o; @@ -380,7 +325,7 @@ walkoptree(SV *opsv, char *method) if (!SvROK(opsv)) croak("opsv is not a reference"); opsv = sv_mortalcopy(opsv); - o = (OP*)SvIV((SV*)SvRV(opsv)); + o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); if (walkoptree_debug) { PUSHMARK(sp); XPUSHs(opsv); @@ -395,8 +340,8 @@ walkoptree(SV *opsv, char *method) OP *kid; for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { /* Use the same opsv. Rely on methods not to mess it up. */ - sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid); - walkoptree(opsv, method); + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); + walkoptree(aTHX_ opsv, method); } } } @@ -405,11 +350,10 @@ typedef OP *B__OP; typedef UNOP *B__UNOP; typedef BINOP *B__BINOP; typedef LOGOP *B__LOGOP; -typedef CONDOP *B__CONDOP; typedef LISTOP *B__LISTOP; typedef PMOP *B__PMOP; typedef SVOP *B__SVOP; -typedef GVOP *B__GVOP; +typedef PADOP *B__PADOP; typedef PVOP *B__PVOP; typedef LOOP *B__LOOP; typedef COP *B__COP; @@ -435,12 +379,21 @@ MODULE = B PACKAGE = B PREFIX = B_ PROTOTYPES: DISABLE BOOT: - INIT_SPECIALSV_LIST; +{ + HV *stash = gv_stashpvn("B", 1, TRUE); + AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); + specialsv_list[0] = Nullsv; + specialsv_list[1] = &PL_sv_undef; + specialsv_list[2] = &PL_sv_yes; + specialsv_list[3] = &PL_sv_no; +#include "defsubs.h" +} #define B_main_cv() PL_main_cv #define B_init_av() PL_initav #define B_main_root() PL_main_root #define B_main_start() PL_main_start +#define B_amagic_generation() PL_amagic_generation #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) #define B_sv_undef() &PL_sv_undef #define B_sv_yes() &PL_sv_yes @@ -458,6 +411,9 @@ B_main_root() B::OP B_main_start() +long +B_amagic_generation() + B::AV B_comppadlist() @@ -477,6 +433,8 @@ void walkoptree(opsv, method) SV * opsv char * method + CODE: + walkoptree(aTHX_ opsv, method); int walkoptree_debug(...) @@ -487,20 +445,7 @@ walkoptree_debug(...) OUTPUT: RETVAL -int -byteload_fh(fp) - InputStream fp - CODE: - byteload_fh(fp); - RETVAL = 1; - OUTPUT: - RETVAL - -void -byteload_string(str) - char * str - -#define address(sv) (IV)sv +#define address(sv) PTR2IV(sv) IV address(sv) @@ -514,7 +459,28 @@ svref_2object(sv) croak("argument is not a reference"); RETVAL = (SV*)SvRV(sv); OUTPUT: - RETVAL + RETVAL + +void +opnumber(name) +char * name +CODE: +{ + int i; + IV result = -1; + ST(0) = sv_newmortal(); + if (strncmp(name,"pp_",3) == 0) + name += 3; + for (i = 0; i < PL_maxo; i++) + { + if (strcmp(name, PL_op_name[i]) == 0) + { + result = i; + break; + } + } + sv_setiv(ST(0),result); +} void ppname(opnum) @@ -523,7 +489,7 @@ ppname(opnum) ST(0) = sv_newmortal(); if (opnum >= 0 && opnum < PL_maxo) { sv_setpvn(ST(0), "pp_", 3); - sv_catpv(ST(0), op_name[opnum]); + sv_catpv(ST(0), PL_op_name[opnum]); } void @@ -533,11 +499,10 @@ hash(sv) char *s; STRLEN len; U32 hash = 0; - char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */ + char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ s = SvPV(sv, len); - while (len--) - hash = hash * 33 + *s++; - sprintf(hexhash, "0x%x", hash); + PERL_HASH(hash, s, len); + sprintf(hexhash, "0x%"UVxf, (UV)hash); ST(0) = sv_2mortal(newSVpv(hexhash, 0)); #define cast_I32(foo) (I32)foo @@ -553,10 +518,18 @@ minus_c() SV * cstring(sv) SV * sv + CODE: + RETVAL = cstring(aTHX_ sv); + OUTPUT: + RETVAL SV * cchar(sv) SV * sv + CODE: + RETVAL = cchar(aTHX_ sv); + OUTPUT: + RETVAL void threadsv_names() @@ -567,13 +540,13 @@ threadsv_names() EXTEND(sp, len); for (i = 0; i < len; i++) - PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1))); + PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); #endif #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling -#define OP_desc(o) op_desc[o->op_type] +#define OP_desc(o) PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type #define OP_seq(o) o->op_seq @@ -591,18 +564,32 @@ OP_sibling(o) B::OP o char * -OP_ppaddr(o) +OP_name(o) B::OP o CODE: ST(0) = sv_newmortal(); - sv_setpvn(ST(0), "pp_", 3); - sv_catpv(ST(0), op_name[o->op_type]); + sv_setpv(ST(0), PL_op_name[o->op_type]); + + +char * +OP_ppaddr(o) + B::OP o + PREINIT: + int i; + SV *sv = sv_newmortal(); + CODE: + sv_setpvn(sv, "PL_ppaddr[OP_", 13); + sv_catpv(sv, PL_op_name[o->op_type]); + for (i=13; i<SvCUR(sv); ++i) + SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); + sv_catpv(sv, "]"); + ST(0) = sv; char * OP_desc(o) B::OP o -U16 +PADOFFSET OP_targ(o) B::OP o @@ -646,19 +633,6 @@ B::OP LOGOP_other(o) B::LOGOP o -#define CONDOP_true(o) o->op_true -#define CONDOP_false(o) o->op_false - -MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_ - -B::OP -CONDOP_true(o) - B::CONDOP o - -B::OP -CONDOP_false(o) - B::CONDOP o - #define LISTOP_children(o) o->op_children MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ @@ -687,10 +661,10 @@ PMOP_pmreplroot(o) if (o->op_type == OP_PUSHRE) { sv_setiv(newSVrv(ST(0), root ? svclassnames[SvTYPE((SV*)root)] : "B::SV"), - (IV)root); + PTR2IV(root)); } else { - sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root); + sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); } B::OP @@ -719,23 +693,38 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) o->op_sv +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ - B::SV SVOP_sv(o) B::SVOP o -#define GVOP_gv(o) o->op_gv +B::GV +SVOP_gv(o) + B::SVOP o + +#define PADOP_padix(o) o->op_padix +#define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv) +#define PADOP_gv(o) ((o->op_padix \ + && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \ + ? (GV*)PL_curpad[o->op_padix] : Nullgv) + +MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ -MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_ +PADOFFSET +PADOP_padix(o) + B::PADOP o +B::SV +PADOP_sv(o) + B::PADOP o B::GV -GVOP_gv(o) - B::GVOP o +PADOP_gv(o) + B::PADOP o MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ @@ -770,11 +759,13 @@ LOOP_lastop(o) B::LOOP o #define COP_label(o) o->cop_label -#define COP_stash(o) o->cop_stash -#define COP_filegv(o) o->cop_filegv +#define COP_stashpv(o) CopSTASHPV(o) +#define COP_stash(o) CopSTASH(o) +#define COP_file(o) CopFILE(o) #define COP_cop_seq(o) o->cop_seq #define COP_arybase(o) o->cop_arybase -#define COP_line(o) o->cop_line +#define COP_line(o) CopLINE(o) +#define COP_warnings(o) o->cop_warnings MODULE = B PACKAGE = B::COP PREFIX = COP_ @@ -782,12 +773,16 @@ char * COP_label(o) B::COP o +char * +COP_stashpv(o) + B::COP o + B::HV COP_stash(o) B::COP o -B::GV -COP_filegv(o) +char * +COP_file(o) B::COP o U32 @@ -802,6 +797,10 @@ U16 COP_line(o) B::COP o +B::SV +COP_warnings(o) + B::COP o + MODULE = B PACKAGE = B::SV PREFIX = Sv U32 @@ -822,6 +821,11 @@ IV SvIVX(sv) B::IV sv +UV +SvUVX(sv) + B::IV sv + + MODULE = B PACKAGE = B::IV #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) @@ -844,12 +848,16 @@ packiv(sv) * reach this code anyway (unless sizeof(IV) > 8 but then * everything else breaks too so I'm not fussed at the moment). */ - wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4)); +#ifdef UV_IS_QUAD + wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); +#else + wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); +#endif wp[1] = htonl(iv & 0xffffffff); - ST(0) = sv_2mortal(newSVpv((char *)wp, 8)); + ST(0) = sv_2mortal(newSVpvn((char *)wp, 8)); } else { U32 w = htonl((U32)SvIVX(sv)); - ST(0) = sv_2mortal(newSVpv((char *)&w, 4)); + ST(0) = sv_2mortal(newSVpvn((char *)&w, 4)); } MODULE = B PACKAGE = B::NV PREFIX = Sv @@ -877,6 +885,14 @@ SvPV(sv) ST(0) = sv_newmortal(); sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); +STRLEN +SvLEN(sv) + B::PV sv + +STRLEN +SvCUR(sv) + B::PV sv + MODULE = B PACKAGE = B::PVMG PREFIX = Sv void @@ -885,7 +901,7 @@ SvMAGIC(sv) MAGIC * mg = NO_INIT PPCODE: for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) - XPUSHs(make_mg_object(sv_newmortal(), mg)); + XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg)); MODULE = B PACKAGE = B::PVMG @@ -898,6 +914,7 @@ SvSTASH(sv) #define MgTYPE(mg) mg->mg_type #define MgFLAGS(mg) mg->mg_flags #define MgOBJ(mg) mg->mg_obj +#define MgLENGTH(mg) mg->mg_len MODULE = B PACKAGE = B::MAGIC PREFIX = Mg @@ -921,13 +938,23 @@ B::SV MgOBJ(mg) B::MAGIC mg +I32 +MgLENGTH(mg) + B::MAGIC mg + void MgPTR(mg) B::MAGIC mg CODE: ST(0) = sv_newmortal(); - if (mg->mg_ptr) - sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); + if (mg->mg_ptr){ + if (mg->mg_len >= 0){ + sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); + } else { + if (mg->mg_len == HEf_SVKEY) + sv_setsv(ST(0),newRV((SV*)mg->mg_ptr)); + } + } MODULE = B PACKAGE = B::PVLV PREFIX = Lv @@ -969,7 +996,7 @@ BmTABLE(sv) CODE: str = SvPV(sv, len); /* Boyer-Moore table is just after string and its safety-margin \0 */ - ST(0) = sv_2mortal(newSVpv(str + len + 1, 256)); + ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256)); MODULE = B PACKAGE = B::GV PREFIX = Gv @@ -977,7 +1004,15 @@ void GvNAME(gv) B::GV gv CODE: - ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv))); + ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); + +bool +is_empty(gv) + B::GV gv + CODE: + RETVAL = GvGP(gv) == Null(GP*); + OUTPUT: + RETVAL B::HV GvSTASH(gv) @@ -1019,6 +1054,10 @@ U16 GvLINE(gv) B::GV gv +char * +GvFILE(gv) + B::GV gv + B::GV GvFILEGV(gv) B::GV gv @@ -1113,7 +1152,7 @@ AvARRAY(av) SV **svp = AvARRAY(av); I32 i; for (i = 0; i <= AvFILL(av); i++) - XPUSHs(make_sv_object(sv_newmortal(), svp[i])); + XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); } MODULE = B PACKAGE = B::AV @@ -1140,8 +1179,8 @@ B::GV CvGV(cv) B::CV cv -B::GV -CvFILEGV(cv) +char * +CvFILE(cv) B::CV cv long @@ -1160,7 +1199,7 @@ void CvXSUB(cv) B::CV cv CODE: - ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv))); + ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv)))); void @@ -1213,7 +1252,7 @@ HvARRAY(hv) (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); while (sv = hv_iternextsv(hv, &key, &len)) { - PUSHs(newSVpv(key, len)); - PUSHs(make_sv_object(sv_newmortal(), sv)); + PUSHs(newSVpvn(key, len)); + PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm index f3e57a1..bc0eda9 100644 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ b/contrib/perl5/ext/B/B/Asmdata.pm @@ -1,5 +1,5 @@ # -# Copyright (c) 1996-1998 Malcolm Beattie +# Copyright (c) 1996-1999 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. @@ -12,9 +12,9 @@ package B::Asmdata; use Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -use vars qw(%insn_data @insn_name @optype @specialsv_name); +our(%insn_data, @insn_name, @optype, @specialsv_name); -@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); +@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); # XXX insn_data is initialised this way because with a large @@ -42,7 +42,7 @@ $insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"]; $insn_data{xpv} = [18, \&PUT_none, "GET_none"]; $insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; $insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [21, \&PUT_double, "GET_double"]; +$insn_data{xnv} = [21, \&PUT_NV, "GET_NV"]; $insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"]; @@ -68,11 +68,11 @@ $insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"]; $insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"]; $insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"]; $insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_filegv} = [48, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_file} = [48, \&PUT_pvcontents, "GET_pvcontents"]; $insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"]; $insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"]; $insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_flags} = [52, \&PUT_U16, "GET_U16"]; $insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"]; $insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"]; $insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"]; @@ -95,7 +95,7 @@ $insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"]; $insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_filegv} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_file} = [75, \&PUT_pvcontents, "GET_pvcontents"]; $insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"]; @@ -113,32 +113,31 @@ $insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; $insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"]; $insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"]; $insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"]; -$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"]; -$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; -$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"]; -$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_children} = [93, \&PUT_U32, "GET_U32"]; +$insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmnext} = [97, \&PUT_opindex, "GET_opindex"]; +$insn_data{pregcomp} = [98, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pmflags} = [99, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmpermflags} = [100, \&PUT_U16, "GET_U16"]; +$insn_data{op_sv} = [101, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_padix} = [102, \&PUT_U32, "GET_U32"]; +$insn_data{op_pv} = [103, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"]; +$insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"]; +$insn_data{cop_label} = [108, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_stashpv} = [109, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_file} = [110, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"]; +$insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"]; +$insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"]; +$insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"]; +$insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"]; +$insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index 06e00ad..6c51a9a 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -52,6 +52,7 @@ sub B::Asmdata::PUT_U8 { 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_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } diff --git a/contrib/perl5/ext/B/B/Bblock.pm b/contrib/perl5/ext/B/B/Bblock.pm index a54431b..fe7fc52 100644 --- a/contrib/perl5/ext/B/B/Bblock.pm +++ b/contrib/perl5/ext/B/B/Bblock.pm @@ -4,7 +4,9 @@ use Exporter (); @EXPORT_OK = qw(find_leaders); use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object); + main_root main_start svref_2object + OPf_SPECIAL OPf_STACKED ); + use B::Terse; use strict; @@ -18,11 +20,18 @@ sub mark_leader { } } +sub remove_sortblock{ + foreach (keys %$bblock){ + my $leader=$$bblock{$_}; + delete $$bblock{$_} if( $leader == 0); + } +} sub find_leaders { my ($root, $start) = @_; $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); + mark_leader($start) if ( ref $start ne "B::NULL" ); + walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; + remove_sortblock(); return $bblock; } @@ -81,25 +90,32 @@ sub B::LOOP::mark_if_leader { sub B::LOGOP::mark_if_leader { my $op = shift; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; mark_leader($op->next); - if ($ppaddr eq "pp_entertry") { + if ($opname eq "entertry") { mark_leader($op->other->next); } else { mark_leader($op->other); } } -sub B::CONDOP::mark_if_leader { +sub B::LISTOP::mark_if_leader { my $op = shift; + my $first=$op->first; + $first=$first->next while ($first->name eq "null"); + mark_leader($op->first) unless (exists( $bblock->{$$first})); mark_leader($op->next); - mark_leader($op->true); - mark_leader($op->false); + if ($op->name eq "sort" and $op->flags & OPf_SPECIAL + and $op->flags & OPf_STACKED){ + my $root=$op->first->sibling->first; + my $leader=$root->first; + $bblock->{$$leader} = 0; + } } sub B::PMOP::mark_if_leader { my $op = shift; - if ($op->ppaddr ne "pp_pushre") { + if ($op->name ne "pushre") { my $replroot = $op->pmreplroot; if ($$replroot) { mark_leader($replroot); @@ -113,6 +129,7 @@ sub B::PMOP::mark_if_leader { sub compile { my @options = @_; + B::clearsym(); if (@options) { return sub { my $objname; @@ -134,7 +151,6 @@ sub compile { # The ops pointed at by nextop, redoop and lastop->op_next of a LOOP # The ops pointed at by op_next and op_other of a LOGOP, except # for pp_entertry which has op_next and op_other->op_next -# The ops pointed at by op_true and op_false of a CONDOP # The op pointed at by op_pmreplstart of a PMOP # The op pointed at by op_other->op_pmreplstart of pp_substcont? # [The op after a pp_return] Omit @@ -153,7 +169,9 @@ B::Bblock - Walk basic blocks =head1 DESCRIPTION -See F<ext/B/README>. +This module is used by the B::CC back end. It walks "basic blocks". +A basic block is a series of operations which is known to execute from +start to finish, with no possiblity of branching or halting. =head1 AUTHOR diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm index 0c5a58d..27003b6 100644 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -11,7 +11,9 @@ use Carp; use IO::File; use B qw(minus_c main_cv main_root main_start comppadlist - class peekop walkoptree svref_2object cstring walksymtable); + class peekop walkoptree svref_2object cstring walksymtable + SVf_POK SVp_POK SVf_IOK SVp_IOK + ); use B::Asmdata qw(@optype @specialsv_name); use B::Assembler qw(assemble_fh); @@ -23,11 +25,11 @@ for ($i = 0; $i < @optype; $i++) { # Following is SVf_POK|SVp_POK # XXX Shouldn't be hardwired -sub POK () { 0x04040000 } +sub POK () { SVf_POK|SVp_POK } -# Following is SVf_IOK|SVp_OK +# Following is SVf_IOK|SVp_IOK # XXX Shouldn't be hardwired -sub IOK () { 0x01010000 } +sub IOK () { SVf_IOK|SVp_IOK } my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); my $assembler_pid; @@ -191,7 +193,7 @@ sub B::OP::bytecode { ldop($ix); print "op_next $nextix\n"; print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", $op->ppaddr, $type; + printf "op_type %s\t# %d\n", "pp_" . $op->name, $type; printf("op_seq %d\n", $op->seq) unless $omit_seq; if ($type || !$compress_nullops) { printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", @@ -224,13 +226,11 @@ sub B::SVOP::bytecode { $sv->bytecode; } -sub B::GVOP::bytecode { +sub B::PADOP::bytecode { my $op = shift; - my $gv = $op->gv; - my $gvix = $gv->objix; + my $padix = $op->padix; $op->B::OP::bytecode; - print "op_gv $gvix\n"; - $gv->bytecode; + print "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -241,7 +241,7 @@ sub B::PVOP::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->ppaddr eq "pp_trans") { + if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness print "op_pv_tr ", join(",", @shorts), "\n"; } else { @@ -258,14 +258,6 @@ sub B::BINOP::bytecode { } } -sub B::CONDOP::bytecode { - my $op = shift; - my $trueix = $op->true->objix; - my $falseix = $op->false->objix; - $op->B::UNOP::bytecode; - print "op_true $trueix\nop_false $falseix\n"; -} - sub B::LISTOP::bytecode { my $op = shift; my $children = $op->children; @@ -286,26 +278,27 @@ sub B::LOOP::bytecode { sub B::COP::bytecode { my $op = shift; - my $stash = $op->stash; - my $stashix = $stash->objix; - my $filegv = $op->filegv; - my $filegvix = $filegv->objix; + my $stashpv = $op->stashpv; + my $file = $op->file; my $line = $op->line; + my $warnings = $op->warnings; + my $warningsix = $warnings->objix; if ($debug_bc) { - printf "# line %s:%d\n", $filegv->SV->PV, $line; + printf "# line %s:%d\n", $file, $line; } $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase; + printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; newpv %s cop_label -cop_stash $stashix +newpv %s +cop_stashpv cop_seq %d -cop_filegv $filegvix +newpv %s +cop_file cop_arybase %d cop_line $line +cop_warnings $warningsix EOT - $filegv->bytecode; - $stash->bytecode; } sub B::PMOP::bytecode { @@ -313,7 +306,7 @@ sub B::PMOP::bytecode { my $replroot = $op->pmreplroot; my $replrootix = $replroot->objix; my $replstartix = $op->pmreplstart->objix; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; # pmnext is corrupt in some PMOPs (see misc.t for example) #my $pmnextix = $op->pmnext->objix; @@ -321,14 +314,14 @@ sub B::PMOP::bytecode { # 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 ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { $replroot->bytecode; } else { walkoptree($replroot, "bytecode"); } } $op->B::LISTOP::bytecode; - if ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { printf "op_pmreplrootgv $replrootix\n"; } else { print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; @@ -395,7 +388,8 @@ sub B::PVIV::bytecode { } sub B::PVNV::bytecode { - my ($sv, $flag) = @_; + 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 @@ -469,18 +463,23 @@ sub B::GV::bytecode { return if saved($gv); my $ix = $gv->objix; mark_saved($gv); - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - my $egv = $gv->EGV; - my $egvix = $egv->objix; ldsv($ix); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE; + printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x -gp_line %d EOT my $refcnt = $gv->REFCNT; printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + return if $gv->is_empty; + printf <<"EOT", $gv->LINE, pvstring($gv->FILE); +gp_line %d +newpv %s +gp_file +EOT + my $gvname = $gv->NAME; + my $name = cstring($gv->STASH->NAME . "::" . $gvname); + my $egv = $gv->EGV; + my $egvix = $egv->objix; my $gvrefcnt = $gv->GvREFCNT; printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { @@ -488,7 +487,7 @@ EOT } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; - my @subfield_names = qw(SV AV HV CV FILEGV FORM IO); + my @subfield_names = qw(SV AV HV CV FORM IO); my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv @@ -571,7 +570,7 @@ sub B::CV::bytecode { my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; - my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE); + 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) @@ -584,7 +583,8 @@ sub B::CV::bytecode { for ($i = 0; $i < @ixes; $i++) { printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS; + printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + printf "newpv %s\nxcv_file\n", pvstring($cv->FILE); # 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 @@ -653,7 +653,7 @@ sub bytecompile_main { walkoptree(main_root, "bytecode"); warn "done main program, now walking symbol table\n" if $debug_bc; my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol SelectSaver blib Cwd)) { @@ -707,6 +707,10 @@ sub compile { $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)) { @@ -816,6 +820,10 @@ extra arguments, it saves the main program. Output to filename instead of STDOUT. +=item B<-afilename> + +Append output to filename. + =item B<--> Force end of options. @@ -889,13 +897,16 @@ C<main_root> and C<curpad> are omitted. =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + + perl -MO=Bytecode,-S foo.pl > foo.S + assemble foo.S > foo.plc - perl -MO=Bytecode,-S foo.pl > foo.S - assemble foo.S > foo.plc - byteperl 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,-m,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm =head1 BUGS diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index e695cc2..d0c8159 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -5,34 +5,75 @@ # 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::C::Section; +use B (); +use base B::Section; + +sub new +{ + my $class = shift; + my $o = $class->SUPER::new(@_); + push(@$o,[]); + return $o; +} + +sub add +{ + my $section = shift; + push(@{$section->[-1]},@_); +} + +sub index +{ + my $section = shift; + return scalar(@{$section->[-1]})-1; +} + +sub output +{ + my ($section, $fh, $format) = @_; + my $sym = $section->symtable || {}; + my $default = $section->default; + foreach (@{$section->[-1]}) + { + s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; + printf $fh $format, $_; + } +} + package B::C; use Exporter (); @ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main - init_sections set_callback save_unused_subs objsym); +@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused + init_sections set_callback save_unused_subs objsym save_context); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av); + threadsv_names main_cv init_av opnumber amagic_generation + AVf_REAL HEf_SVKEY); use B::Asmdata qw(@specialsv_name); use FileHandle; use Carp; use strict; +use Config; my $hv_index = 0; my $gv_index = 0; my $re_index = 0; my $pv_index = 0; my $anonsub_index = 0; +my $initsub_index = 0; my %symtable; +my %xsub; my $warn_undefined_syms; my $verbose; -my @unused_sub_packages; +my %unused_sub_packages; my $nullop_count; -my $pv_copy_on_grow; +my $pv_copy_on_grow = 0; my ($debug_cops, $debug_av, $debug_cv, $debug_mg); +my $max_string_len; my @threadsv_names; BEGIN { @@ -40,11 +81,11 @@ BEGIN { } # Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, - $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, +my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, + $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect, $bootstrap); + $xrvsect, $xpvbmsect, $xpviosect ); sub walk_and_save_optree; my $saveoptree_callback = \&walk_and_save_optree; @@ -66,11 +107,9 @@ sub walk_and_save_optree { # to "know" that op_seq is a U16 and use 65535. Ugh. my $op_seq = 65535; -sub AVf_REAL () { 1 } - -# XXX This shouldn't really be hardcoded here but it saves -# looking up the name of every BASEOP in B::OP -sub OP_THREADSV () { 345 } +# Look this up here so we can do just a number compare +# rather than looking up the name of every BASEOP in B::OP +my $OP_THREADSV = opnumber('threadsv'); sub savesym { my ($obj, $value) = @_; @@ -98,10 +137,11 @@ sub getsym { } sub savepv { - my $pv = shift; + my $pv = shift; + $pv = '' unless defined $pv; # Is this sane ? my $pvsym = 0; my $pvmax = 0; - if ($pv_copy_on_grow) { + if ($pv_copy_on_grow) { my $cstring = cstring($pv); if ($cstring ne "0") { # sic $pvsym = sprintf("pv%d", $pv_index++); @@ -115,17 +155,21 @@ sub savepv { sub B::OP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $type = $op->type; $nullop_count++ unless $type; - if ($type == OP_THREADSV) { + if ($type == $OP_THREADSV) { # saves looking up ppaddr but it's a bit naughty to hard code this $init->add(sprintf("(void)find_threadsv(%s);", cstring($threadsv_names[$op->targ]))); } - $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, + $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $op->targ, $type, $op_seq, $op->flags, $op->private)); - savesym($op, sprintf("&op_list[%d]", $opsect->index)); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "&op_list[$ix]"); } sub B::FAKEOP::new { @@ -135,10 +179,12 @@ sub B::FAKEOP::new { sub B::FAKEOP::save { my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", - $op->next, $op->sibling, $op->ppaddr, $op->targ, + $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x", + $op->next, $op->sibling, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); - return sprintf("&op_list[%d]", $opsect->index); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + return "&op_list[$ix]"; } sub B::FAKEOP::next { $_[0]->{"next"} || 0 } @@ -151,114 +197,139 @@ sub B::FAKEOP::private { $_[0]->{private} || 0 } sub B::UNOP::save { my ($op, $level) = @_; - $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first})); - savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index)); + my $ix = $unopsect->index; + $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&unop_list[$ix]"); } sub B::BINOP::save { my ($op, $level) = @_; - $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last})); - savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index)); + my $ix = $binopsect->index; + $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&binop_list[$ix]"); } sub B::LISTOP::save { my ($op, $level) = @_; - $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children)); - savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index)); + my $ix = $listopsect->index; + $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&listop_list[$ix]"); } sub B::LOGOP::save { my ($op, $level) = @_; - $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->other})); - savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index)); -} - -sub B::CONDOP::save { - my ($op, $level) = @_; - $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->true}, - ${$op->false})); - savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index)); + my $ix = $logopsect->index; + $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&logop_list[$ix]"); } sub B::LOOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children, ${$op->redoop}, ${$op->nextop}, ${$op->lastop})); - savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index)); + my $ix = $loopsect->index; + $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&loop_list[$ix]"); } sub B::PVOP::save { my ($op, $level) = @_; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->pv))); - savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index)); + my $ix = $pvopsect->index; + $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&pvop_list[$ix]"); } sub B::SVOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, - $op->private, "(SV*)$svsym")); - savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index)); + $op->private)); + my $ix = $svopsect->index; + $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + $init->add("svop_list[$ix].op_sv = (SV*)$svsym;"); + savesym($op, "(OP*)&svop_list[$ix]"); } -sub B::GVOP::save { +sub B::PADOP::save { my ($op, $level) = @_; - my $gvsym = $op->gv->save; - $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); - $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym)); - savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index)); + $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr)); + my $ix = $padopsect->index; + $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); + savesym($op, "(OP*)&padop_list[$ix]"); } sub B::COP::save { my ($op, $level) = @_; - my $gvsym = $op->filegv->save; - my $stashsym = $op->stash->save; - warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV) + my $sym = objsym($op); + return $sym if defined $sym; + warn sprintf("COP: line %d file %s\n", $op->line, $op->file) if $debug_cops; - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->label), $op->cop_seq, $op->arybase, $op->line)); - my $copix = $copsect->index; - $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym), - sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym)); - savesym($op, "(OP*)&cop_list[$copix]"); + my $ix = $copsect->index; + $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), + sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); + savesym($op, "(OP*)&cop_list[$ix]"); } sub B::PMOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $replroot = $op->pmreplroot; my $replstart = $op->pmreplstart; my $replrootfield = sprintf("s\\_%x", $$replroot); @@ -269,7 +340,7 @@ sub B::PMOP::save { # 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 ($ppaddr eq "pp_pushre") { + if ($op->name eq "pushre") { $gvsym = $replroot->save; # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug $replrootfield = 0; @@ -280,13 +351,14 @@ sub B::PMOP::save { # pmnext handling is broken in perl itself, I think. Bad op_pmnext # fields aren't noticed in perl's runtime (unless you try reset) but we # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ, + $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children, $replrootfield, $replstartfield, $op->pmflags, $op->pmpermflags,)); my $pm = sprintf("pmop_list[%d]", $pmopsect->index); + $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)); my $re = $op->precomp; if (defined($re)) { my $resym = sprintf("re%d", $re_index++); @@ -297,7 +369,7 @@ sub B::PMOP::save { if ($gvsym) { $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); } - savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index)); + savesym($op, "(OP*)&$pm"); } sub B::SPECIAL::save { @@ -319,10 +391,11 @@ sub B::NULL::save { return $sym if defined $sym; # warn "Saving SVt_NULL SV\n"; # debug # debug - #if ($$sv == 0) { - # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; - #} - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS)); + if ($$sv == 0) { + warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; + return savesym($sv, "Nullsv /* XXX */"); + } + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -332,7 +405,7 @@ sub B::IV::save { return $sym if defined $sym; $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -340,12 +413,35 @@ sub B::NV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } +sub savepvn { + my ($dest,$pv) = @_; + my @res; + if (defined $max_string_len && length($pv) > $max_string_len) { + push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1); + my $offset = 0; + while (length $pv) { + my $str = substr $pv, 0, $max_string_len, ''; + push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", + cstring($str), length($str)); + $offset += length $str; + } + push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); + } + else { + push @res, sprintf("%s = savepvn(%s, %u);", $dest, + cstring($pv), length($pv)); + } + return @res; +} + sub B::PVLV::save { my ($sv) = @_; my $sym = objsym($sv); @@ -358,10 +454,10 @@ sub B::PVLV::save { $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvlvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", + $xpvlvsect->index), $pv)); } $sv->save_magic; return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -376,10 +472,10 @@ sub B::PVIV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvivsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", + $xpvivsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -388,16 +484,19 @@ sub B::PVNV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - my $pv = $sv->PV; + my $pv = $sv->PV; + $pv = '' unless defined $pv; my $len = length($pv); my ($pvsym, $pvmax) = savepv($pv); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $pvsym, $len, $pvmax, $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", - $xpvnvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", + $xpvnvsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -412,10 +511,10 @@ sub B::BM::save { $len, $len + 258, $sv->IVX, $sv->NVX, $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); $sv->save_magic; - $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvbmsect->index, cstring($pv), $len), + $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", + $xpvbmsect->index), $pv), sprintf("xpvbm_list[%d].xpv_cur = %u;", $xpvbmsect->index, $len - 257)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -430,10 +529,10 @@ sub B::PV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", + $xpvsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -448,10 +547,10 @@ sub B::PVMG::save { $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvmgsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", + $xpvmgsect->index), $pv)); } $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); $sv->save_magic; @@ -462,6 +561,7 @@ sub B::PVMG::save_magic { my ($sv) = @_; #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug my $stash = $sv->SvSTASH; + $stash->save; if ($$stash) { warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) if $debug_mg; @@ -469,19 +569,27 @@ sub B::PVMG::save_magic { $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); } my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr); + my ($mg, $type, $obj, $ptr,$len,$ptrsv); foreach $mg (@mgchain) { $type = $mg->TYPE; $obj = $mg->OBJ; $ptr = $mg->PTR; - my $len = defined($ptr) ? length($ptr) : 0; + $len=$mg->LENGTH; if ($debug_mg) { warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", class($sv), $$sv, class($obj), $$obj, cchar($type), cstring($ptr)); } - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", + $obj->save; + if ($len == HEf_SVKEY){ + #The pointer is an SV* + $ptrsv=svref_2object($ptr)->save; + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", + $$sv, $$obj, cchar($type),$ptrsv,$len)); + }else{ + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", $$sv, $$obj, cchar($type),cstring($ptr),$len)); + } } } @@ -489,9 +597,11 @@ sub B::RV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xrvsect->add($sv->RV->save); + my $rv = $sv->RV->save; + $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; + $xrvsect->add($rv); $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -516,7 +626,7 @@ sub try_autoload { } } } - +sub Dummy_initxs{}; sub B::CV::save { my ($cv) = @_; my $sym = objsym($cv); @@ -525,18 +635,43 @@ sub B::CV::save { return $sym; } # Reserve a place in svsect and xpvcvsect and record indices + my $gv = $cv->GV; + my ($cvname, $cvstashname); + if ($$gv){ + $cvname = $gv->NAME; + $cvstashname = $gv->STASH->NAME; + } + my $root = $cv->ROOT; + my $cvxsub = $cv->XSUB; + #INIT is removed from the symbol table, so this call must come + # from PL_initav->save. Re-bootstrapping will push INIT back in + # so nullop should be sent. + if ($cvxsub && ($cvname ne "INIT")) { + my $egv = $gv->EGV; + my $stashname = $egv->STASH->NAME; + if ($cvname eq "bootstrap") + { + my $file = $gv->FILE; + $decl->add("/* bootstrap $file */"); + warn "Bootstrap $stashname $file\n"; + $xsub{$stashname}='Dynamic'; + # $xsub{$stashname}='Static' unless $xsub{$stashname}; + return qq/NULL/; + } + warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; + return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; + } + if ($cvxsub && $cvname eq "INIT") { + no strict 'refs'; + return svref_2object(\&Dummy_initxs)->save; + } my $sv_ix = $svsect->index + 1; $svsect->add("svix$sv_ix"); my $xpvcv_ix = $xpvcvsect->index + 1; $xpvcvsect->add("xpvcvix$xpvcv_ix"); # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() $sym = savesym($cv, "&sv_list[$sv_ix]"); - warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv; - my $gv = $cv->GV; - my $cvstashname = $gv->STASH->NAME; - my $cvname = $gv->NAME; - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; + warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; if (!$$root && !$cvxsub) { if (try_autoload($cvstashname, $cvname)) { # Recalculate root and xsub @@ -564,6 +699,10 @@ sub B::CV::save { $ppname .= ($stashname eq "main") ? $gvname : "$stashname\::$gvname"; $ppname =~ s/::/__/g; + if ($gvname eq "INIT"){ + $ppname .= "_$initsub_index"; + $initsub_index++; + } } } if (!$ppname) { @@ -581,28 +720,19 @@ sub B::CV::save { $$padlist, $$cv) if $debug_cv; } } - elsif ($cvxsub) { - $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY); - # Try to find out canonical name of XSUB function from EGV. - # XXX Doesn't work for XSUBs with PREFIX set (or anyone who - # calls newXS() manually with weird arguments). - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - $stashname =~ s/::/__/g; - $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME); - $decl->add("void $xsub _((CV*));"); - } else { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug - } - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x", + } + $pv = '' unless defined $pv; # Avoid use of undef warnings + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); if (${$cv->OUTSIDE} == ${main_cv()}){ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); } if ($$gv) { @@ -611,13 +741,7 @@ sub B::CV::save { warn sprintf("done saving GV 0x%x for CV 0x%x\n", $$gv, $$cv) if $debug_cv; } - my $filegv = $cv->FILEGV; - if ($$filegv) { - $filegv->save; - $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv)); - warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n", - $$filegv, $$cv) if $debug_cv; - } + $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE))); my $stash = $cv->STASH; if ($$stash) { $stash->save; @@ -626,7 +750,7 @@ sub B::CV::save { $$stash, $$cv) if $debug_cv; } $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS)); + $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS)); return $sym; } @@ -641,24 +765,31 @@ sub B::GV::save { $sym = savesym($gv, "gv_list[$ix]"); #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug } + my $is_empty = $gv->is_empty; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); #warn "GV name is $name\n"; # debug - my $egv = $gv->EGV; my $egvsym; - if ($$gv != $$egv) { - #warn(sprintf("EGV name is %s, saving it now\n", - # $egv->STASH->NAME . "::" . $egv->NAME)); # debug - $egvsym = $egv->save; + unless ($is_empty) { + my $egv = $gv->EGV; + if ($$gv != $$egv) { + #warn(sprintf("EGV name is %s, saving it now\n", + # $egv->STASH->NAME . "::" . $egv->NAME)); # debug + $egvsym = $egv->save; + } } $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS), - sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS), - sprintf("GvLINE($sym) = %u;", $gv->LINE)); + sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS)); + $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty; + # Shouldn't need to do save_magic since gv_fetchpv handles that #$gv->save_magic; my $refcnt = $gv->REFCNT + 1; $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1; + + return $sym if $is_empty; + my $gvrefcnt = $gv->GvREFCNT; if ($gvrefcnt > 1) { $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); @@ -672,45 +803,51 @@ sub B::GV::save { # warn "GV::save saving subfields\n"; # debug my $gvsv = $gv->SV; if ($$gvsv) { + $gvsv->save; $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); # warn "GV::save \$$name\n"; # debug - $gvsv->save; } my $gvav = $gv->AV; if ($$gvav) { + $gvav->save; $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); # warn "GV::save \@$name\n"; # debug - $gvav->save; } my $gvhv = $gv->HV; if ($$gvhv) { + $gvhv->save; $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); # warn "GV::save \%$name\n"; # debug - $gvhv->save; } my $gvcv = $gv->CV; - if ($$gvcv) { - $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); -# warn "GV::save &$name\n"; # debug - $gvcv->save; - } - my $gvfilegv = $gv->FILEGV; - if ($$gvfilegv) { - $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); -# warn "GV::save GvFILEGV(*$name)\n"; # debug - $gvfilegv->save; - } + if ($$gvcv) { + my $origname=cstring($gvcv->GV->EGV->STASH->NAME . + "::" . $gvcv->GV->EGV->NAME); + if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias + # must save as a 'stub' so newXS() has a CV to populate + $init->add("{ CV *cv;"); + $init->add("\tcv=perl_get_cv($origname,TRUE);"); + $init->add("\tGvCV($sym)=cv;"); + $init->add("\tSvREFCNT_inc((SV *)cv);"); + $init->add("}"); + } else { + $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); +# warn "GV::save &$name\n"; # debug + } + } + $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE))); +# warn "GV::save GvFILE(*$name)\n"; # debug my $gvform = $gv->FORM; if ($$gvform) { + $gvform->save; $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); # warn "GV::save GvFORM(*$name)\n"; # debug - $gvform->save; } my $gvio = $gv->IO; if ($$gvio) { + $gvio->save; $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); # warn "GV::save GvIO(*$name)\n"; # debug - $gvio->save; } } return $sym; @@ -723,7 +860,7 @@ sub B::AV::save { $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags)); $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); + $xpvavsect->index, $av->REFCNT , $av->FLAGS)); my $sv_list_index = $svsect->index; my $fill = $av->FILL; $av->save_magic; @@ -789,7 +926,7 @@ sub B::HV::save { $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", $hv->MAX, $hv->RITER)); $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS)); + $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); my $sv_list_index = $svsect->index; my @contents = $hv->ARRAY; if (@contents) { @@ -802,9 +939,12 @@ sub B::HV::save { my ($key, $value) = splice(@contents, 0, 2); $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", cstring($key),length($key),$value, hash($key))); +# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", +# cstring($key),length($key),$value, 0)); } $init->add("}"); } + $hv->save_magic(); return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); } @@ -813,6 +953,7 @@ sub B::IO::save { my $sym = objsym($io); return $sym if defined $sym; my $pv = $io->PV; + $pv = '' unless defined $pv; my $len = length($pv); $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", $len, $len+1, $io->IVX, $io->NVX, $io->LINES, @@ -821,7 +962,7 @@ sub B::IO::save { cstring($io->BOTTOM_NAME), $io->SUBPROCESS, cchar($io->IoTYPE), $io->IoFLAGS)); $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT + 1, $io->FLAGS)); + $xpviosect->index, $io->REFCNT , $io->FLAGS)); $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); my ($field, $fsym); foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { @@ -848,11 +989,10 @@ sub output_all { my $init_name = shift; my $section; my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, - $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect, - $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, + $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, + $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); - $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); $symsect->output(\*STDOUT, "#define %s\n"); print "\n"; output_declarations(); @@ -881,6 +1021,8 @@ sub output_all { static int $init_name() { dTHR; + dTARG; + djSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -915,18 +1057,18 @@ typedef struct { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) _((CV*)); + void (*xcv_xsub) (CV*); void * xcv_xsubany; GV * xcv_gv; - GV * xcv_filegv; - long xcv_depth; /* >= 2 indicates recursive call */ + char * xcv_file; + long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; #ifdef USE_THREADS perl_mutex *xcv_mutexp; struct perl_thread *xcv_owner; /* current owner thread */ #endif /* USE_THREADS */ - U8 xcv_flags; + cv_flags_t xcv_flags; } XPVCV_or_similar; #define ANYINIT(i) i #else @@ -948,15 +1090,16 @@ sub output_boilerplate { print <<'EOT'; #include "EXTERN.h" #include "perl.h" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif +#include "XSUB.h" /* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef pp_mapstart -#define pp_mapstart pp_grepstart +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); -static void xs_init _((void)); +static void xs_init (pTHX); +static void dl_init (pTHX); static PerlInterpreter *my_perl; EOT } @@ -964,28 +1107,20 @@ EOT sub output_main { print <<'EOT'; int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ { int exitstatus; int i; char **fakeargv; - PERL_SYS_INIT(&argc,&argv); + PERL_SYS_INIT3(&argc,&argv,&env); - perl_init_i18nl10n(1); - if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) exit(1); perl_construct( my_perl ); + PL_perl_destruct_level = 0; } #ifdef CSH @@ -1021,22 +1156,84 @@ main(int argc, char **argv, char **env) exitstatus = perl_init(); if (exitstatus) exit( exitstatus ); + dl_init(aTHX); exitstatus = perl_run( my_perl ); perl_destruct( my_perl ); perl_free( my_perl ); + PERL_SYS_TERM(); + exit( exitstatus ); } +/* yanked from perl.c */ static void -xs_init() +xs_init(pTHX) { -} + char *file = __FILE__; + dTARG; + djSP; +EOT + print "\n#ifdef USE_DYNAMIC_LOADING"; + print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; + print "\n#endif\n" ; + # delete $xsub{'DynaLoader'}; + delete $xsub{'UNIVERSAL'}; + print("/* bootstrapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_DynaLoader(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + print "#endif\n"; + foreach my $stashname (keys %xsub){ + if ($xsub{$stashname} ne 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end bootstrapping code */\n"); + print "}\n"; + +print <<'EOT'; +static void +dl_init(pTHX) +{ + char *file = __FILE__; + dTARG; + djSP; EOT + print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + foreach my $stashname (@DynaLoader::dl_modules) { + warn "Loaded $stashname\n"; + if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; + print qq/\tPUTBACK;\n/; + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + warn "bootstrapping $stashname added to xs_init\n"; + print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; + print "\n#else\n"; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print "#endif\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); + print "}\n"; } - sub dump_symtable { # For debugging my ($sym, $val); @@ -1056,107 +1253,174 @@ sub save_object { sub Dummy_BootStrap { } -sub B::GV::savecv { - my $gv = shift; - my $cv = $gv->CV; - my $name = $gv->NAME; - if ($$cv) { - if ($name eq "bootstrap" && $cv->XSUB) { - my $file = $cv->FILEGV->SV->PV; - $bootstrap->add($file); - my $name = $gv->STASH->NAME.'::'.$name; - no strict 'refs'; - *{$name} = \&Dummy_BootStrap; - $cv = $gv->CV; - } - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $name, $$cv, $$gv); - } - my $package=$gv->STASH->NAME; - # This seems to undo all the ->isa and prefix stuff we do below - # so disable again for now - if (0 && ! grep(/^$package$/,@unused_sub_packages)){ - warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) - if $debug_cv; - return ; +sub B::GV::savecv +{ + my $gv = shift; + my $package=$gv->STASH->NAME; + my $name = $gv->NAME; + my $cv = $gv->CV; + my $sv = $gv->SV; + my $av = $gv->AV; + my $hv = $gv->HV; + + # We may be looking at this package just because it is a branch in the + # symbol table which is on the path to a package which we need to save + # e.g. this is 'Getopt' and we need to save 'Getopt::Long' + # + return unless ($unused_sub_packages{$package}); + return unless ($$cv || $$av || $$sv || $$hv); + $gv->save; +} + +sub mark_package +{ + my $package = shift; + unless ($unused_sub_packages{$package}) + { + no strict 'refs'; + $unused_sub_packages{$package} = 1; + if (defined @{$package.'::ISA'}) + { + foreach my $isa (@{$package.'::ISA'}) + { + if ($isa eq 'DynaLoader') + { + unless (defined(&{$package.'::bootstrap'})) + { + warn "Forcing bootstrap of $package\n"; + eval { $package->bootstrap }; + } + } +# else + { + unless ($unused_sub_packages{$isa}) + { + warn "$isa saved (it is in $package\'s \@ISA)\n"; + mark_package($isa); + } + } } - $gv->save; } - elsif ($name eq 'ISA') - { - $gv->save; - } - + } + return 1; +} + +sub should_save +{ + no strict qw(vars refs); + my $package = shift; + $package =~ s/::$//; + return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. + # warn "Considering $package\n";#debug + foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) + { + # If this package is a prefix to something we are saving, traverse it + # but do not mark it for saving if it is not already + # e.g. to get to Getopt::Long we need to traverse Getopt but need + # not save Getopt + return 1 if ($u =~ /^$package\:\:/); + } + if (exists $unused_sub_packages{$package}) + { + # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; + delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; + return $unused_sub_packages{$package}; + } + # Omit the packages which we use (and which cause grief + # because of fancy "goto &$AUTOLOAD" stuff). + # XXX Surely there must be a nicer way to do this. + if ($package eq "FileHandle" || $package eq "Config" || + $package eq "SelectSaver" || $package =~/^(B|IO)::/) + { + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; + } + # Now see if current package looks like an OO class this is probably too strong. + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) + { + if ($package->can($m)) + { + warn "$package has method $m: saving package\n";#debug + return mark_package($package); + } + } + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; +} +sub delete_unsaved_hashINC{ + my $packname=shift; + $packname =~ s/\:\:/\//g; + $packname .= '.pm'; +# warn "deleting $packname" if $INC{$packname} ;# debug + delete $INC{$packname}; +} +sub walkpackages +{ + my ($symref, $recurse, $prefix) = @_; + my $sym; + my $ref; + no strict 'vars'; + local(*glob); + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) + { + *glob = $ref; + if ($sym =~ /::$/) + { + $sym = $prefix . $sym; + if ($sym ne "main::" && &$recurse($sym)) + { + walkpackages(\%glob, $recurse, $sym); + } + } + } } +sub save_unused_subs +{ + no strict qw(refs); + &descend_marked_unused; + warn "Prescan\n"; + walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); + warn "Saving methods\n"; + walksymtable(\%{"main::"}, "savecv", \&should_save); +} -sub save_unused_subs { - my %search_pack; - map { $search_pack{$_} = 1 } @_; - @unused_sub_packages=@_; - no strict qw(vars refs); - walksymtable(\%{"main::"}, "savecv", sub { - my $package = shift; - $package =~ s/::$//; - return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. - #warn "Considering $package\n";#debug - return 1 if exists $search_pack{$package}; - #sub try for a partial match - if (grep(/^$package\:\:/,@unused_sub_packages)){ - return 1; - } - #warn " (nothing explicit)\n";#debug - # Omit the packages which we use (and which cause grief - # because of fancy "goto &$AUTOLOAD" stuff). - # XXX Surely there must be a nicer way to do this. - if ($package eq "FileHandle" - || $package eq "Config" - || $package eq "SelectSaver") { - return 0; - } - foreach my $u (keys %search_pack) { - if ($package =~ /^${u}::/) { - warn "$package starts with $u\n"; - return 1 - } - if ($package->isa($u)) { - warn "$package isa $u\n"; - return 1 - } - return 1 if $package->isa($u); - } - foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { - if (defined(&{$package."::$m"})) { - warn "$package has method $m: -u$package assumed\n";#debug - push @unused_sub_package, $package; - return 1; - } - } - return 0; - }); +sub save_context +{ + my $curpad_nam = (comppadlist->ARRAY)[0]->save; + my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; + $init->add( "PL_curpad = AvARRAY($curpad_sym);", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;" ); } +sub descend_marked_unused { + foreach my $pack (keys %unused_sub_packages) + { + mark_package($pack); + } +} + sub save_main { + warn "Starting compile\n"; warn "Walking tree\n"; - my $curpad_nam = (comppadlist->ARRAY)[0]->save; - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - my $init_av = init_av->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; + seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(@unused_sub_packages); - + save_unused_subs(); + my $init_av = init_av->save; $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "PL_initav = (AV *) $init_av;"); + save_context(); warn "Writing output\n"; output_boilerplate(); print "\n"; @@ -1168,7 +1432,7 @@ sub save_main { sub init_sections { my @sections = (init => \$init, decl => \$decl, sym => \$symsect, binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect, + cop => \$copsect, padop => \$padopsect, listop => \$listopsect, logop => \$logopsect, loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, @@ -1177,11 +1441,17 @@ sub init_sections { xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect, bootstrap => \$bootstrap); + xpvio => \$xpviosect); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { - $$sectref = new B::Section $name, \%symtable, 0; + $$sectref = new B::C::Section $name, \%symtable, 0; } +} + +sub mark_unused +{ + my ($arg,$val) = @_; + $unused_sub_packages{$arg} = $val; } sub compile { @@ -1226,7 +1496,7 @@ sub compile { $verbose = 1; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; if ($arg eq "cog") { @@ -1241,6 +1511,8 @@ sub compile { # Optimisations for -O1 $pv_copy_on_grow = 1; } + } elsif ($opt eq "l") { + $max_string_len = $arg; } } init_sections(); @@ -1356,6 +1628,15 @@ No copy-on-grow. Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently, B<-O1> and higher set B<-fcog>. +=item B<-llimit> + +Some C compilers impose an arbitrary limit on the length of string +constants (e.g. 2048 characters for Microsoft Visual C++). The +B<-llimit> options tells the C backend not to generate string literals +exceeding that limit. + +=back + =head1 EXAMPLES perl -MO=C,-ofoo.c foo.pl @@ -1365,7 +1646,7 @@ Note that C<cc_harness> lives in the C<B> subdirectory of your perl library directory. The utility called C<perlcc> may also be used to help make use of this compiler. - perl -MO=C,-v,-DcA bar.pl > /dev/null + perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null =head1 BUGS diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index d200d70..c5ca2a3 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -6,36 +6,22 @@ # License or the Artistic License, as specified in the README file. # package B::CC; +use Config; use strict; use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info); -use B::C qw(save_unused_subs objsym init_sections + timing_info init_av sv_undef amagic_generation + OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL + OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV + OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR + CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK + ); +use B::C qw(save_unused_subs objsym init_sections mark_unused output_all output_boilerplate output_main); use B::Bblock qw(find_leaders); use B::Stackobj qw(:types :flags); # These should probably be elsewhere # Flags for $op->flags -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_MOD () { 32 } -sub OPf_STACKED () { 64 } -sub OPf_SPECIAL () { 128 } -# op-specific flags for $op->private -sub OPpASSIGN_BACKWARDS () { 64 } -sub OPpLVAL_INTRO () { 128 } -sub OPpDEREF_AV () { 32 } -sub OPpDEREF_HV () { 64 } -sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV } -sub OPpFLIP_LINENUM () { 64 } -sub G_ARRAY () { 1 } -# cop.h -sub CXt_NULL () { 0 } -sub CXt_SUB () { 1 } -sub CXt_EVAL () { 2 } -sub CXt_LOOP () { 3 } -sub CXt_SUBST () { 4 } -sub CXt_BLOCK () { 5 } my $module; # module name (when compiled with -m) my %done; # hash keyed by $$op of leaders of basic blocks @@ -66,6 +52,9 @@ my %skip_stack; # Hash of PP names which don't need write_back_stack my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals my %ignore_op; # Hash of ops which do nothing except returning op_next +my %need_curcop; # Hash of ops which need PL_curcop + +my %lexstate; #state of padsvs at the start of a bblock BEGIN { foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { @@ -73,11 +62,6 @@ BEGIN { } } -my @unused_sub_packages; # list of packages (given by -u options) to search - # explicitly and save every sub we find there, even - # if apparently unused (could be only referenced from - # an eval "" or from a $SIG{FOO} = "bar"). - my ($module_name); my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); @@ -111,12 +95,17 @@ sub init_hash { map { $_ => 1 } @_ } # %skip_lexicals = init_hash qw(pp_enter pp_enterloop); %skip_invalidate = init_hash qw(pp_enter pp_enterloop); +%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller + pp_reset pp_rv2cv pp_entereval pp_require pp_dofile + pp_entertry pp_enterloop pp_enteriter pp_entersub + pp_enter pp_method); sub debug { if ($debug_runtime) { warn(@_); } else { - runtime(map { chomp; "/* $_ */"} @_); + my @tmp=@_; + runtime(map { chomp; "/* $_ */"} @tmp); } } @@ -139,7 +128,7 @@ sub output_runtime { print qq(#include "cc_runtime.h"\n); foreach $ppdata (@pp_list) { my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nPP($name)\n{\n"; + print "\nstatic\nCCPP($name)\n{\n"; my ($type, $varlist, $line); while (($type, $varlist) = each %$declare) { print "\t$type ", join(", ", @$varlist), ";\n"; @@ -167,7 +156,7 @@ sub init_pp { declare("SV", "**svp"); map { declare("SV", "*$_") } qw(sv src dst left right); declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname _((ARGSproto));"); + $decl->add("static OP * $ppname (pTHX);"); debug "init_pp: $ppname\n" if $debug_queue; } @@ -200,7 +189,7 @@ sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" } +sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } @@ -208,7 +197,7 @@ sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } sub pop_bool { if (@stack) { - return ((pop @stack)->as_numeric); + return ((pop @stack)->as_bool); } else { # Careful: POPs has an auto-decrement and SvTRUE evaluates # its argument more than once. @@ -228,6 +217,32 @@ sub write_back_lexicals { } } +sub save_or_restore_lexical_state { + my $bblock=shift; + unless( exists $lexstate{$bblock}){ + foreach my $lex (@pad) { + next unless ref($lex); + ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; + } + } + else { + foreach my $lex (@pad) { + next unless ref($lex); + my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; + next if ( $old_flags eq $lex->{flags}); + if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ + $lex->write_back; + } + if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ + $lex->load_double; + } + if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ + $lex->load_int; + } + } + } +} + sub write_back_stack { my $obj; return unless @stack; @@ -350,8 +365,9 @@ sub dopoptoloop { sub dopoptolabel { my $label = shift; my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP - && $cxstack[$cxix]->{label} ne $label) { + while ($cxix >= 0 && + ($cxstack[$cxix]->{type} != CXt_LOOP || + $cxstack[$cxix]->{label} ne $label)) { $cxix--; } debug "dopoptolabel: returning $cxix" if $debug_cxstack; @@ -360,7 +376,7 @@ sub dopoptolabel { sub error { my $format = shift; - my $file = $curcop->[0]->filegv->SV->PV; + my $file = $curcop->[0]->file; my $line = $curcop->[0]->line; $errors++; if (@_) { @@ -416,12 +432,22 @@ sub load_pad { } $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, "i_$name", "d_$name"); - declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name"); - declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name"); + debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; } } +sub declare_pad { + my $ix; + for ($ix = 1; $ix <= $#pad; $ix++) { + my $type = $pad[$ix]->{type}; + declare("IV", $type == T_INT ? + sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; + declare("double", $type == T_DOUBLE ? + sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; + + } +} # # Debugging stuff # @@ -461,7 +487,7 @@ sub doop { sub gimme { my $op = shift; my $flags = $op->flags; - return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()"); + return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); } # @@ -476,10 +502,12 @@ sub pp_null { sub pp_stub { my $op = shift; my $gimme = gimme($op); - if ($gimme != 1) { + if ($gimme != G_ARRAY) { + my $obj= new B::Stackobj::Const(sv_undef); + push(@stack, $obj); # XXX Change to push a constant sv_undef Stackobj onto @stack - write_back_stack(); - runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); + #write_back_stack(); + #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); } return $op->next; } @@ -499,8 +527,10 @@ sub pp_and { if (@stack >= 1) { my $bool = pop_bool(); write_back_stack(); - runtime(sprintf("if (!$bool) goto %s;", label($next))); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); } else { + save_or_restore_lexical_state($$next); runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), "*sp--;"); } @@ -513,11 +543,13 @@ sub pp_or { reload_lexicals(); unshift(@bblock_todo, $next); if (@stack >= 1) { - my $obj = pop @stack; + my $bool = pop_bool @stack; write_back_stack(); - runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }", - $obj->as_numeric, $obj->as_sv, label($next))); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", + $bool, label($next))); } else { + save_or_restore_lexical_state($$next); runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), "*sp--;"); } @@ -526,13 +558,14 @@ sub pp_or { sub pp_cond_expr { my $op = shift; - my $false = $op->false; + my $false = $op->next; unshift(@bblock_todo, $false); reload_lexicals(); my $bool = pop_bool(); write_back_stack(); + save_or_restore_lexical_state($$false); runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->true; + return $op->other; } sub pp_padsv { @@ -555,9 +588,16 @@ sub pp_padsv { sub pp_const { my $op = shift; my $sv = $op->sv; - my $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + my $obj; + # constant could be in the pad (under useithreads) + if ($$sv) { + $obj = $constobj{$$sv}; + if (!defined($obj)) { + $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + } + } + else { + $obj = $pad[$op->targ]; } push(@stack, $obj); return $op->next; @@ -567,7 +607,7 @@ sub pp_nextstate { my $op = shift; $curcop->load($op); @stack = (); - debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno; + debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; runtime("TAINT_NOT;") unless $omit_taint; runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); if ($freetmps_each_bblock || $freetmps_each_loop) { @@ -584,18 +624,58 @@ sub pp_dbstate { return default_pp($op); } -sub pp_rv2gv { $curcop->write_back; default_pp(@_) } -sub pp_bless { $curcop->write_back; default_pp(@_) } -sub pp_repeat { $curcop->write_back; default_pp(@_) } +#default_pp will handle this: +#sub pp_bless { $curcop->write_back; default_pp(@_) } +#sub pp_repeat { $curcop->write_back; default_pp(@_) } # The following subs need $curcop->write_back if we decide to support arybase: # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -sub pp_sort { $curcop->write_back; default_pp(@_) } -sub pp_caller { $curcop->write_back; default_pp(@_) } -sub pp_reset { $curcop->write_back; default_pp(@_) } +#sub pp_caller { $curcop->write_back; default_pp(@_) } +#sub pp_reset { $curcop->write_back; default_pp(@_) } + +sub pp_rv2gv{ + my $op =shift; + $curcop->write_back; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + if ($op->private & OPpDEREF) { + $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); + $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", + $op->first->type)); + } + return $op->next; +} +sub pp_sort { + my $op = shift; + my $ppname = $op->ppaddr; + if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ + #this indicates the sort BLOCK Array case + #ugly surgery required. + my $root=$op->first->sibling->first; + my $start=$root->first; + $op->first->save; + $op->first->sibling->save; + $root->save; + my $sym=$start->save; + my $fakeop=cc_queue("pp_sort".$$op,$root,$start); + $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); + } + $curcop->write_back; + write_back_lexicals(); + write_back_stack(); + doop($op); + return $op->next; +} sub pp_gv { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } write_back_stack(); runtime("XPUSHs((SV*)$gvsym);"); return $op->next; @@ -603,7 +683,13 @@ sub pp_gv { sub pp_gvsv { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } write_back_stack(); if ($op->private & OPpLVAL_INTRO) { runtime("XPUSHs(save_scalar($gvsym));"); @@ -615,7 +701,13 @@ sub pp_gvsv { sub pp_aelemfast { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } my $ix = $op->private; my $flag = $op->flags & OPf_MOD; write_back_stack(); @@ -666,11 +758,15 @@ sub numeric_binop { } } else { if ($force_int) { + my $rightruntime = new B::Pseudoreg ("IV", "riv"); + runtime(sprintf("$$rightruntime = %s;",$right)); runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $right))); + &$operator("TOPi", $$rightruntime))); } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn", $right))); + &$operator("TOPn",$$rightruntime))); } } } else { @@ -694,6 +790,60 @@ sub numeric_binop { return $op->next; } +sub pp_ncmp { + my ($op) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_numeric(); + if (@stack >= 1) { + my $left = top_numeric(); + runtime sprintf("if (%s > %s){",$left,$right); + $stack[-1]->set_int(1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s < %s ) {",$left,$right); + $stack[-1]->set_int(-1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s == %s) {",$left,$right); + $stack[-1]->set_int(0); + $stack[-1]->write_back(); + runtime sprintf("}else {"); + $stack[-1]->set_sv("&PL_sv_undef"); + runtime "}"; + } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); + runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); + runtime sprintf("sv_setiv(TOPs,1);"); + runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,-1);"); + runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,0);"); + runtime sprintf(qq/}else {/); + runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); + runtime "}"; + } + } else { + my $targ = $pad[$op->targ]; + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + runtime sprintf("if (%s > %s){",$$left,$$right); + $targ->set_int(1); + $targ->write_back(); + runtime sprintf("}else if (%s < %s ) {",$$left,$$right); + $targ->set_int(-1); + $targ->write_back(); + runtime sprintf("}else if (%s == %s) {",$$left,$$right); + $targ->set_int(0); + $targ->write_back(); + runtime sprintf("}else {"); + $targ->set_sv("&PL_sv_undef"); + runtime "}"; + push(@stack, $targ); + } + return $op->next; +} + sub sv_binop { my ($op, $operator, $flags) = @_; if ($op->flags & OPf_STACKED) { @@ -789,7 +939,6 @@ BEGIN { my $modulo_op = infix_op("%"); my $lshift_op = infix_op("<<"); my $rshift_op = infix_op(">>"); - my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" }; my $scmp_op = prefix_op("sv_cmp"); my $seq_op = prefix_op("sv_eq"); my $sne_op = prefix_op("!sv_eq"); @@ -808,12 +957,11 @@ BEGIN { # XXX The standard perl PP code has extra handling for # some special case arguments of these operators. # - sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) } - sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) } - sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) } + sub pp_add { numeric_binop($_[0], $plus_op) } + sub pp_subtract { numeric_binop($_[0], $minus_op) } + sub pp_multiply { numeric_binop($_[0], $multiply_op) } sub pp_divide { numeric_binop($_[0], $divide_op) } sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) } sub pp_left_shift { int_binop($_[0], $lshift_op) } sub pp_right_shift { int_binop($_[0], $rshift_op) } @@ -857,7 +1005,7 @@ sub pp_sassign { ($src, $dst) = ($dst, $src) if $backwards; my $type = $src->{type}; if ($type == T_INT) { - $dst->set_int($src->as_int); + $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); } elsif ($type == T_DOUBLE) { $dst->set_numeric($src->as_numeric); } else { @@ -870,7 +1018,11 @@ sub pp_sassign { my $type = $src->{type}; runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); if ($type == T_INT) { - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + if ($src->{flags} & VALID_UNSIGNED){ + runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); + }else{ + runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + } } elsif ($type == T_DOUBLE) { runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); } else { @@ -887,7 +1039,7 @@ sub pp_sassign { } elsif ($type == T_DOUBLE) { $dst->set_double("SvNV(sv)"); } else { - runtime("SvSetSV($dst->{sv}, sv);"); + runtime("SvSetMagicSV($dst->{sv}, sv);"); $dst->invalidate; } } @@ -922,6 +1074,7 @@ sub pp_preinc { return $op->next; } + sub pp_pushmark { my $op = shift; write_back_stack(); @@ -933,7 +1086,7 @@ sub pp_list { my $op = shift; write_back_stack(); my $gimme = gimme($op); - if ($gimme == 1) { # sic + if ($gimme == G_ARRAY) { # sic runtime("POPMARK;"); # need this even though not a "full" pp_list } else { runtime("PP_LIST($gimme);"); @@ -943,16 +1096,31 @@ sub pp_list { sub pp_entersub { my $op = shift; + $curcop->write_back; write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); my $sym = doop($op); runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); runtime("SPAGAIN;}"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_formline { + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + # See comment in pp_grepwhile to see why! + $init->add("((LISTOP*)$sym)->op_first = $sym;"); + runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); + save_or_restore_lexical_state(${$op->first}); + runtime( sprintf("goto %s;",label($op->first))); + runtime("}"); + return $op->next; +} sub pp_goto{ @@ -969,7 +1137,16 @@ sub pp_enterwrite { my $op = shift; pp_entersub($op); } - +sub pp_leavesub{ + my $op = shift; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); + runtime("\tPUTBACK;return 0;"); + runtime("}"); + doop($op); + return $op->next; +} sub pp_leavewrite { my $op = shift; write_back_lexicals(REGISTER|TEMPORARY); @@ -977,7 +1154,7 @@ sub pp_leavewrite { my $sym = doop($op); # XXX Is this the right way to distinguish between it returning # CvSTART(cv) (via doform) and pop_return()? - runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);"); + #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); runtime("SPAGAIN;"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); @@ -991,6 +1168,7 @@ sub doeval { write_back_stack(); my $sym = loadop($op); my $ppaddr = $op->ppaddr; + #runtime(qq/printf("$ppaddr type eval\n");/); runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); $know_op = 1; invalidate_lexicals(REGISTER|TEMPORARY); @@ -998,9 +1176,24 @@ sub doeval { } sub pp_entereval { doeval(@_) } -sub pp_require { doeval(@_) } sub pp_dofile { doeval(@_) } +#pp_require is protected by pp_entertry, so no protection for it. +sub pp_require { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;}"); + $know_op = 1; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + + sub pp_entertry { my $op = shift; $curcop->write_back; @@ -1008,12 +1201,19 @@ sub pp_entertry { write_back_stack(); my $sym = doop($op); my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("Sigjmp_buf", $jmpbuf); + declare("JMPENV", $jmpbuf); runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_leavetry{ + my $op=shift; + default_pp($op); + runtime("PP_LEAVETRY;"); + return $op->next; +} + sub pp_grepstart { my $op = shift; if ($need_freetmps && $freetmps_each_loop) { @@ -1021,7 +1221,14 @@ sub pp_grepstart { $need_freetmps = 0; } write_back_stack(); - doop($op); + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); return $op->next->other; } @@ -1032,7 +1239,16 @@ sub pp_mapstart { $need_freetmps = 0; } write_back_stack(); - doop($op); + # pp_mapstart can return either op_next->op_next or op_next->op_other and + # we need to be able to distinguish the two at runtime. + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); return $op->next->other; } @@ -1049,6 +1265,7 @@ sub pp_grepwhile { # around that, we hack op_next to be our own op (purely because we # know it's a non-NULL pointer and can't be the same as op_other). $init->add("((LOGOP*)$sym)->op_next = $sym;"); + save_or_restore_lexical_state($$next); runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); $know_op = 0; return $op->other; @@ -1063,7 +1280,7 @@ sub pp_return { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); doop($op); - runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;"); + runtime("PUTBACK;", "return PL_op;"); $know_op = 0; return $op->next; } @@ -1077,30 +1294,31 @@ sub nyi { sub pp_range { my $op = shift; my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { + if (!($flags & OPf_WANT)) { error("context of range unknown at compile-time"); } write_back_lexicals(); write_back_stack(); - if (!($flags & OPf_LIST)) { + unless (($flags & OPf_WANT)== OPf_WANT_LIST) { # We need to save our UNOP structure since pp_flop uses # it to find and adjust out targ. We don't need it ourselves. $op->save; + save_or_restore_lexical_state(${$op->other}); runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", - $op->targ, label($op->false)); - unshift(@bblock_todo, $op->false); + $op->targ, label($op->other)); + unshift(@bblock_todo, $op->other); } - return $op->true; + return $op->next; } sub pp_flip { my $op = shift; my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { + if (!($flags & OPf_WANT)) { error("context of flip unknown at compile-time"); } - if ($flags & OPf_LIST) { - return $op->first->false; + if (($flags & OPf_WANT)==OPf_WANT_LIST) { + return $op->first->other; } write_back_lexicals(); write_back_stack(); @@ -1116,9 +1334,10 @@ sub pp_flip { if ($op->flags & OPf_SPECIAL) { runtime("sv_setiv(PL_curpad[$ix], 1);"); } else { + save_or_restore_lexical_state(${$op->first->other}); runtime("\tsv_setiv(PL_curpad[$ix], 0);", "\tsp--;", - sprintf("\tgoto %s;", label($op->first->false))); + sprintf("\tgoto %s;", label($op->first->other))); } runtime("}", qq{sv_setpv(PL_curpad[$ix], "");}, @@ -1187,6 +1406,7 @@ sub pp_next { default_pp($op); my $nextop = $cxstack[$cxix]->{nextop}; push(@bblock_todo, $nextop); + save_or_restore_lexical_state($$nextop); runtime(sprintf("goto %s;", label($nextop))); return $op->next; } @@ -1210,6 +1430,7 @@ sub pp_redo { default_pp($op); my $redoop = $cxstack[$cxix]->{redoop}; push(@bblock_todo, $redoop); + save_or_restore_lexical_state($$redoop); runtime(sprintf("goto %s;", label($redoop))); return $op->next; } @@ -1238,6 +1459,7 @@ sub pp_last { default_pp($op); my $lastop = $cxstack[$cxix]->{lastop}->next; push(@bblock_todo, $lastop); + save_or_restore_lexical_state($$lastop); runtime(sprintf("goto %s;", label($lastop))); return $op->next; } @@ -1249,6 +1471,7 @@ sub pp_subst { my $sym = doop($op); my $replroot = $op->pmreplroot; if ($$replroot) { + save_or_restore_lexical_state($$replroot); runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", $sym, label($replroot)); $op->pmreplstart->save; @@ -1264,11 +1487,12 @@ sub pp_substcont { write_back_stack(); doop($op); my $pmop = $op->other; - warn sprintf("substcont: op = %s, pmop = %s\n", - peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); + # warn sprintf("substcont: op = %s, pmop = %s\n", + # peekop($op), peekop($pmop));#debug +# my $pmopsym = objsym($pmop); my $pmopsym = $pmop->save; # XXX can this recurse? - warn "pmopsym = $pmopsym\n";#debug +# warn "pmopsym = $pmopsym\n";#debug + save_or_restore_lexical_state(${$pmop->pmreplstart}); runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", $pmopsym, label($pmop->pmreplstart)); invalidate_lexicals(); @@ -1277,7 +1501,10 @@ sub pp_substcont { sub default_pp { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; + if ($curcop and $need_curcop{$ppname}){ + $curcop->write_back; + } write_back_lexicals() unless $skip_lexicals{$ppname}; write_back_stack() unless $skip_stack{$ppname}; doop($op); @@ -1291,7 +1518,7 @@ sub default_pp { sub compile_op { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; if (exists $ignore_op{$ppname}) { return $op->next; } @@ -1313,6 +1540,7 @@ sub compile_op { sub compile_bblock { my $op = shift; #warn "compile_bblock: ", peekop($op), "\n"; # debug + save_or_restore_lexical_state($$op); write_label($op); $know_op = 0; do { @@ -1326,15 +1554,26 @@ sub compile_bblock { sub cc { my ($name, $root, $start, @padlist) = @_; my $op; + if($done{$$start}){ + #warn "repeat=>".ref($start)."$name,\n";#debug + $decl->add(sprintf("#define $name %s",$done{$$start})); + return; + } init_pp($name); load_pad(@padlist); + %lexstate=(); B::Pseudoreg->new_scope; @cxstack = (); if ($debug_timings) { warn sprintf("Basic block analysis at %s\n", timing_info); } $leaders = find_leaders($root, $start); - @bblock_todo = ($start, values %$leaders); + my @leaders= keys %$leaders; + if ($#leaders > -1) { + @bblock_todo = ($start, values %$leaders) ; + } else{ + runtime("return PL_op?PL_op->op_next:0;"); + } if ($debug_timings) { warn sprintf("Compilation at %s\n", timing_info); } @@ -1344,7 +1583,7 @@ sub cc { next if !defined($op) || !$$op || $done{$$op}; #warn "...compiling it\n"; # debug do { - $done{$$op} = 1; + $done{$$op} = $name; $op = compile_bblock($op); if ($need_freetmps && $freetmps_each_bblock) { runtime("FREETMPS;"); @@ -1356,14 +1595,16 @@ sub cc { $need_freetmps = 0; } if (!$$op) { - runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;"); + runtime("PUTBACK;","return PL_op;"); } elsif ($done{$$op}) { + save_or_restore_lexical_state($$op); runtime(sprintf("goto %s;", label($op))); } } if ($debug_timings) { warn sprintf("Saving runtime at %s\n", timing_info); } + declare_pad(@padlist) ; save_runtime(); } @@ -1387,20 +1628,32 @@ sub cc_obj { sub cc_main { my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; + my $curpad_nam = $comppadlist[0]->save; + my $curpad_sym = $comppadlist[1]->save; + my $init_av = init_av->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - save_unused_subs(@unused_sub_packages); + # Do save_unused_subs before saving inc_hv + save_unused_subs(); cc_recurse(); + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; return if $errors; if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = (AV *) $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;", + ); + } + seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output output_boilerplate(); print "\n"; output_all("perl_init"); @@ -1419,11 +1672,11 @@ XS(boot_$cmodule) perl_init(); ENTER; SAVETMPS; - SAVESPTR(PL_curpad); - SAVESPTR(PL_op); + SAVEVPTR(PL_curpad); + SAVEVPTR(PL_op); PL_curpad = AvARRAY($curpad_sym); PL_op = $start; - pp_main(ARGS); + pp_main(aTHX); FREETMPS; LEAVE; ST(0) = &PL_sv_yes; @@ -1459,7 +1712,7 @@ sub compile { $module_name = $arg; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; my $value = $arg !~ s/^no-//; @@ -1485,7 +1738,7 @@ sub compile { } elsif ($opt eq "m") { $arg ||= shift @options; $module = $arg; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "p") { $arg ||= shift @options; $patchlevel = $arg; diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm index 7754a5a..ae7a973 100644 --- a/contrib/perl5/ext/B/B/Debug.pm +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -39,13 +39,6 @@ sub B::LOGOP::debug { printf "\top_other\t0x%x\n", ${$op->other}; } -sub B::CONDOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_true\t0x%x\n", ${$op->true}; - printf "\top_false\t0x%x\n", ${$op->false}; -} - sub B::LISTOP::debug { my ($op) = @_; $op->B::BINOP::debug(); @@ -67,16 +60,15 @@ sub B::PMOP::debug { sub B::COP::debug { my ($op) = @_; $op->B::OP::debug(); - my ($filegv) = $op->filegv; - printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line; + printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings}; cop_label %s - cop_stash 0x%x - cop_filegv 0x%x + cop_stashpv %s + cop_file %s cop_seq %d cop_arybase %d cop_line %d + cop_warnings 0x%x EOT - $filegv->debug; } sub B::SVOP::debug { @@ -92,11 +84,10 @@ sub B::PVOP::debug { printf "\top_pv\t\t0x%x\n", $op->pv; } -sub B::GVOP::debug { +sub B::PADOP::debug { my ($op) = @_; $op->B::OP::debug(); - printf "\top_gv\t\t0x%x\n", ${$op->gv}; - $op->gv->debug; + printf "\top_padix\t\t%ld\n", $op->padix; } sub B::CVOP::debug { @@ -184,14 +175,14 @@ sub B::CV::debug { my ($start) = $sv->START; my ($root) = $sv->ROOT; my ($padlist) = $sv->PADLIST; + my ($file) = $sv->FILE; my ($gv) = $sv->GV; - my ($filegv) = $sv->FILEGV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; STASH 0x%x START 0x%x ROOT 0x%x GV 0x%x - FILEGV 0x%x + FILE %s DEPTH %d PADLIST 0x%x OUTSIDE 0x%x @@ -199,7 +190,6 @@ EOT $start->debug if $start; $root->debug if $root; $gv->debug if $gv; - $filegv->debug if $filegv; $padlist->debug if $padlist; } @@ -226,7 +216,7 @@ sub B::GV::debug { my ($av) = $gv->AV; my ($cv) = $gv->CV; $gv->B::SV::debug; - printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS; + printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; NAME %s STASH %s (0x%x) SV 0x%x @@ -238,7 +228,7 @@ sub B::GV::debug { CV 0x%x CVGEN %d LINE %d - FILEGV 0x%x + FILE %s GvFLAGS 0x%x EOT $sv->debug if $sv; @@ -253,6 +243,7 @@ sub B::SPECIAL::debug { sub compile { my $order = shift; + B::clearsym(); if ($order eq "exec") { return sub { walkoptree_exec(main_start, "debug") } } else { diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm index 5e0bd1d..cd53c11 100644 --- a/contrib/perl5/ext/B/B/Deparse.pm +++ b/contrib/perl5/ext/B/B/Deparse.pm @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -7,9 +7,17 @@ # but essentially none of his code remains. package B::Deparse; -use Carp 'cluck'; -use B qw(class main_root main_start main_cv svref_2object); -$VERSION = 0.56; +use Carp 'cluck', 'croak'; +use Config; +use B qw(class main_root main_start main_cv svref_2object opnumber + OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST + OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL + OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE + OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY + SVf_IOK SVf_NOK SVf_ROK SVf_POK + PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE + PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); +$VERSION = 0.59; use strict; # Changes between 0.50 and 0.51: @@ -26,17 +34,17 @@ use strict; # Changes between 0.51 and 0.52: # - added pp_threadsv (special variables under USE_THREADS) # - added documentation -# Changes between 0.52 and 0.53 +# Changes between 0.52 and 0.53: # - many changes adding precedence contexts and associativity # - added `-p' and `-s' output style options # - various other minor fixes -# Changes between 0.53 and 0.54 +# Changes between 0.53 and 0.54: # - added support for new `for (1..100)' optimization, # thanks to Gisle Aas -# Changes between 0.54 and 0.55 +# Changes between 0.54 and 0.55: # - added support for new qr// construct # - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56 +# Changes between 0.55 and 0.56: # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t # - fixed $# on non-lexicals broken in last big rewrite # - added temporary fix for change in opcode of OP_STRINGIFY @@ -50,17 +58,51 @@ use strict; # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' # - added semicolons at the ends of blocks # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 +# Changes between 0.56 and 0.561: +# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) +# - used new B.pm symbolic constants (done by Nick Ing-Simmons) +# Changes between 0.561 and 0.57: +# - stylistic changes to symbolic constant stuff +# - handled scope in s///e replacement code +# - added unquote option for expanding "" into concats, etc. +# - split method and proto parts of pp_entersub into separate functions +# - various minor cleanups +# Changes after 0.57: +# - added parens in \&foo (patch by Albert Dvornik) +# Changes between 0.57 and 0.58: +# - fixed `0' statements that weren't being printed +# - added methods for use from other programs +# (based on patches from James Duncan and Hugo van der Sanden) +# - added -si and -sT to control indenting (also based on a patch from Hugo) +# - added -sv to print something else instead of '???' +# - preliminary version of utf8 tr/// handling +# Changes after 0.58: +# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) +# - added support for Hugo's new OP_SETSTATE (like nextstate) +# Changes between 0.58 and 0.59 +# - added support for Chip's OP_METHOD_NAMED +# - added support for Ilya's OPpTARGET_MY optimization +# - elided arrows before `()' subscripts when possible # Todo: +# - finish tr/// changes +# - add option for even more parens (generalize \&foo change) # - {} around variables in strings ("${var}letters") # base/lex.t 25-27 # comp/term.t 11 -# - generate symbolic constants directly from core source # - left/right context +# - recognize `use utf8', `use integer', etc +# - treat top-level block specially for incremental output +# - interpret in high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) # - break long lines ("\r" as discretionary break?) +# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. +# - more style options: brace style, hex vs. octal, quotes, ... +# - print big ints as hex/octal instead of decimal (heuristic?) +# - handle `my $x if 0'? # - include values of variables (e.g. set in BEGIN) # - coordinate with Data::Dumper (both directions? see previous) # - version using op_next instead of op_first/sibling? @@ -103,7 +145,11 @@ use strict; # # parens: -p # linenums: -l +# unquote: -q # cuddle: ` ' or `\n', depending on -sC +# indent_size: -si +# use_tabs: -sT +# ex_const: -sv # A little explanation of how precedence contexts and associativity # work: @@ -182,13 +228,10 @@ sub next_todo { return "format $name =\n" . $self->deparse_format($ent->[1]->FORM). "\n"; } else { - return "sub $name " . - $self->deparse_sub($ent->[1]->CV); + return "sub $name " . $self->deparse_sub($ent->[1]->CV); } } -sub OPf_KIDS () { 4 } - sub walk_tree { my($op, $sub) = @_; $sub->($op); @@ -208,19 +251,20 @@ sub walk_sub { return if !$op or null $op; walk_tree($op, sub { my $op = shift; - if ($op->ppaddr eq "pp_gv") { - if ($op->next->ppaddr eq "pp_entersub") { - next if $self->{'subs_done'}{$ {$op->gv}}++; - next if class($op->gv->CV) eq "SPECIAL"; - $self->todo($op->gv, $op->gv->CV, 0); - $self->walk_sub($op->gv->CV); - } elsif ($op->next->ppaddr eq "pp_enterwrite" - or ($op->next->ppaddr eq "pp_rv2gv" - and $op->next->next->ppaddr eq "pp_enterwrite")) { - next if $self->{'forms_done'}{$ {$op->gv}}++; - next if class($op->gv->FORM) eq "SPECIAL"; - $self->todo($op->gv, $op->gv->FORM, 1); - $self->walk_sub($op->gv->FORM); + if ($op->name eq "gv") { + my $gv = $self->maybe_padgv($op); + if ($op->next->name eq "entersub") { + next if $self->{'subs_done'}{$$gv}++; + next if class($gv->CV) eq "SPECIAL"; + $self->todo($gv, $gv->CV, 0); + $self->walk_sub($gv->CV); + } elsif ($op->next->name eq "enterwrite" + or ($op->next->name eq "rv2gv" + and $op->next->next->name eq "enterwrite")) { + next if $self->{'forms_done'}{$$gv}++; + next if class($gv->FORM) eq "SPECIAL"; + $self->todo($gv, $gv->FORM, 1); + $self->walk_sub($gv->FORM); } } }); @@ -279,37 +323,57 @@ sub style_opts { while (length($opt = substr($opts, 0, 1))) { if ($opt eq "C") { $self->{'cuddle'} = " "; + $opts = substr($opts, 1); + } elsif ($opt eq "i") { + $opts =~ s/^i(\d+)//; + $self->{'indent_size'} = $1; + } elsif ($opt eq "T") { + $self->{'use_tabs'} = 1; + $opts = substr($opts, 1); + } elsif ($opt eq "v") { + $opts =~ s/^v([^.]*)(.|$)//; + $self->{'ex_const'} = $1; } - $opts = substr($opts, 1); } } +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{'subs_todo'} = []; + $self->{'curstash'} = "main"; + $self->{'cuddle'} = "\n"; + $self->{'indent_size'} = 4; + $self->{'use_tabs'} = 0; + $self->{'ex_const'} = "'???'"; + while (my $arg = shift @_) { + if (substr($arg, 0, 2) eq "-u") { + $self->stash_subs(substr($arg, 2)); + } elsif ($arg eq "-p") { + $self->{'parens'} = 1; + } elsif ($arg eq "-l") { + $self->{'linenums'} = 1; + } elsif ($arg eq "-q") { + $self->{'unquote'} = 1; + } elsif (substr($arg, 0, 2) eq "-s") { + $self->style_opts(substr $arg, 2); + } + } + return $self; +} + sub compile { my(@args) = @_; return sub { - my $self = bless {}; - my $arg; - $self->{'subs_todo'} = []; + my $self = B::Deparse->new(@args); $self->stash_subs("main"); $self->{'curcv'} = main_cv; - $self->{'curstash'} = "main"; - $self->{'cuddle'} = "\n"; - while ($arg = shift @args) { - if (substr($arg, 0, 2) eq "-u") { - $self->stash_subs(substr($arg, 2)); - } elsif ($arg eq "-p") { - $self->{'parens'} = 1; - } elsif ($arg eq "-l") { - $self->{'linenums'} = 1; - } elsif (substr($arg, 0, 2) eq "-s") { - $self->style_opts(substr $arg, 2); - } - } $self->walk_sub(main_cv, main_start); print $self->print_protos; @{$self->{'subs_todo'}} = - sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; - print indent($self->deparse(main_root, 0)), "\n" unless null main_root; + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; + print $self->indent($self->deparse(main_root, 0)), "\n" + unless null main_root; my @text; while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; @@ -318,25 +382,38 @@ sub compile { } } +sub coderef2text { + my $self = shift; + my $sub = shift; + croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE"; + return $self->indent($self->deparse_sub(svref_2object($sub))); +} + sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; - my $meth = $op->ppaddr; +# return $self->$ {\("pp_" . $op->name)}($op, $cx); + my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); } sub indent { + my $self = shift; my $txt = shift; my @lines = split(/\n/, $txt); my $leader = ""; + my $level = 0; my $line; for $line (@lines) { - if (substr($line, 0, 1) eq "\t") { - $leader = $leader . " "; - $line = substr($line, 1); - } elsif (substr($line, 0, 1) eq "\b") { - $leader = substr($leader, 0, length($leader) - 4); + my $cmd = substr($line, 0, 1); + if ($cmd eq "\t" or $cmd eq "\b") { + $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; + if ($self->{'use_tabs'}) { + $leader = "\t" x ($level / 8) . " " x ($level % 8); + } else { + $leader = " " x $level; + } $line = substr($line, 1); } if (substr($line, 0, 1) eq "\f") { @@ -349,8 +426,6 @@ sub indent { return join("\n", @lines); } -sub SVf_POK () {0x40000} - sub deparse_sub { my $self = shift; my $cv = shift; @@ -382,7 +457,7 @@ sub deparse_format { $op = $op->sibling; # skip nextstate my @exprs; $kid = $op->first->sibling; # skip pushmark - push @text, $kid->sv->PV; + push @text, $self->const_sv($kid)->PV; $kid = $kid->sibling; for (; not null $kid; $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 0); @@ -393,47 +468,38 @@ sub deparse_format { return join("", @text) . "."; } -# the aassign in-common check messes up SvCUR (always setting it -# to a value >= 100), but it's probably safe to assume there -# won't be any NULs in the names of my() variables. (with -# stash variables, I wouldn't be so sure) -sub padname_fix { - my $str = shift; - $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; - return $str; -} - sub is_scope { my $op = shift; - return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope" - || $op->ppaddr eq "pp_lineseq" - || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" - && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter")); + return $op->name eq "leave" || $op->name eq "scope" + || $op->name eq "lineseq" + || ($op->name eq "null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->name eq "enter")); } sub is_state { - my $name = $_[0]->ppaddr; - return $name eq "pp_nextstate" || $name eq "pp_dbstate"; + my $name = $_[0]->name; + return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; } sub is_miniwhile { # check for one-line loop (`foo() while $y--') my $op = shift; return (!null($op) and null($op->sibling) - and $op->ppaddr eq "pp_null" and class($op) eq "UNOP" - and (($op->first->ppaddr =~ /^pp_(and|or)$/ - and $op->first->first->sibling->ppaddr eq "pp_lineseq") - or ($op->first->ppaddr eq "pp_lineseq" + and $op->name eq "null" and class($op) eq "UNOP" + and (($op->first->name =~ /^(and|or)$/ + and $op->first->first->sibling->name eq "lineseq") + or ($op->first->name eq "lineseq" and not null $op->first->first->sibling - and $op->first->first->sibling->ppaddr eq "pp_unstack") + and $op->first->first->sibling->name eq "unstack") )); } sub is_scalar { my $op = shift; - return ($op->ppaddr eq "pp_rv2sv" or - $op->ppaddr eq "pp_padsv" or - $op->ppaddr eq "pp_gv" or # only in array/hash constructs - !null($op->first) && $op->first->ppaddr eq "pp_gvsv"); + return ($op->name eq "rv2sv" or + $op->name eq "padsv" or + $op->name eq "gv" or # only in array/hash constructs + $op->flags & OPf_KIDS && !null($op->first) + && $op->first->name eq "gvsv"); } sub maybe_parens { @@ -483,18 +549,28 @@ sub maybe_parens_func { } } -sub OPp_LVAL_INTRO () { 128 } - sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; - if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { return $self->maybe_parens_func("local", $text, $cx, 16); } else { return $text; } } +sub maybe_targmy { + my $self = shift; + my($op, $cx, $func, @args) = @_; + if ($op->private & OPpTARGET_MY) { + my $var = $self->padname($op->targ); + my $val = $func->($self, $op, 7, @args); + return $self->maybe_parens("$var = $val", $cx, 7); + } else { + return $func->($self, $op, $cx, @args); + } +} + sub padname_sv { my $self = shift; my $targ = shift; @@ -504,7 +580,7 @@ sub padname_sv { sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; - if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { return $self->maybe_parens_func("my", $text, $cx, 16); } else { return $text; @@ -606,10 +682,10 @@ sub pp_leave { $kid = $op->first->sibling; # skip enter if (is_miniwhile($kid)) { my $top = $kid->first; - my $name = $top->ppaddr; - if ($name eq "pp_and") { + my $name = $top->name; + if ($name eq "and") { $name = "while"; - } elsif ($name eq "pp_or") { + } elsif ($name eq "or") { $name = "until"; } else { # no conditional -> while 1 or until 0 return $self->deparse($top->first, 1) . " while 1"; @@ -628,7 +704,7 @@ sub pp_leave { last if null $kid; } $expr .= $self->deparse($kid, 0); - push @exprs, $expr if $expr; + push @exprs, $expr if length $expr; } if ($cx > 0) { # inside an expression return "do { " . join(";\n", @exprs) . " }"; @@ -650,7 +726,7 @@ sub pp_scope { last if null $kid; } $expr .= $self->deparse($kid, 0); - push @exprs, $expr if $expr; + push @exprs, $expr if length $expr; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) return "do { " . join(";\n", @exprs) . " }"; @@ -696,19 +772,20 @@ sub pp_nextstate { and $seq > $self->{'subs_todo'}[0][0]) { push @text, $self->next_todo; } - my $stash = $op->stash->NAME; + my $stash = $op->stashpv; if ($stash ne $self->{'curstash'}) { push @text, "package $stash;\n"; $self->{'curstash'} = $stash; } if ($self->{'linenums'}) { push @text, "\f#line " . $op->line . - ' "' . substr($op->filegv->NAME, 2), qq'"\n'; + ' "' . $op->file, qq'"\n'; } return join("", @text); } sub pp_dbstate { pp_nextstate(@_) } +sub pp_setstate { pp_nextstate(@_) } sub pp_unstack { return "" } # see also leaveloop @@ -721,9 +798,9 @@ sub baseop { sub pp_stub { baseop(@_, "()") } sub pp_wantarray { baseop(@_, "wantarray") } sub pp_fork { baseop(@_, "fork") } -sub pp_wait { baseop(@_, "wait") } -sub pp_getppid { baseop(@_, "getppid") } -sub pp_time { baseop(@_, "time") } +sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } +sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } +sub pp_time { maybe_targmy(@_, \&baseop, "time") } sub pp_tms { baseop(@_, "times") } sub pp_ghostent { baseop(@_, "gethostent") } sub pp_gnetent { baseop(@_, "getnetent") } @@ -757,18 +834,19 @@ sub pfixop { sub pp_preinc { pfixop(@_, "++", 23) } sub pp_predec { pfixop(@_, "--", 23) } -sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) } -sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) } +sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } -sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) } -sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) } -sub pp_complement { pfixop(@_, "~", 21) } +sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) } -sub pp_negate { +sub pp_negate { maybe_targmy(@_, \&real_negate) } +sub real_negate { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) { + if ($op->first->name =~ /^(i_)?negate$/) { # avoid --$x $self->pfixop($op, $cx, "-", 21.5); } else { @@ -787,11 +865,9 @@ sub pp_not { } } -sub OPf_SPECIAL () { 128 } - sub unop { my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my($op, $cx, $name) = @_; my $kid; if ($op->flags & OPf_KIDS) { $kid = $op->first; @@ -801,36 +877,31 @@ sub unop { } } -sub pp_chop { unop(@_, "chop") } -sub pp_chomp { unop(@_, "chomp") } -sub pp_schop { unop(@_, "chop") } -sub pp_schomp { unop(@_, "chomp") } +sub pp_chop { maybe_targmy(@_, \&unop, "chop") } +sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_schop { maybe_targmy(@_, \&unop, "chop") } +sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } sub pp_defined { unop(@_, "defined") } sub pp_undef { unop(@_, "undef") } sub pp_study { unop(@_, "study") } sub pp_ref { unop(@_, "ref") } sub pp_pos { maybe_local(@_, unop(@_, "pos")) } -sub pp_sin { unop(@_, "sin") } -sub pp_cos { unop(@_, "cos") } -sub pp_rand { unop(@_, "rand") } +sub pp_sin { maybe_targmy(@_, \&unop, "sin") } +sub pp_cos { maybe_targmy(@_, \&unop, "cos") } +sub pp_rand { maybe_targmy(@_, \&unop, "rand") } sub pp_srand { unop(@_, "srand") } -sub pp_exp { unop(@_, "exp") } -sub pp_log { unop(@_, "log") } -sub pp_sqrt { unop(@_, "sqrt") } -sub pp_int { unop(@_, "int") } -sub pp_hex { unop(@_, "hex") } -sub pp_oct { unop(@_, "oct") } -sub pp_abs { unop(@_, "abs") } - -sub pp_length { unop(@_, "length") } -sub pp_ord { unop(@_, "ord") } -sub pp_chr { unop(@_, "chr") } -sub pp_ucfirst { unop(@_, "ucfirst") } -sub pp_lcfirst { unop(@_, "lcfirst") } -sub pp_uc { unop(@_, "uc") } -sub pp_lc { unop(@_, "lc") } -sub pp_quotemeta { unop(@_, "quotemeta") } +sub pp_exp { maybe_targmy(@_, \&unop, "exp") } +sub pp_log { maybe_targmy(@_, \&unop, "log") } +sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } +sub pp_int { maybe_targmy(@_, \&unop, "int") } +sub pp_hex { maybe_targmy(@_, \&unop, "hex") } +sub pp_oct { maybe_targmy(@_, \&unop, "oct") } +sub pp_abs { maybe_targmy(@_, \&unop, "abs") } + +sub pp_length { maybe_targmy(@_, \&unop, "length") } +sub pp_ord { maybe_targmy(@_, \&unop, "ord") } +sub pp_chr { maybe_targmy(@_, \&unop, "chr") } sub pp_each { unop(@_, "each") } sub pp_values { unop(@_, "values") } @@ -856,19 +927,19 @@ sub pp_tell { unop(@_, "tell") } sub pp_getsockname { unop(@_, "getsockname") } sub pp_getpeername { unop(@_, "getpeername") } -sub pp_chdir { unop(@_, "chdir") } -sub pp_chroot { unop(@_, "chroot") } +sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } +sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } sub pp_readlink { unop(@_, "readlink") } -sub pp_rmdir { unop(@_, "rmdir") } +sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } sub pp_readdir { unop(@_, "readdir") } sub pp_telldir { unop(@_, "telldir") } sub pp_rewinddir { unop(@_, "rewinddir") } sub pp_closedir { unop(@_, "closedir") } -sub pp_getpgrp { unop(@_, "getpgrp") } +sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } sub pp_localtime { unop(@_, "localtime") } sub pp_gmtime { unop(@_, "gmtime") } sub pp_alarm { unop(@_, "alarm") } -sub pp_sleep { unop(@_, "sleep") } +sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } sub pp_dofile { unop(@_, "do") } sub pp_entereval { unop(@_, "eval") } @@ -894,8 +965,6 @@ sub pp_exists { $cx, 16); } -sub OPpSLICE () { 64 } - sub pp_delete { my $self = shift; my($op, $cx) = @_; @@ -911,15 +980,13 @@ sub pp_delete { } } -sub OPp_CONST_BARE () { 64 } - sub pp_require { my $self = shift; my($op, $cx) = @_; - if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const" - and $op->first->private & OPp_CONST_BARE) + if (class($op) eq "UNOP" and $op->first->name eq "const" + and $op->first->private & OPpCONST_BARE) { - my $name = $op->first->sv->PV; + my $name = $self->const_sv($op->first)->PV; $name =~ s[/][::]g; $name =~ s/\.pm//g; return "require($name)"; @@ -943,20 +1010,19 @@ sub pp_scalar { sub padval { my $self = shift; my $targ = shift; + #cluck "curcv was undef" unless $self->{curcv}; return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ]; } -sub OPf_REF () { 16 } - sub pp_refgen { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_null") { + if ($kid->name eq "null") { $kid = $kid->first; - if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") { - my($pre, $post) = @{{"pp_anonlist" => ["[","]"], - "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}}; + if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { + my($pre, $post) = @{{"anonlist" => ["[","]"], + "anonhash" => ["{","}"]}->{$kid->name}}; my($expr, @exprs); $kid = $kid->first->sibling; # skip pushmark for (; !null($kid); $kid = $kid->sibling) { @@ -965,16 +1031,25 @@ sub pp_refgen { } return $pre . join(", ", @exprs) . $post; } elsif (!null($kid->sibling) and - $kid->sibling->ppaddr eq "pp_anoncode") { + $kid->sibling->name eq "anoncode") { return "sub " . $self->deparse_sub($self->padval($kid->sibling->targ)); - } elsif ($kid->ppaddr eq "pp_pushmark" - and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/ - and not $kid->sibling->flags & OPf_REF) { - # The @a in \(@a) isn't in ref context, but only when the - # parens are there. - return "\\(" . $self->deparse($kid->sibling, 1) . ")"; - } + } elsif ($kid->name eq "pushmark") { + my $sib_name = $kid->sibling->name; + if ($sib_name =~ /^(pad|rv2)[ah]v$/ + and not $kid->sibling->flags & OPf_REF) + { + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + return "\\(" . $self->deparse($kid->sibling, 1) . ")"; + } elsif ($sib_name eq 'entersub') { + my $text = $self->deparse($kid->sibling, 1); + # Always show parens for \(&func()), but only with -p otherwise + $text = "($text)" if $self->{'parens'} + or $kid->sibling->private & OPpENTERSUB_AMPER; + return "\\$text"; + } + } } $self->pfixop($op, $cx, "\\", 20); } @@ -985,13 +1060,31 @@ sub pp_readline { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh> - if ($kid->ppaddr eq "pp_rv2gv") { - $kid = $kid->first; - } + $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> return "<" . $self->deparse($kid, 1) . ">"; } +# Unary operators that can occur as pseudo-listops inside double quotes +sub dq_unop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + # If there's more than one kid, the first is an ex-pushmark. + $kid = $kid->sibling if not null $kid->sibling; + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_ucfirst { dq_unop(@_, "ucfirst") } +sub pp_lcfirst { dq_unop(@_, "lcfirst") } +sub pp_uc { dq_unop(@_, "uc") } +sub pp_lc { dq_unop(@_, "lc") } +sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } + sub loopex { my $self = shift; my ($op, $cx, $name) = @_; @@ -1019,7 +1112,7 @@ sub ftst { # Genuine `-X' filetests are exempt from the LLAFR, but not # l?stat(); for the sake of clarity, give'em all parens return $self->maybe_parens_unop($name, $op->first, $cx); - } elsif (class($op) eq "GVOP") { + } elsif (class($op) eq "SVOP") { return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); } else { # I don't think baseop filetests ever survive ck_ftst, but... return $name; @@ -1059,19 +1152,17 @@ sub pp_ftbinary { ftst(@_, "-B") } sub SWAP_CHILDREN () { 1 } sub ASSIGN () { 2 } # has OP= variant -sub OPf_STACKED () { 64 } - my(%left, %right); sub assoc_class { my $op = shift; - my $name = $op->ppaddr; - if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") { + my $name = $op->name; + if ($name eq "concat" and $op->first->name eq "concat") { # avoid spurious `=' -- see comment in pp_concat - return "pp_concat"; + return "concat"; } - if ($name eq "pp_null" and class($op) eq "UNOP" - and $op->first->ppaddr =~ /^pp_(and|x?or)$/ + if ($name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|x?or)$/ and null $op->first->sibling) { # Like all conditional constructs, OP_ANDs and OP_ORs are topped @@ -1088,25 +1179,25 @@ sub assoc_class { # $a + $b + $c is equivalent to ($a + $b) + $c BEGIN { - %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19, - 'pp_divide' => 19, 'pp_i_divide' => 19, - 'pp_modulo' => 19, 'pp_i_modulo' => 19, - 'pp_repeat' => 19, - 'pp_add' => 18, 'pp_i_add' => 18, - 'pp_subtract' => 18, 'pp_i_subtract' => 18, - 'pp_concat' => 18, - 'pp_left_shift' => 17, 'pp_right_shift' => 17, - 'pp_bit_and' => 13, - 'pp_bit_or' => 12, 'pp_bit_xor' => 12, - 'pp_and' => 3, - 'pp_or' => 2, 'pp_xor' => 2, + %left = ('multiply' => 19, 'i_multiply' => 19, + 'divide' => 19, 'i_divide' => 19, + 'modulo' => 19, 'i_modulo' => 19, + 'repeat' => 19, + 'add' => 18, 'i_add' => 18, + 'subtract' => 18, 'i_subtract' => 18, + 'concat' => 18, + 'left_shift' => 17, 'right_shift' => 17, + 'bit_and' => 13, + 'bit_or' => 12, 'bit_xor' => 12, + 'and' => 3, + 'or' => 2, 'xor' => 2, ); } sub deparse_binop_left { my $self = shift; my($op, $left, $prec) = @_; - if ($left{assoc_class($op)} + if ($left{assoc_class($op)} && $left{assoc_class($left)} and $left{assoc_class($op)} == $left{assoc_class($left)}) { return $self->deparse($left, $prec - .00001); @@ -1119,27 +1210,27 @@ sub deparse_binop_left { # $a = $b = $c is equivalent to $a = ($b = $c) BEGIN { - %right = ('pp_pow' => 22, - 'pp_sassign=' => 7, 'pp_aassign=' => 7, - 'pp_multiply=' => 7, 'pp_i_multiply=' => 7, - 'pp_divide=' => 7, 'pp_i_divide=' => 7, - 'pp_modulo=' => 7, 'pp_i_modulo=' => 7, - 'pp_repeat=' => 7, - 'pp_add=' => 7, 'pp_i_add=' => 7, - 'pp_subtract=' => 7, 'pp_i_subtract=' => 7, - 'pp_concat=' => 7, - 'pp_left_shift=' => 7, 'pp_right_shift=' => 7, - 'pp_bit_and=' => 7, - 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7, - 'pp_andassign' => 7, - 'pp_orassign' => 7, + %right = ('pow' => 22, + 'sassign=' => 7, 'aassign=' => 7, + 'multiply=' => 7, 'i_multiply=' => 7, + 'divide=' => 7, 'i_divide=' => 7, + 'modulo=' => 7, 'i_modulo=' => 7, + 'repeat=' => 7, + 'add=' => 7, 'i_add=' => 7, + 'subtract=' => 7, 'i_subtract=' => 7, + 'concat=' => 7, + 'left_shift=' => 7, 'right_shift=' => 7, + 'bit_and=' => 7, + 'bit_or=' => 7, 'bit_xor=' => 7, + 'andassign' => 7, + 'orassign' => 7, ); } sub deparse_binop_right { my $self = shift; my($op, $right, $prec) = @_; - if ($right{assoc_class($op)} + if ($right{assoc_class($op)} && $right{assoc_class($right)} and $right{assoc_class($op)} == $right{assoc_class($right)}) { return $self->deparse($right, $prec - .00001); @@ -1166,23 +1257,23 @@ sub binop { return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); } -sub pp_add { binop(@_, "+", 18, ASSIGN) } -sub pp_multiply { binop(@_, "*", 19, ASSIGN) } -sub pp_subtract { binop(@_, "-",18, ASSIGN) } -sub pp_divide { binop(@_, "/", 19, ASSIGN) } -sub pp_modulo { binop(@_, "%", 19, ASSIGN) } -sub pp_i_add { binop(@_, "+", 18, ASSIGN) } -sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) } -sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) } -sub pp_i_divide { binop(@_, "/", 19, ASSIGN) } -sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) } -sub pp_pow { binop(@_, "**", 22, ASSIGN) } - -sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) } -sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) } -sub pp_bit_and { binop(@_, "&", 13, ASSIGN) } -sub pp_bit_or { binop(@_, "|", 12, ASSIGN) } -sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) } +sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } +sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } +sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } + +sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } +sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } +sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } +sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } +sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } sub pp_eq { binop(@_, "==", 14) } sub pp_ne { binop(@_, "!=", 14) } @@ -1213,14 +1304,15 @@ sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) } # `.' is special because concats-of-concats are optimized to save copying # by making all but the first concat stacked. The effect is as if the # programmer had written `($a . $b) .= $c', except legal. -sub pp_concat { +sub pp_concat { maybe_targmy(@_, \&real_concat) } +sub real_concat { my $self = shift; my($op, $cx) = @_; my $left = $op->first; my $right = $op->last; my $eq = ""; my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") { + if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { $eq = "="; $prec = 7; } @@ -1301,7 +1393,10 @@ sub logop { } sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } -sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } + +# xor is syntactically a logop, but it's really a binop (contrary to +# old versions of opcode.pl). Syntax is what matters here. sub pp_xor { logop(@_, "xor", 2, "", 0, "") } sub logassignop { @@ -1339,20 +1434,20 @@ sub listop { } sub pp_bless { listop(@_, "bless") } -sub pp_atan2 { listop(@_, "atan2") } +sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } sub pp_substr { maybe_local(@_, listop(@_, "substr")) } sub pp_vec { maybe_local(@_, listop(@_, "vec")) } -sub pp_index { listop(@_, "index") } -sub pp_rindex { listop(@_, "rindex") } -sub pp_sprintf { listop(@_, "sprintf") } +sub pp_index { maybe_targmy(@_, \&listop, "index") } +sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } +sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } sub pp_formline { listop(@_, "formline") } # see also deparse_format -sub pp_crypt { listop(@_, "crypt") } +sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } sub pp_unpack { listop(@_, "unpack") } sub pp_pack { listop(@_, "pack") } -sub pp_join { listop(@_, "join") } +sub pp_join { maybe_targmy(@_, \&listop, "join") } sub pp_splice { listop(@_, "splice") } -sub pp_push { listop(@_, "push") } -sub pp_unshift { listop(@_, "unshift") } +sub pp_push { maybe_targmy(@_, \&listop, "push") } +sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } sub pp_reverse { listop(@_, "reverse") } sub pp_warn { listop(@_, "warn") } sub pp_die { listop(@_, "die") } @@ -1375,7 +1470,7 @@ sub pp_recv { listop(@_, "recv") } sub pp_seek { listop(@_, "seek") } sub pp_fcntl { listop(@_, "fcntl") } sub pp_ioctl { listop(@_, "ioctl") } -sub pp_flock { listop(@_, "flock") } +sub pp_flock { maybe_targmy(@_, \&listop, "flock") } sub pp_socket { listop(@_, "socket") } sub pp_sockpair { listop(@_, "sockpair") } sub pp_bind { listop(@_, "bind") } @@ -1385,23 +1480,23 @@ sub pp_accept { listop(@_, "accept") } sub pp_shutdown { listop(@_, "shutdown") } sub pp_gsockopt { listop(@_, "getsockopt") } sub pp_ssockopt { listop(@_, "setsockopt") } -sub pp_chown { listop(@_, "chown") } -sub pp_unlink { listop(@_, "unlink") } -sub pp_chmod { listop(@_, "chmod") } -sub pp_utime { listop(@_, "utime") } -sub pp_rename { listop(@_, "rename") } -sub pp_link { listop(@_, "link") } -sub pp_symlink { listop(@_, "symlink") } -sub pp_mkdir { listop(@_, "mkdir") } +sub pp_chown { maybe_targmy(@_, \&listop, "chown") } +sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } +sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } +sub pp_utime { maybe_targmy(@_, \&listop, "utime") } +sub pp_rename { maybe_targmy(@_, \&listop, "rename") } +sub pp_link { maybe_targmy(@_, \&listop, "link") } +sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } +sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } sub pp_open_dir { listop(@_, "opendir") } sub pp_seekdir { listop(@_, "seekdir") } -sub pp_waitpid { listop(@_, "waitpid") } -sub pp_system { listop(@_, "system") } -sub pp_exec { listop(@_, "exec") } -sub pp_kill { listop(@_, "kill") } -sub pp_setpgrp { listop(@_, "setpgrp") } -sub pp_getpriority { listop(@_, "getpriority") } -sub pp_setpriority { listop(@_, "setpriority") } +sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } +sub pp_system { maybe_targmy(@_, \&listop, "system") } +sub pp_exec { maybe_targmy(@_, \&listop, "exec") } +sub pp_kill { maybe_targmy(@_, \&listop, "kill") } +sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } +sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } +sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } sub pp_shmget { listop(@_, "shmget") } sub pp_shmctl { listop(@_, "shmctl") } sub pp_shmread { listop(@_, "shmread") } @@ -1442,10 +1537,10 @@ sub pp_truncate { my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; my $kid = $op->first->sibling; - my($fh, $len); + my $fh; if ($op->flags & OPf_SPECIAL) { # $kid is an OP_CONST - $fh = $kid->sv->PV; + $fh = $self->const_sv($kid)->PV; } else { $fh = $self->deparse($kid, 6); $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; @@ -1456,7 +1551,6 @@ sub pp_truncate { } else { return "truncate $fh, $len"; } - } sub indirop { @@ -1480,8 +1574,7 @@ sub indirop { $expr = $self->deparse($kid, 6); push @exprs, $expr; } - return $self->maybe_parens_func($name, - $indir . join(", ", @exprs), + return $self->maybe_parens_func($name, $indir . join(", ", @exprs), $cx, 5); } @@ -1497,7 +1590,7 @@ sub mapop { $kid = $kid->first->sibling; # skip a pushmark my $code = $kid->first; # skip a null if (is_scope $code) { - $code = "{" . $self->deparse($code, 1) . "} "; + $code = "{" . $self->deparse($code, 0) . "} "; } else { $code = $self->deparse($code, 24) . ", "; } @@ -1523,15 +1616,15 @@ sub pp_list { # This assumes that no other private flags equal 128, and that # OPs that store things other than flags in their op_private, # like OP_AELEMFAST, won't be immediate children of a list. - unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef") + unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef") { $local = ""; # or not last; } - if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my() + if ($lop->name =~ /^pad[ash]v$/) { # my() ($local = "", last) if $local eq "local"; $local = "my"; - } elsif ($lop->ppaddr ne "pp_undef") { # local() + } elsif ($lop->name ne "undef") { # local() ($local = "", last) if $local eq "my"; $local = "local"; } @@ -1540,7 +1633,7 @@ sub pp_list { return $self->deparse($kid, $cx) if null $kid->sibling and not $local; for (; !null($kid); $kid = $kid->sibling) { if ($local) { - if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") { + if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { $lop = $kid->first; } else { $lop = $kid; @@ -1575,10 +1668,10 @@ sub pp_cond_expr { } $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif + if ($false->name eq "lineseq") { # braces w/o scope => elsif my $head = "if ($cond) {\n\t$true\n\b}"; my @elsifs; - while (!null($false) and $false->ppaddr eq "pp_lineseq") { + while (!null($false) and $false->name eq "lineseq") { my $newop = $false->first->sibling->first; my $newcond = $newop->first; my $newtrue = $newcond->sibling; @@ -1607,13 +1700,13 @@ sub pp_leaveloop { local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; - if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop + if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) } else { $bare = 1; } - } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach + } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; if ($enter->flags & OPf_STACKED @@ -1638,20 +1731,20 @@ sub pp_leaveloop { $var = "my " . $var; } } - } elsif ($var->ppaddr eq "pp_rv2gv") { + } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); - } elsif ($var->ppaddr eq "pp_gv") { + } elsif ($var->name eq "gv") { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER - } elsif ($kid->ppaddr eq "pp_null") { # while/until + } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"pp_and" => "while", "pp_or" => "until"} - ->{$kid->ppaddr}; + my $name = {"and" => "while", "or" => "until"} + ->{$kid->name}; $head = "$name (" . $self->deparse($kid->first, 1) . ") "; $kid = $kid->first->sibling; - } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty + } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } # The third-to-last kid is the continue block if the pointer used @@ -1663,15 +1756,14 @@ sub pp_leaveloop { # (because it's a nulled out nextstate in a scope), in which # case the head's next is advanced past the null but the nextop's # isn't, so we need to try nextop->next. - my($cont, $precont); + my $precont; + my $cont = $kid->first; if ($bare) { - $cont = $kid->first; while (!null($cont->sibling)) { $precont = $cont; $cont = $cont->sibling; } } else { - $cont = $kid->first; while (!null($cont->sibling->sibling->sibling)) { $precont = $cont; $cont = $cont->sibling; @@ -1708,30 +1800,29 @@ sub pp_leavetry { return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; } -sub OP_CONST () { 5 } - -# XXX need a better way to do this -sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 } +BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } +BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } sub pp_null { my $self = shift; my($op, $cx) = @_; if (class($op) eq "OP") { - return "'???'" if $op->targ == OP_CONST; # old value is lost - } elsif ($op->first->ppaddr eq "pp_pushmark") { + # old value is lost + return $self->{'ex_const'} if $op->targ == OP_CONST; + } elsif ($op->first->name eq "pushmark") { return $self->pp_list($op, $cx); - } elsif ($op->first->ppaddr eq "pp_enter") { + } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { return $self->dquote($op); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_readline" and + $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 7) . " = " . $self->deparse($op->first->sibling, 7), $cx, 7); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_trans" and + $op->first->sibling->name eq "trans" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " . $self->deparse($op->first->sibling, 20), @@ -1741,6 +1832,16 @@ sub pp_null { } } +# the aassign in-common check messes up SvCUR (always setting it +# to a value >= 100), but it's probably safe to assume there +# won't be any NULs in the names of my() variables. (with +# stash variables, I wouldn't be so sure) +sub padname_fix { + my $str = shift; + $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; + return $str; +} + sub padname { my $self = shift; my $targ = shift; @@ -1778,22 +1879,37 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } +sub maybe_padgv { + my $self = shift; + my $op = shift; + my $gv; + if ($Config{useithreads}) { + $gv = $self->padval($op->padix); + } + else { + $gv = $op->gv; + } + return $gv; +} + sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv)); + my $gv = $self->maybe_padgv($op); + return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - return $self->gv_name($op->gv); + my $gv = $self->maybe_padgv($op); + return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $op->gv; + my $gv = $self->maybe_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -1813,7 +1929,7 @@ sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } sub pp_av2arylen { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr eq "pp_padav") { + if ($op->first->name eq "padav") { return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); } else { return $self->maybe_local($op, $cx, @@ -1828,23 +1944,41 @@ sub pp_rv2av { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_const") { # constant list - my $av = $kid->sv; + if ($kid->name eq "const") { # constant list + my $av = $self->const_sv($kid); return "(" . join(", ", map(const($_), $av->ARRAY)) . ")"; } else { return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); } } +sub is_subscriptable { + my $op = shift; + if ($op->name =~ /^[ahg]elem/) { + return 1; + } elsif ($op->name eq "entersub") { + my $kid = $op->first; + return 0 unless null $kid->sibling; + $kid = $kid->first; + $kid = $kid->sibling until null $kid->sibling; + return 0 if is_scope($kid); + $kid = $kid->first; + return 0 if $kid->name eq "gv"; + return 0 if is_scalar($kid); + return is_subscriptable($kid); + } else { + return 0; + } +} sub elem { my $self = shift; my ($op, $cx, $left, $right, $padname) = @_; my($array, $idx) = ($op->first, $op->first->sibling); - unless ($array->ppaddr eq $padname) { # Maybe this has been fixed + unless ($array->name eq $padname) { # Maybe this has been fixed $array = $array->first; # skip rv2av (or ex-rv2av in _53+) } - if ($array->ppaddr eq $padname) { + if ($array->name eq $padname) { $array = $self->padany($array); } elsif (is_scope($array)) { # ${expr}[0] $array = "{" . $self->deparse($array, 0) . "}"; @@ -1852,8 +1986,7 @@ sub elem { $array = $self->deparse($array, 24); } else { # $x[20][3]{hi} or expr->[20] - my $arrow; - $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/; + my $arrow = is_subscriptable($array) ? "" : "->"; return $self->deparse($array, 24) . $arrow . $left . $self->deparse($idx, 1) . $right; } @@ -1861,15 +1994,15 @@ sub elem { return "\$" . $array . $left . $idx . $right; } -sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) } -sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) } +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } sub pp_gelem { my $self = shift; my($op, $cx) = @_; my($glob, $part) = ($op->first, $op->last); $glob = $glob->first; # skip rv2gv - $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug + $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug my $scope = is_scope($glob); $glob = $self->deparse($glob, 0); $part = $self->deparse($part, 1); @@ -1889,16 +2022,16 @@ sub slice { } $array = $last; $array = $array->first - if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null"; + if $array->name eq $regname or $array->name eq "null"; if (is_scope($array)) { $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->ppaddr eq $padname) { + } elsif ($array->name eq $padname) { $array = $self->padany($array); } else { $array = $self->deparse($array, 24); } $kid = $op->first->sibling; # skip pushmark - if ($kid->ppaddr eq "pp_list") { + if ($kid->name eq "list") { $kid = $kid->first->sibling; # skip list, pushmark for (; !null $kid; $kid = $kid->sibling) { push @elems, $self->deparse($kid, 6); @@ -1910,10 +2043,8 @@ sub slice { return "\@" . $array . $left . $list . $right; } -sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", - "pp_rv2av", "pp_padav")) } -sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", - "pp_rv2hv", "pp_padhv")) } +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } sub pp_lslice { my $self = shift; @@ -1926,48 +2057,153 @@ sub pp_lslice { return "($list)" . "[$idx]"; } -sub OPpENTERSUB_AMPER () { 8 } - -sub OPf_WANT () { 3 } -sub OPf_WANT_VOID () { 1 } -sub OPf_WANT_SCALAR () { 2 } -sub OPf_WANT_LIST () { 2 } - sub want_scalar { my $op = shift; return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; } -sub pp_entersub { +sub want_list { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_LIST; +} + +sub method { my $self = shift; my($op, $cx) = @_; - my $prefix = ""; - my $amper = ""; - my $proto = undef; - my $simple = 0; - my($kid, $args, @exprs); - if (not null $op->first->sibling) { # method - $kid = $op->first->sibling; # skip pushmark - my $obj = $self->deparse($kid, 24); + my $kid = $op->first->sibling; # skip pushmark + my($meth, $obj, @exprs); + if ($kid->name eq "list" and want_list $kid) { + # When an indirect object isn't a bareword but the args are in + # parens, the parens aren't part of the method syntax (the LLAFR + # doesn't apply), but they make a list with OPf_PARENS set that + # doesn't get flattened by the append_elem that adds the method, + # making a (object, arg1, arg2, ...) list where the object + # usually is. This can be distinguished from + # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an + # object) because in the later the list is in scalar context + # as the left side of -> always is, while in the former + # the list is in list context as method arguments always are. + # (Good thing there aren't method prototypes!) + $meth = $kid->sibling; + $kid = $kid->first->sibling; # skip pushmark + $obj = $kid; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + } else { + $obj = $kid; $kid = $kid->sibling; for (; not null $kid->sibling; $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); } - my $meth = $kid->first; - if ($meth->ppaddr eq "pp_const") { - $meth = $meth->sv->PV; # needs to be bare + $meth = $kid; + } + $obj = $self->deparse($obj, 24); + if ($meth->name eq "method_named") { + $meth = $self->const_sv($meth)->PV; + } else { + $meth = $meth->first; + if ($meth->name eq "const") { + # As of 5.005_58, this case is probably obsoleted by the + # method_named case above + $meth = $self->const_sv($meth)->PV; # needs to be bare } else { $meth = $self->deparse($meth, 1); } - $args = join(", ", @exprs); - $kid = $obj . "->" . $meth; - if ($args) { - return $kid . "(" . $args . ")"; # parens mandatory + } + my $args = join(", ", @exprs); + $kid = $obj . "->" . $meth; + if ($args) { + return $kid . "(" . $args . ")"; # parens mandatory + } else { + return $kid; + } +} + +# returns "&" if the prototype doesn't match the args, +# or ("", $args_after_prototype_demunging) if it does. +sub check_proto { + my $self = shift; + my($proto, @args) = @_; + my($arg, $real); + my $doneok = 0; + my @reals; + # An unbackslashed @ or % gobbles up the rest of the args + $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/; + while ($proto) { + $proto =~ s/^ *([\\]?[\$\@&%*]|;)//; + my $chr = $1; + if ($chr eq "") { + return "&" if @args; + } elsif ($chr eq ";") { + $doneok = 1; + } elsif ($chr eq "@" or $chr eq "%") { + push @reals, map($self->deparse($_, 6), @args); + @args = (); } else { - return $kid; # toke.c fakes parens - } + $arg = shift @args; + last unless $arg; + if ($chr eq "\$") { + if (want_scalar $arg) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "&") { + if ($arg->name =~ /^(s?refgen|undef)$/) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "*") { + if ($arg->name =~ /^s?refgen$/ + and $arg->first->first->name eq "rv2gv") + { + $real = $arg->first->first; # skip refgen, null + if ($real->first->name eq "gv") { + push @reals, $self->deparse($real, 6); + } else { + push @reals, $self->deparse($real->first, 6); + } + } else { + return "&"; + } + } elsif (substr($chr, 0, 1) eq "\\") { + $chr = substr($chr, 1); + if ($arg->name =~ /^s?refgen$/ and + !null($real = $arg->first) and + ($chr eq "\$" && is_scalar($real->first) + or ($chr eq "\@" + && $real->first->sibling->name + =~ /^(rv2|pad)av$/) + or ($chr eq "%" + && $real->first->sibling->name + =~ /^(rv2|pad)hv$/) + #or ($chr eq "&" # This doesn't work + # && $real->first->name eq "rv2cv") + or ($chr eq "*" + && $real->first->name eq "rv2gv"))) + { + push @reals, $self->deparse($real, 6); + } else { + return "&"; + } + } + } } - # else, not a method + return "&" if $proto and !$doneok; # too few args and no `;' + return "&" if @args; # too many args + return ("", join ", ", @reals); +} + +sub pp_entersub { + my $self = shift; + my($op, $cx) = @_; + return $self->method($op, $cx) unless null $op->first->sibling; + my $prefix = ""; + my $amper = ""; + my($kid, @exprs); if ($op->flags & OPf_SPECIAL) { $prefix = "do "; } elsif ($op->private & OPpENTERSUB_AMPER) { @@ -1978,97 +2214,30 @@ sub pp_entersub { for (; not null $kid->sibling; $kid = $kid->sibling) { push @exprs, $kid; } + my $simple = 0; + my $proto = undef; if (is_scope($kid)) { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; - } elsif ($kid->first->ppaddr eq "pp_gv") { - my $gv = $kid->first->gv; + } elsif ($kid->first->name eq "gv") { + my $gv = $self->maybe_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } - $simple = 1; + $simple = 1; # only calls of named functions can be prototyped $kid = $self->deparse($kid, 24); } elsif (is_scalar $kid->first) { $amper = "&"; $kid = $self->deparse($kid, 24); } else { $prefix = ""; - $kid = $self->deparse($kid, 24) . "->"; + my $arrow = is_subscriptable($kid->first) ? "" : "->"; + $kid = $self->deparse($kid, 24) . $arrow; } + my $args; if (defined $proto and not $amper) { - my($arg, $real); - my $doneok = 0; - my @args = @exprs; - my @reals; - my $p = $proto; - $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/; - while ($p) { - $p =~ s/^ *([\\]?[\$\@&%*]|;)//; - my $chr = $1; - if ($chr eq "") { - undef $proto if @args; - } elsif ($chr eq ";") { - $doneok = 1; - } elsif ($chr eq "@" or $chr eq "%") { - push @reals, map($self->deparse($_, 6), @args); - @args = (); - } else { - $arg = shift @args; - last unless $arg; - if ($chr eq "\$") { - if (want_scalar $arg) { - push @reals, $self->deparse($arg, 6); - } else { - undef $proto; - } - } elsif ($chr eq "&") { - if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) { - push @reals, $self->deparse($arg, 6); - } else { - undef $proto; - } - } elsif ($chr eq "*") { - if ($arg->ppaddr =~ /^pp_s?refgen$/ - and $arg->first->first->ppaddr eq "pp_rv2gv") - { - $real = $arg->first->first; # skip refgen, null - if ($real->first->ppaddr eq "pp_gv") { - push @reals, $self->deparse($real, 6); - } else { - push @reals, $self->deparse($real->first, 6); - } - } else { - undef $proto; - } - } elsif (substr($chr, 0, 1) eq "\\") { - $chr = substr($chr, 1); - if ($arg->ppaddr =~ /^pp_s?refgen$/ and - !null($real = $arg->first) and - ($chr eq "\$" && is_scalar($real->first) - or ($chr eq "\@" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)av$/) - or ($chr eq "%" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)hv$/) - #or ($chr eq "&" # This doesn't work - # && $real->first->ppaddr eq "pp_rv2cv") - or ($chr eq "*" - && $real->first->ppaddr eq "pp_rv2gv"))) - { - push @reals, $self->deparse($real, 6); - } else { - undef $proto; - } - } - } - } - undef $proto if $p and !$doneok; - undef $proto if @args; - $args = join(", ", @reals); - $amper = ""; - unless (defined $proto) { - $amper = "&"; + ($amper, $args) = $self->check_proto($proto, @exprs); + if ($amper eq "&") { $args = join(", ", map($self->deparse($_, 6), @exprs)); } } else { @@ -2146,6 +2315,7 @@ sub balanced_delim { } elsif ($c eq $close) { $cnt--; if ($cnt < 0) { + # qq()() isn't ")(" $fail = 1; last; } @@ -2175,14 +2345,10 @@ sub single_delim { } } -sub SVf_IOK () {0x10000} -sub SVf_NOK () {0x20000} -sub SVf_ROK () {0x80000} - sub const { my $sv = shift; if (class($sv) eq "SPECIAL") { - return ('undef', '1', '0')[$$sv-1]; + return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif ($sv->FLAGS & SVf_IOK) { return $sv->IV; } elsif ($sv->FLAGS & SVf_NOK) { @@ -2191,43 +2357,52 @@ sub const { return "\\(" . const($sv->RV) . ")"; # constant folded } else { my $str = $sv->PV; - if ($str =~ /[^ -~]/) { # ASCII + if ($str =~ /[^ -~]/) { # ASCII for non-printing return single_delim("qq", '"', uninterp escape_str unback $str); } else { - $str =~ s/\\/\\\\/g; - return single_delim("q", "'", $str); + return single_delim("q", "'", unback $str); } } } +sub const_sv { + my $self = shift; + my $op = shift; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + sub pp_const { my $self = shift; my($op, $cx) = @_; -# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting -# return $op->sv->PV; +# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting +# return $self->const_sv($op)->PV; # } - return const($op->sv); + my $sv = $self->const_sv($op); + return const($sv); } sub dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { - return uninterp(escape_str(unback($op->sv->PV))); - } elsif ($type eq "pp_concat") { + my $type = $op->name; + if ($type eq "const") { + return uninterp(escape_str(unback($self->const_sv($op)->PV))); + } elsif ($type eq "concat") { return $self->dq($op->first) . $self->dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2243,13 +2418,15 @@ sub pp_backtick { sub dquote { my $self = shift; - my $op = shift; - # skip ex-stringify, pushmark - return single_delim("qq", '"', $self->dq($op->first->sibling)); + my($op, $cx) = shift; + my $kid = $op->first->sibling; # skip ex-stringify, pushmark + return $self->deparse($kid, $cx) if $self->{'unquote'}; + $self->maybe_targmy($kid, $cx, + sub {single_delim("qq", '"', $self->dq($_[1]))}); } -# OP_STRINGIFY is a listop, but it only ever has one arg (?) -sub pp_stringify { dquote(@_) } +# OP_STRINGIFY is a listop, but it only ever has one arg +sub pp_stringify { maybe_targmy(@_, \&dquote) } # tr/// and s/// (and tr[][], tr[]//, tr###, etc) # note that tr(from)/to/ is OK, but not tr/from/(to) @@ -2316,7 +2493,8 @@ sub collapse { if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and $chars[$c + 2] == $tr + 2) { - for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {} + for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) + {} $str .= "-"; $str .= pchr($chars[$c]); } @@ -2324,14 +2502,12 @@ sub collapse { return $str; } -sub OPpTRANS_SQUASH () { 16 } -sub OPpTRANS_DELETE () { 32 } -sub OPpTRANS_COMPLEMENT () { 64 } +# XXX This has trouble with hyphens in the replacement (tr/bac/-AC/), +# and backslashes. -sub pp_trans { - my $self = shift; - my($op, $cx) = @_; - my(@table) = unpack("s256", $op->pv); +sub tr_decode_byte { + my($table, $flags) = @_; + my(@table) = unpack("s256", $table); my($c, $tr, @from, @to, @delfrom, $delhyphen); if ($table[ord "-"] != -1 and $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) @@ -2353,10 +2529,8 @@ sub pp_trans { push @delfrom, $c; } } - my $flags; @from = (@from, @delfrom); - if ($op->private & OPpTRANS_COMPLEMENT) { - $flags .= "c"; + if ($flags & OPpTRANS_COMPLEMENT) { my @newfrom = (); my %from; @from{@from} = (1) x @from; @@ -2365,16 +2539,136 @@ sub pp_trans { } @from = @newfrom; } - if ($op->private & OPpTRANS_DELETE) { - $flags .= "d"; - } else { + unless ($flags & OPpTRANS_DELETE) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } - $flags .= "s" if $op->private & OPpTRANS_SQUASH; my($from, $to); $from = collapse(@from); $to = collapse(@to); $from .= "-" if $delhyphen; + return ($from, $to); +} + +sub tr_chr { + my $x = shift; + if ($x == ord "-") { + return "\\-"; + } else { + return chr $x; + } +} + +# XXX This doesn't yet handle all cases correctly either + +sub tr_decode_utf8 { + my($swash_hv, $flags) = @_; + my %swash = $swash_hv->ARRAY; + my $final = undef; + $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; + my $none = $swash{"NONE"}->IV; + my $extra = $none + 1; + my(@from, @delfrom, @to); + my $line; + foreach $line (split /\n/, $swash{'LIST'}->PV) { + my($min, $max, $result) = split(/\t/, $line); + $min = hex $min; + if (length $max) { + $max = hex $max; + } else { + $max = $min; + } + $result = hex $result; + if ($result == $extra) { + push @delfrom, [$min, $max]; + } else { + push @from, [$min, $max]; + push @to, [$result, $result + $max - $min]; + } + } + for my $i (0 .. $#from) { + if ($from[$i][0] == ord '-') { + unshift @from, splice(@from, $i, 1); + unshift @to, splice(@to, $i, 1); + last; + } elsif ($from[$i][1] == ord '-') { + $from[$i][1]--; + $to[$i][1]--; + unshift @from, ord '-'; + unshift @to, ord '-'; + last; + } + } + for my $i (0 .. $#delfrom) { + if ($delfrom[$i][0] == ord '-') { + push @delfrom, splice(@delfrom, $i, 1); + last; + } elsif ($delfrom[$i][1] == ord '-') { + $delfrom[$i][1]--; + push @delfrom, ord '-'; + last; + } + } + if (defined $final and $to[$#to][1] != $final) { + push @to, [$final, $final]; + } + push @from, @delfrom; + if ($flags & OPpTRANS_COMPLEMENT) { + my @newfrom; + my $next = 0; + for my $i (0 .. $#from) { + push @newfrom, [$next, $from[$i][0] - 1]; + $next = $from[$i][1] + 1; + } + @from = (); + for my $range (@newfrom) { + if ($range->[0] <= $range->[1]) { + push @from, $range; + } + } + } + my($from, $to, $diff); + for my $chunk (@from) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $from .= tr_chr($chunk->[0]); + } + } + for my $chunk (@to) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $to .= tr_chr($chunk->[0]); + } + } + #$final = sprintf("%04x", $final) if defined $final; + #$none = sprintf("%04x", $none) if defined $none; + #$extra = sprintf("%04x", $extra) if defined $extra; + #print STDERR "final: $final\n none: $none\nextra: $extra\n"; + #print STDERR $swash{'LIST'}->PV; + return (escape_str($from), escape_str($to)); +} + +sub pp_trans { + my $self = shift; + my($op, $cx) = @_; + my($from, $to); + if (class($op) eq "PVOP") { + ($from, $to) = tr_decode_byte($op->pv, $op->private); + } else { # class($op) eq "SVOP" + ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); + } + my $flags = ""; + $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; + $flags .= "d" if $op->private & OPpTRANS_DELETE; + $to = "" if $from eq $to and $flags eq ""; + $flags .= "s" if $op->private & OPpTRANS_SQUASH; return "tr" . double_delim($from, $to) . $flags; } @@ -2382,22 +2676,22 @@ sub pp_trans { sub re_dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { - return uninterp($op->sv->PV); - } elsif ($type eq "pp_concat") { + my $type = $op->name; + if ($type eq "const") { + return uninterp($self->const_sv($op)->PV); + } elsif ($type eq "concat") { return $self->re_dq($op->first) . $self->re_dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2408,26 +2702,11 @@ sub pp_regcomp { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe"; - $kid = $kid->first if $kid->ppaddr eq "pp_regcreset"; + $kid = $kid->first if $kid->name eq "regcmaybe"; + $kid = $kid->first if $kid->name eq "regcreset"; return $self->re_dq($kid); } -sub OPp_RUNTIME () { 64 } - -sub PMf_ONCE () { 0x2 } -sub PMf_SKIPWHITE () { 0x10 } -sub PMf_CONST () { 0x40 } -sub PMf_KEEP () { 0x80 } -sub PMf_GLOBAL () { 0x100 } -sub PMf_CONTINUE () { 0x200 } -sub PMf_EVAL () { 0x400 } -sub PMf_LOCALE () { 0x800 } -sub PMf_MULTILINE () { 0x1000 } -sub PMf_SINGLELINE () { 0x2000 } -sub PMf_FOLD () { 0x4000 } -sub PMf_EXTENDED () { 0x8000 } - # osmic acid -- see osmium tetroxide my %matchwords; @@ -2522,11 +2801,15 @@ sub pp_subst { $kid = $kid->sibling; } else { $repl = $op->pmreplroot->first; # skip substcont - while ($repl->ppaddr eq "pp_entereval") { + while ($repl->name eq "entereval") { $repl = $repl->first; $flags .= "e"; } - $repl = $self->dq($repl); + if ($op->pmflags & PMf_EVAL) { + $repl = $self->deparse($repl, 0); + } else { + $repl = $self->dq($repl); + } } if (null $kid) { $re = re_uninterp(escape_str($op->precomp)); @@ -2559,7 +2842,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl> +B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>] + I<prog.pl> =head1 DESCRIPTION @@ -2584,6 +2868,11 @@ the '-MO=Deparse', separated by a comma but not any white space. =over 4 +=item B<-l> + +Add '#line' declarations to the output based on the line and file +locations of the original code. + =item B<-p> Print extra parentheses. Without this option, B::Deparse includes @@ -2607,29 +2896,44 @@ C<B::Deparse,-p> will print which probably isn't what you intended (the C<'???'> is a sign that perl optimized away a constant value). +=item B<-q> + +Expand double-quoted strings into the corresponding combinations of +concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For +instance, print + + print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; + +as + + print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' + . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); + +Note that the expanded form represents the way perl handles such +constructions internally -- this option actually turns off the reverse +translation that B::Deparse usually does. On the other hand, note that +C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value +of $y into a string before doing the assignment. + =item B<-u>I<PACKAGE> Normally, B::Deparse deparses the main code of a program, all the subs called by the main program (and all the subs called by them, recursively), and any other subs in the main:: package. To include subs in other packages that aren't called directly, such as AUTOLOAD, -DESTROY, other subs called automatically by perl, and methods, which -aren't resolved to subs until runtime, use the B<-u> option. The +DESTROY, other subs called automatically by perl, and methods (which +aren't resolved to subs until runtime), use the B<-u> option. The argument to B<-u> is the name of a package, and should follow directly after the 'u'. Multiple B<-u> options may be given, separated by commas. Note that unlike some other backends, B::Deparse doesn't (yet) try to guess automatically when B<-u> is needed -- you must invoke it yourself. -=item B<-l> - -Add '#line' declarations to the output based on the line and file -locations of the original code. - =item B<-s>I<LETTERS> -Tweak the style of B::Deparse's output. At the moment, only one style -option is implemented: +Tweak the style of B::Deparse's output. The letters should follow +directly after the 's', with no space or punctuation. The following +options are available: =over 4 @@ -2654,17 +2958,85 @@ instead of The default is not to cuddle. +=item B<i>I<NUMBER> + +Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. + +=item B<T> + +Use tabs for each 8 columns of indent. The default is to use only spaces. +For instance, if the style options are B<-si4T>, a line that's indented +3 times will be preceded by one tab and four spaces; if the options were +B<-si8T>, the same line would be preceded by three tabs. + +=item B<v>I<STRING>B<.> + +Print I<STRING> for the value of a constant that can't be determined +because it was optimized away (mnemonic: this happens when a constant +is used in B<v>oid context). The end of the string is marked by a period. +The string should be a valid perl expression, generally a constant. +Note that unless it's a number, it probably needs to be quoted, and on +a command line quotes need to be protected from the shell. Some +conventional values include 0, 1, 42, '', 'foo', and +'Useless use of constant omitted' (which may need to be +B<-sv"'Useless use of constant omitted'."> +or something similar depending on your shell). The default is '???'. +If you're using B::Deparse on a module or other file that's require'd, +you shouldn't use a value that evaluates to false, since the customary +true constant at the end of a module will be in void context when the +file is compiled as a main program. + =back =back +=head1 USING B::Deparse AS A MODULE + +=head2 Synopsis + + use B::Deparse; + $deparse = B::Deparse->new("-p", "-sC"); + $body = $deparse->coderef2text(\&func); + eval "sub func $body"; # the inverse operation + +=head2 Description + +B::Deparse can also be used on a sub-by-sub basis from other perl +programs. + +=head2 new + + $deparse = B::Deparse->new(OPTIONS) + +Create an object to store the state of a deparsing operation and any +options. The options are the same as those that can be given on the +command line (see L</OPTIONS>); options that are separated by commas +after B<-MO=Deparse> should be given as separate strings. Some +options, like B<-u>, don't make sense for a single subroutine, so +don't pass them. + +=head2 coderef2text + + $body = $deparse->coderef2text(\&func) + $body = $deparse->coderef2text(sub ($$) { ... }) + +Return source code for the body of a subroutine (a block, optionally +preceded by a prototype in parens), given a reference to the +sub. Because a subroutine can have no names, or more than one name, +this method doesn't return a complete subroutine definition -- if you +want to eval the result, you should prepend "sub subname ", or "sub " +for an anonymous function constructor. Unless the sub was defined in +the main:: package, the code will include a package declaration. + =head1 BUGS See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant <alias@mcs.com>, based on an earlier version by -Malcolm Beattie <mbeattie@sable.ox.ac.uk>. +Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier +version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with +contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van +der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. =cut diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index 4a008a3..d054a2d 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -52,6 +52,20 @@ sub GET_objindex { return unpack("N", $str); } +sub GET_opindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading opindex" unless length($str) == 4; + return unpack("N", $str); +} + +sub GET_svindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading svindex" unless length($str) == 4; + return unpack("N", $str); +} + sub GET_strconst { my $fh = shift; my ($str, $c); diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm index d34bd77..ed0d07d 100644 --- a/contrib/perl5/ext/B/B/Lint.pm +++ b/contrib/perl5/ext/B/B/Lint.pm @@ -116,13 +116,9 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents); - -# Constants (should probably be elsewhere) -sub G_ARRAY () { 1 } -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_STACKED () { 64 } +use B qw(walkoptree_slow main_root walksymtable svref_2object parents + OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY + ); my $file = "unknown"; # shadows current filename my $line = 0; # shadows current line number @@ -133,8 +129,8 @@ my %check; my %implies_ok_context; BEGIN { map($implies_ok_context{$_}++, - qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice - pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete)); + qw(scalar av2arylen aelem aslice helem hslice + keys values hslice defined undef delete)); } # Lint checks turned on by default @@ -165,8 +161,8 @@ sub warning { sub gimme { my $op = shift; my $flags = $op->flags; - if ($flags & OPf_KNOW) { - return(($flags & OPf_LIST) ? 1 : 0); + if ($flags & OPf_WANT) { + return(($flags & OPf_WANT_LIST) ? 1 : 0); } return undef; } @@ -175,8 +171,8 @@ sub B::OP::lint {} sub B::COP::lint { my $op = shift; - if ($op->ppaddr eq "pp_nextstate") { - $file = $op->filegv->SV->PV; + if ($op->name eq "nextstate") { + $file = $op->file; $line = $op->line; $curstash = $op->stash->NAME; } @@ -184,24 +180,24 @@ sub B::COP::lint { sub B::UNOP::lint { my $op = shift; - my $ppaddr = $op->ppaddr; - if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) { + my $opname = $op->name; + if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { my $parent = parents->[0]; - my $pname = $parent->ppaddr; + my $pname = $parent->name; return if gimme($op) || $implies_ok_context{$pname}; # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" # null out the parent so we have to check for a parent of pp_null and # a grandparent of pp_enteriter or pp_delete - if ($pname eq "pp_null") { - my $gpname = parents->[1]->ppaddr; - return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete"; + if ($pname eq "null") { + my $gpname = parents->[1]->name; + return if $gpname eq "enteriter" || $gpname eq "delete"; } warning("Implicit scalar context for %s in %s", - $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc); + $opname eq "rv2av" ? "array" : "hash", $parent->desc); } - if ($check{private_names} && $ppaddr eq "pp_method") { + if ($check{private_names} && $opname eq "method") { my $methop = $op->first; - if ($methop->ppaddr eq "pp_const") { + if ($methop->name eq "const") { my $method = $methop->sv->PV; if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { warning("Illegal reference to private method name $method"); @@ -213,14 +209,12 @@ sub B::UNOP::lint { sub B::PMOP::lint { my $op = shift; if ($check{implicit_read}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { warning('Implicit match on $_'); } } if ($check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { warning('Implicit substitution on $_'); } } @@ -229,34 +223,35 @@ sub B::PMOP::lint { sub B::LOOP::lint { my $op = shift; if ($check{implicit_read} || $check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_enteriter") { + if ($op->name eq "enteriter") { my $last = $op->last; - if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") { + if ($last->name eq "gv" && $last->gv->NAME eq "_") { warning('Implicit use of $_ in foreach'); } } } } -sub B::GVOP::lint { +sub B::SVOP::lint { my $op = shift; - if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv" + if ($check{dollar_underscore} && $op->name eq "gvsv" && $op->gv->NAME eq "_") { warning('Use of $_'); } if ($check{private_names}) { - my $ppaddr = $op->ppaddr; - my $gv = $op->gv; - if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv") - && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) - { - warning('Illegal reference to private name %s', $gv->NAME); + my $opname = $op->name; + if ($opname eq "gv" || $opname eq "gvsv") { + my $gv = $op->gv; + if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { + warning('Illegal reference to private name %s', $gv->NAME); + } } } if ($check{undefined_subs}) { - if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") { + if ($op->name eq "gv" + && $op->next->name eq "entersub") + { my $gv = $op->gv; my $subname = $gv->STASH->NAME . "::" . $gv->NAME; no strict 'refs'; @@ -266,7 +261,7 @@ sub B::GVOP::lint { } } } - if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") { + if ($check{regexp_variables} && $op->name eq "gvsv") { my $name = $op->gv->NAME; if ($name =~ /^[&'`]$/) { warning('Use of regexp variable $%s', $name); diff --git a/contrib/perl5/ext/B/B/Stackobj.pm b/contrib/perl5/ext/B/B/Stackobj.pm index eea966c..0db3e33 100644 --- a/contrib/perl5/ext/B/B/Stackobj.pm +++ b/contrib/perl5/ext/B/B/Stackobj.pm @@ -5,34 +5,35 @@ # 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::Stackobj; +package B::Stackobj; use Exporter (); @ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT +@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - REGISTER TEMPORARY)]); + VALID_UNSIGNED REGISTER TEMPORARY)]); use Carp qw(confess); use strict; -use B qw(class); - -# Perl internal constants that I should probably define elsewhere. -sub SVf_IOK () { 0x10000 } -sub SVf_NOK () { 0x20000 } +use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); # Types sub T_UNKNOWN () { 0 } sub T_DOUBLE () { 1 } sub T_INT () { 2 } +sub T_SPECIAL () { 3 } # Flags sub VALID_INT () { 0x01 } -sub VALID_DOUBLE () { 0x02 } -sub VALID_SV () { 0x04 } -sub REGISTER () { 0x08 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x10 } # no implicit write-back needed at all +sub VALID_UNSIGNED () { 0x02 } +sub VALID_DOUBLE () { 0x04 } +sub VALID_SV () { 0x08 } +sub REGISTER () { 0x10 } # no implicit write-back when calling subs +sub TEMPORARY () { 0x20 } # no implicit write-back needed at all +sub SAVE_INT () { 0x40 } #if int part needs to be saved at all +sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all + # # Callback for runtime code generation @@ -47,7 +48,7 @@ sub runtime { &$runtime_callback(@_) } sub write_back { confess "stack object does not implement write_back" } -sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) } +sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } sub as_sv { my $obj = shift; @@ -62,7 +63,7 @@ sub as_int { my $obj = shift; if (!($obj->{flags} & VALID_INT)) { $obj->load_int; - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; } return $obj->{iv}; } @@ -71,7 +72,7 @@ sub as_double { my $obj = shift; if (!($obj->{flags} & VALID_DOUBLE)) { $obj->load_double; - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; } return $obj->{nv}; } @@ -81,6 +82,17 @@ sub as_numeric { return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; } +sub as_bool { + my $obj=shift; + if ($obj->{flags} & VALID_INT ){ + return $obj->{iv}; + } + if ($obj->{flags} & VALID_DOUBLE ){ + return $obj->{nv}; + } + return sprintf("(SvTRUE(%s))", $obj->as_sv) ; +} + # # Debugging methods # @@ -126,17 +138,18 @@ sub minipeek { # set_numeric and set_sv are only invoked on legal lvalues. # sub set_int { - my ($obj, $expr) = @_; + my ($obj, $expr,$unsigned) = @_; runtime("$obj->{iv} = $expr;"); $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; + $obj->{flags} |= VALID_UNSIGNED if $unsigned; } sub set_double { my ($obj, $expr) = @_; runtime("$obj->{nv} = $expr;"); $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; } sub set_numeric { @@ -162,6 +175,8 @@ sub set_sv { @B::Stackobj::Padsv::ISA = 'B::Stackobj'; sub B::Stackobj::Padsv::new { my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; + $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; + $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; bless { type => $type, flags => VALID_SV | $extra_flags, @@ -178,14 +193,23 @@ sub B::Stackobj::Padsv::load_int { } else { runtime("$obj->{iv} = SvIV($obj->{sv});"); } - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; } sub B::Stackobj::Padsv::load_double { my $obj = shift; $obj->write_back; runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; +} +sub B::Stackobj::Padsv::save_int { + my $obj = shift; + return $obj->{flags} & SAVE_INT; +} + +sub B::Stackobj::Padsv::save_double { + my $obj = shift; + return $obj->{flags} & SAVE_DOUBLE; } sub B::Stackobj::Padsv::write_back { @@ -193,7 +217,11 @@ sub B::Stackobj::Padsv::write_back { my $flags = $obj->{flags}; return if $flags & VALID_SV; if ($flags & VALID_INT) { - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + if ($flags & VALID_UNSIGNED ){ + runtime("sv_setuv($obj->{sv}, $obj->{iv});"); + }else{ + runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + } } elsif ($flags & VALID_DOUBLE) { runtime("sv_setnv($obj->{sv}, $obj->{nv});"); } else { @@ -213,17 +241,26 @@ sub B::Stackobj::Const::new { flags => 0, sv => $sv # holds the SV object until write_back happens }, $class; - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - $obj->{nv} = $obj->{iv} = $sv->IV; - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; + if ( ref($sv) eq "B::SPECIAL" ){ + $obj->{type}= T_SPECIAL; + }else{ + my $svflags = $sv->FLAGS; + if ($svflags & SVf_IOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_INT; + if ($svflags & SVf_IVisUV){ + $obj->{flags} |= VALID_UNSIGNED; + $obj->{nv} = $obj->{iv} = $sv->UVX; + }else{ + $obj->{nv} = $obj->{iv} = $sv->IV; + } + } elsif ($svflags & SVf_NOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_DOUBLE; + $obj->{iv} = $obj->{nv} = $sv->NV; + } else { + $obj->{type} = T_UNKNOWN; + } } return $obj; } @@ -238,13 +275,21 @@ sub B::Stackobj::Const::write_back { sub B::Stackobj::Const::load_int { my $obj = shift; - $obj->{iv} = int($obj->{sv}->PV); + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{iv} = int($obj->{sv}->RV->PV); + }else{ + $obj->{iv} = int($obj->{sv}->PV); + } $obj->{flags} |= VALID_INT; } sub B::Stackobj::Const::load_double { my $obj = shift; - $obj->{nv} = $obj->{sv}->PV + 0.0; + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{nv} = $obj->{sv}->RV->PV + 0.0; + }else{ + $obj->{nv} = $obj->{sv}->PV + 0.0; + } $obj->{flags} |= VALID_DOUBLE; } diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm new file mode 100644 index 0000000..0a3543e --- /dev/null +++ b/contrib/perl5/ext/B/B/Stash.pm @@ -0,0 +1,42 @@ +# Stash.pm -- show what stashes are loaded +# vishalb@hotmail.com +package B::Stash; + +BEGIN { %Seen = %INC } + +CHECK { + my @arr=scan($main::{"main::"}); + @arr=map{s/\:\:$//;$_;} @arr; + print "-umain,-u", join (",-u",@arr) ,"\n"; +} +sub scan{ + my $start=shift; + my $prefix=shift; + $prefix = '' unless defined $prefix; + my @return; + foreach my $key ( keys %{$start}){ +# print $prefix,$key,"\n"; + if ($key =~ /::$/){ + unless ($start eq ${$start}{$key} or $key eq "B::" ){ + push @return, $key unless omit($prefix.$key); + foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ + push @return, "$key".$subscan; + } + } + } + } + return @return; +} +sub omit{ + my $module = shift; + my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , + "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); + return 1 if $omit{$module}; + if ($module eq "IO::" or $module eq "IO::Handle::"){ + $module =~ s/::/\//g; + return 1 unless $INC{$module}; + } + + return 0; +} +1; diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm index 93757f3..66b5cfc 100644 --- a/contrib/perl5/ext/B/B/Terse.pm +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -17,6 +17,7 @@ sub terse { sub compile { my $order = shift; my @options = @_; + B::clearsym(); if (@options) { return sub { my $objname; @@ -53,10 +54,9 @@ sub B::SVOP::terse { $op->sv->terse(0); } -sub B::GVOP::terse { +sub B::PADOP::terse { my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->gv->terse(0); + print indent($level), peekop($op), " ", $op->padix, "\n"; } sub B::PMOP::terse { @@ -78,7 +78,7 @@ sub B::COP::terse { if ($label) { $label = " label ".cstring($label); } - print indent($level), peekop($op), $label, "\n"; + print indent($level), peekop($op), $label || "", "\n"; } sub B::PV::terse { diff --git a/contrib/perl5/ext/B/B/Xref.pm b/contrib/perl5/ext/B/B/Xref.pm index 0102856..b4078b8 100644 --- a/contrib/perl5/ext/B/B/Xref.pm +++ b/contrib/perl5/ext/B/B/Xref.pm @@ -85,11 +85,10 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(peekop class comppadlist main_start svref_2object walksymtable); - -# Constants (should probably be elsewhere) -sub OPpLVAL_INTRO () { 128 } -sub SVf_POK () { 0x40000 } +use Config; +use B qw(peekop class comppadlist main_start svref_2object walksymtable + OPpLVAL_INTRO SVf_POK + ); sub UNKNOWN { ["?", "?", "?"] } @@ -135,17 +134,28 @@ sub process { sub load_pad { my $padlist = shift; - my ($namelistav, @namelist, $ix); + my ($namelistav, $vallistav, @namelist, $ix); @pad = (); return if class($padlist) eq "SPECIAL"; - ($namelistav) = $padlist->ARRAY; + ($namelistav,$vallistav) = $padlist->ARRAY; @namelist = $namelistav->ARRAY; for ($ix = 1; $ix < @namelist; $ix++) { my $namesv = $namelist[$ix]; next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; + my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; $pad[$ix] = ["(lexical)", $type, $name]; } + if ($Config{useithreads}) { + my (@vallist); + @vallist = $vallistav->ARRAY; + for ($ix = 1; $ix < @vallist; $ix++) { + my $valsv = $vallist[$ix]; + next unless class($valsv) eq "GV"; + # these pad GVs don't have corresponding names, so same @pad + # array can be used without collisions + $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; + } + } } sub xref { @@ -155,28 +165,24 @@ sub xref { last if $done{$$op}++; warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; warn peekop($op), "\n" if $debug_op; - my $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { + my $opname = $op->name; + if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { xref($op->other); - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($opname eq "match" || $opname eq "subst") { xref($op->pmreplstart); - } elsif ($ppname eq "pp_substcont") { + } elsif ($opname eq "substcont") { xref($op->other->pmreplstart); $op = $op->other; redo; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - xref($op->true); - $op = $op->false; - redo; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($opname eq "enterloop") { xref($op->redoop); xref($op->nextop); xref($op->lastop); - } elsif ($ppname eq "pp_subst") { + } elsif ($opname eq "subst") { xref($op->pmreplstart); } else { no strict 'refs'; + my $ppname = "pp_$opname"; &$ppname($op) if defined(&$ppname); } } @@ -207,7 +213,7 @@ sub xref_main { sub pp_nextstate { my $op = shift; - $file = $op->filegv->SV->PV; + $file = $op->file; $line = $op->line; $top = UNKNOWN; } @@ -235,23 +241,45 @@ sub pp_rv2gv { deref($top, "*"); } sub pp_gvsv { my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->NAME]; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '$'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, '$', $gv->NAME]; + } process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_gv { my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->NAME]; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '*'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, "*", $gv->NAME]; + } process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_const { my $op = shift; my $sv = $op->sv; - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + # constant could be in the pad (under useithreads) + if ($$sv) { + $top = ["?", "", + (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + } + else { + $top = $pad[$op->targ]; + } } sub pp_method { @@ -278,7 +306,7 @@ sub B::GV::xref { my $cv = $gv->CV; if ($$cv) { #return if $done{$$cv}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); push(@todo, $cv); @@ -286,7 +314,7 @@ sub B::GV::xref { my $form = $gv->FORM; if ($$form) { return if $done{$$form}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); } @@ -296,7 +324,7 @@ sub xref_definitions { my ($pack, %exclude); return if $nodefs; $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars FileHandle Exporter Carp)) { $exclude{$pack."::"} = 1; } diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index 80e5e1b..cb9696b 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -16,31 +16,21 @@ if ($^O eq 'MSWin32') { WriteMakefile( NAME => "B", VERSION => "a5", - MAN3PODS => {}, + PL_FILES => { 'defsubs_h.PL' => 'defsubs.h' }, + MAN3PODS => {}, clean => { - FILES => "perl$e byteperl$e *$o B.c *~" + FILES => "perl$e *$o B.c defsubs.h *~" } -); +); -sub MY::post_constants { - "\nLIBS = $Config{libs}\n" -} +package MY; -# Leave out doing byteperl for now. Probably should be built in the -# core directory or somewhere else rather than here -#sub MY::top_targets { -# my $self = shift; -# my $targets = $self->MM::top_targets(); -# $targets =~ s/^(all ::.*)$/$1 byteperl$e/m; -# return <<"EOT" . $targets; +sub post_constants { + "\nLIBS = $Config::Config{libs}\n" +} -# -# byteperl is *not* a standard perl+XSUB executable. It's a special -# program for running standalone bytecode executables. It isn't an XSUB -# at the moment because a standlone Perl program needs to set up curpad -# which is overwritten on exit from an XSUB. -# -#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o -# \$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS) -#EOT -#} +sub postamble { +' +B$(OBJ_EXT) : defsubs.h +' +} diff --git a/contrib/perl5/ext/B/NOTES b/contrib/perl5/ext/B/NOTES index ee10ba0..89d03ba 100644 --- a/contrib/perl5/ext/B/NOTES +++ b/contrib/perl5/ext/B/NOTES @@ -161,8 +161,8 @@ O module it should return a sub ref (usually a closure) to perform the actual compilation. When O regains control, it ensures that the "-c" option is forced (so that the program being compiled doesn't - end up running) and registers an END block to call back the sub ref + end up running) and registers a CHECK block to call back the sub ref returned from the backend's compile(). Perl then continues by parsing prog.pl (just as it would with "perl -c prog.pl") and after - doing so, assuming there are no parse-time errors, the END block + doing so, assuming there are no parse-time errors, the CHECK block of O gets called and the actual backend compilation happens. Phew. diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm index ad391a3..352f8d4 100644 --- a/contrib/perl5/ext/B/O.pm +++ b/contrib/perl5/ext/B/O.pm @@ -11,7 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; - eval 'END { &$compilesub() }'; + eval 'CHECK { &$compilesub() }'; } else { die $compilesub; } @@ -59,7 +59,7 @@ C<B::Backend> module and calls the C<compile> function in that package, passing it OPTIONS. That function is expected to return a sub reference which we'll call CALLBACK. Next, the "compile-only" flag is switched on (equivalent to the command-line option C<-c>) -and an END block is registered which calls CALLBACK. Thus the main +and a CHECK block is registered which calls CALLBACK. Thus the main Perl program mentioned on the command-line is read in, parsed and compiled into internal syntax tree form. Since the C<-c> flag is set, the program does not start running (excepting BEGIN blocks of diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL new file mode 100644 index 0000000..80ef936 --- /dev/null +++ b/contrib/perl5/ext/B/defsubs_h.PL @@ -0,0 +1,35 @@ +# Do not remove the following line; MakeMaker relies on it to identify +# this file as a template for defsubs.h +# Extracting defsubs.h (with variable substitutions) +#!perl +my ($out) = __FILE__ =~ /(^.*)\.PL/i; +$out =~ s/_h$/.h/; +open(OUT,">$out") || die "Cannot open $file:$!"; +print "Extracting $out...\n"; +foreach my $const (qw(AVf_REAL + HEf_SVKEY + SVf_IOK SVf_IVisUV SVf_NOK SVf_POK + SVf_ROK SVp_IOK SVp_POK )) + { + doconst($const); + } +foreach my $file (qw(op.h cop.h)) + { + open(OPH,"../../$file") || die "Cannot open ../../$file:$!"; + while (<OPH>) + { + doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); + } + close(OPH); + } +close(OUT); + +sub doconst +{ + my $sym = shift; + my $l = length($sym); + print OUT <<"END"; + newCONSTSUB(stash,"$sym",newSViv($sym)); + av_push(export_ok,newSVpvn("$sym",$l)); +END +} diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop index 183d541..e0cb8ff 100644 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -1,21 +1,24 @@ PP(pp_range) { if (GIMME == G_ARRAY) - return cCONDOP->op_true; - return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; + return NORMAL; + if (SvTRUEx(PAD_SV(PL_op->op_targ))) + return cLOGOP->op_other; + else + return NORMAL; } -pp_range is a CONDOP. -In array context, it just returns op_true. +pp_range is a LOGOP. +In array context, it just returns op_next. In scalar context it checks the truth of targ and returns -op_false if true, op_true if false. +op_other if true, op_next if false. flip is an UNOP. -It "looks after" its child which is always a pp_range CONDOP. -In array context, it just returns the child's op_false. +It "looks after" its child which is always a pp_range LOGOP. +In array context, it just returns the child's op_other. In scalar context, there are three possible outcomes: (1) set child's targ to 1, our targ to 1 and return op_next. - (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false. + (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other. (3) Blank targ and TOPs and return op_next. Case 1 happens for a "..." with a matching lineno... or true TOPs. Case 2 happens for a ".." with a matching lineno... or true TOPs. @@ -37,14 +40,14 @@ Case 3 happens for a non-matching lineno or false TOPs. /* range */ if (SvTRUE(curpad[op->op_targ])) - goto label(op_false); -/* op_true */ + goto label(op_other); +/* op_next */ ... /* flip */ -/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */ +/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */ /* end of basic block */ goto out; -label(range op_false): +label(range op_other): ... /* flop */ out: diff --git a/contrib/perl5/ext/B/ramblings/runtime.porting b/contrib/perl5/ext/B/ramblings/runtime.porting index 4699b25..d58b011 100644 --- a/contrib/perl5/ext/B/ramblings/runtime.porting +++ b/contrib/perl5/ext/B/ramblings/runtime.porting @@ -33,8 +33,10 @@ glob 5 2 do_readline readline 8 2 do_readline rcatline 8 2 regcmaybe 8 1 +regcreset 8 1 regcomp 8 9 pregcomp match 8 10 +qr 8 1 subst 8 10 substcont 8 7 trans 7 4 do_trans @@ -170,6 +172,7 @@ orassign 7 3 modifies flow of control method 8 5 entersub 10 7 leavesub 10 5 +leavesublv caller 2 8 warn 9 3 die 9 3 @@ -212,6 +215,7 @@ leavewrite 4 5 prtf 4 4 do_sprintf print 8 6 sysopen 8 2 +sysseek 8 2 sysread 8 4 syswrite 8 4 pp_send send 8 4 @@ -347,4 +351,7 @@ sgrent egrent getlogin syscall -
\ No newline at end of file +lock 6 1 +threadsv 6 2 unused if not USE_THREADS +setstate 1 1 currently unused anywhere +method_named 10 2 diff --git a/contrib/perl5/ext/B/typemap b/contrib/perl5/ext/B/typemap index 7206a6a..bafba1c 100644 --- a/contrib/perl5/ext/B/typemap +++ b/contrib/perl5/ext/B/typemap @@ -4,11 +4,10 @@ B::OP T_OP_OBJ B::UNOP T_OP_OBJ B::BINOP T_OP_OBJ B::LOGOP T_OP_OBJ -B::CONDOP T_OP_OBJ B::LISTOP T_OP_OBJ B::PMOP T_OP_OBJ B::SVOP T_OP_OBJ -B::GVOP T_OP_OBJ +B::PADOP T_OP_OBJ B::PVOP T_OP_OBJ B::CVOP T_OP_OBJ B::LOOP T_OP_OBJ @@ -31,12 +30,13 @@ B::IO T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV STRLEN T_IV +PADOFFSET T_UV INPUT T_OP_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") @@ -44,7 +44,7 @@ T_OP_OBJ T_SV_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") @@ -52,18 +52,18 @@ T_SV_OBJ T_MG_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") OUTPUT T_OP_OBJ - sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var); + sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); T_SV_OBJ - make_sv_object(($arg), (SV*)($var)); + make_sv_object(aTHX_ ($arg), (SV*)($var)); T_MG_OBJ - sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var); + sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); |
