diff options
52 files changed, 1086 insertions, 1645 deletions
diff --git a/bytecode.pl b/bytecode.pl index 93216048a3..d1e1c708c0 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -13,7 +13,7 @@ my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). -my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); +my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); my (%alias_from, $from, $tos); while (($from, $tos) = each %alias_to) { @@ -82,7 +82,7 @@ print BYTERUN_C $c_header, <<'EOT'; #include "bytecode.h" -static const int optype_size[] = { +static int optype_size[] = { EOT my $i = 0; for ($i = 0; $i < @optype - 1; $i++) { @@ -92,28 +92,33 @@ printf BYTERUN_C " sizeof(%s)\n", $optype[$i], $i; print BYTERUN_C <<'EOT'; }; +static SV *specialsv_list[4]; + +static int bytecode_iv_overflows = 0; +static SV *bytecode_sv; +static XPV bytecode_pv; +static void **bytecode_obj_list; +static I32 bytecode_obj_list_fill = -1; + void * -bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) +bset_obj_store(pTHXo_ void *obj, I32 ix) { - if (ix > bstate->bs_obj_list_fill) { - Renew(bstate->bs_obj_list, ix + 32, void*); - bstate->bs_obj_list_fill = ix + 31; + if (ix > bytecode_obj_list_fill) { + if (bytecode_obj_list_fill == -1) + New(666, bytecode_obj_list, ix + 1, void*); + else + Renew(bytecode_obj_list, ix + 1, void*); + bytecode_obj_list_fill = ix; } - bstate->bs_obj_list[ix] = obj; + bytecode_obj_list[ix] = obj; return obj; } void -byterun(pTHXo_ register struct byteloader_state *bstate) +byterun(pTHXo_ struct bytestream bs) { dTHR; - register int insn; - U32 ix; - SV *specialsv_list[6]; - - BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ - New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ - bstate->bs_obj_list_fill = 31; + int insn; EOT @@ -193,25 +198,13 @@ EOT # open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!"; print BYTERUN_H $c_header, <<'EOT'; -struct byteloader_fdata { - SV *datasv; - int next_out; - int idx; +struct bytestream { + void *data; + int (*pfgetc)(void *); + int (*pfread)(char *, size_t, size_t, void *); + void (*pfreadpv)(U32, void *, XPV *); }; -struct byteloader_state { - struct byteloader_fdata *bs_fdata; - SV *bs_sv; - void **bs_obj_list; - int bs_obj_list_fill; - XPV bs_pv; - int bs_iv_overflows; -}; - -int bl_getc(struct byteloader_fdata *); -int bl_read(struct byteloader_fdata *, char *, size_t, size_t); -extern void byterun(pTHXo_ struct byteloader_state *); - enum { EOT @@ -240,6 +233,18 @@ for ($i = 0; $i < @optype - 1; $i++) { } printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i; +print BYTERUN_H <<'EOT'; +extern void byterun(pTHXo_ struct bytestream bs); + +#define INIT_SPECIALSV_LIST STMT_START { \ +EOT +for ($i = 0; $i < @specialsv; $i++) { + print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n"; +} +print BYTERUN_H <<'EOT'; + } STMT_END +EOT + # # Finish off insn_data and create array initialisers in Asmdata.pm # @@ -289,86 +294,85 @@ nop none none #opcode lvalue argtype flags # ret none none x -ldsv bstate->bs_sv svindex +ldsv bytecode_sv svindex ldop PL_op opindex -stsv bstate->bs_sv U32 s +stsv bytecode_sv U32 s stop PL_op U32 s -stpv bstate->bs_pv.xpv_pv U32 x -ldspecsv bstate->bs_sv U8 x -newsv bstate->bs_sv U8 x +ldspecsv bytecode_sv U8 x +newsv bytecode_sv U8 x newop PL_op U8 x newopn PL_op U8 x newpv none PV -pv_cur bstate->bs_pv.xpv_cur STRLEN -pv_free bstate->bs_pv none x -sv_upgrade bstate->bs_sv char x -sv_refcnt SvREFCNT(bstate->bs_sv) U32 -sv_refcnt_add SvREFCNT(bstate->bs_sv) I32 x -sv_flags SvFLAGS(bstate->bs_sv) U32 -xrv SvRV(bstate->bs_sv) svindex -xpv bstate->bs_sv none x -xiv32 SvIVX(bstate->bs_sv) I32 -xiv64 SvIVX(bstate->bs_sv) IV64 -xnv SvNVX(bstate->bs_sv) NV -xlv_targoff LvTARGOFF(bstate->bs_sv) STRLEN -xlv_targlen LvTARGLEN(bstate->bs_sv) STRLEN -xlv_targ LvTARG(bstate->bs_sv) svindex -xlv_type LvTYPE(bstate->bs_sv) char -xbm_useful BmUSEFUL(bstate->bs_sv) I32 -xbm_previous BmPREVIOUS(bstate->bs_sv) U16 -xbm_rare BmRARE(bstate->bs_sv) U8 -xfm_lines FmLINES(bstate->bs_sv) I32 -xio_lines IoLINES(bstate->bs_sv) long -xio_page IoPAGE(bstate->bs_sv) long -xio_page_len IoPAGE_LEN(bstate->bs_sv) long -xio_lines_left IoLINES_LEFT(bstate->bs_sv) long -xio_top_name IoTOP_NAME(bstate->bs_sv) pvcontents -xio_top_gv *(SV**)&IoTOP_GV(bstate->bs_sv) svindex -xio_fmt_name IoFMT_NAME(bstate->bs_sv) pvcontents -xio_fmt_gv *(SV**)&IoFMT_GV(bstate->bs_sv) svindex -xio_bottom_name IoBOTTOM_NAME(bstate->bs_sv) pvcontents -xio_bottom_gv *(SV**)&IoBOTTOM_GV(bstate->bs_sv) svindex -xio_subprocess IoSUBPROCESS(bstate->bs_sv) short -xio_type IoTYPE(bstate->bs_sv) char -xio_flags IoFLAGS(bstate->bs_sv) char -xcv_stash *(SV**)&CvSTASH(bstate->bs_sv) svindex -xcv_start CvSTART(bstate->bs_sv) opindex -xcv_root CvROOT(bstate->bs_sv) opindex -xcv_gv *(SV**)&CvGV(bstate->bs_sv) svindex -xcv_file CvFILE(bstate->bs_sv) pvindex -xcv_depth CvDEPTH(bstate->bs_sv) long -xcv_padlist *(SV**)&CvPADLIST(bstate->bs_sv) svindex -xcv_outside *(SV**)&CvOUTSIDE(bstate->bs_sv) svindex -xcv_flags CvFLAGS(bstate->bs_sv) U16 -av_extend bstate->bs_sv SSize_t x -av_push bstate->bs_sv svindex x -xav_fill AvFILLp(bstate->bs_sv) SSize_t -xav_max AvMAX(bstate->bs_sv) SSize_t -xav_flags AvFLAGS(bstate->bs_sv) U8 -xhv_riter HvRITER(bstate->bs_sv) I32 -xhv_name HvNAME(bstate->bs_sv) pvcontents -hv_store bstate->bs_sv svindex x -sv_magic bstate->bs_sv char x -mg_obj SvMAGIC(bstate->bs_sv)->mg_obj svindex -mg_private SvMAGIC(bstate->bs_sv)->mg_private U16 -mg_flags SvMAGIC(bstate->bs_sv)->mg_flags U8 -mg_pv SvMAGIC(bstate->bs_sv) pvcontents x -xmg_stash *(SV**)&SvSTASH(bstate->bs_sv) svindex -gv_fetchpv bstate->bs_sv strconst x -gv_stashpv bstate->bs_sv strconst x -gp_sv GvSV(bstate->bs_sv) svindex -gp_refcnt GvREFCNT(bstate->bs_sv) U32 -gp_refcnt_add GvREFCNT(bstate->bs_sv) I32 x -gp_av *(SV**)&GvAV(bstate->bs_sv) svindex -gp_hv *(SV**)&GvHV(bstate->bs_sv) svindex -gp_cv *(SV**)&GvCV(bstate->bs_sv) svindex -gp_file GvFILE(bstate->bs_sv) pvindex -gp_io *(SV**)&GvIOp(bstate->bs_sv) svindex -gp_form *(SV**)&GvFORM(bstate->bs_sv) svindex -gp_cvgen GvCVGEN(bstate->bs_sv) U32 -gp_line GvLINE(bstate->bs_sv) line_t -gp_share bstate->bs_sv svindex x -xgv_flags GvFLAGS(bstate->bs_sv) U8 +pv_cur bytecode_pv.xpv_cur STRLEN +pv_free bytecode_pv none x +sv_upgrade bytecode_sv char x +sv_refcnt SvREFCNT(bytecode_sv) U32 +sv_refcnt_add SvREFCNT(bytecode_sv) I32 x +sv_flags SvFLAGS(bytecode_sv) U32 +xrv SvRV(bytecode_sv) svindex +xpv bytecode_sv none x +xiv32 SvIVX(bytecode_sv) I32 +xiv64 SvIVX(bytecode_sv) IV64 +xnv SvNVX(bytecode_sv) NV +xlv_targoff LvTARGOFF(bytecode_sv) STRLEN +xlv_targlen LvTARGLEN(bytecode_sv) STRLEN +xlv_targ LvTARG(bytecode_sv) svindex +xlv_type LvTYPE(bytecode_sv) char +xbm_useful BmUSEFUL(bytecode_sv) I32 +xbm_previous BmPREVIOUS(bytecode_sv) U16 +xbm_rare BmRARE(bytecode_sv) U8 +xfm_lines FmLINES(bytecode_sv) I32 +xio_lines IoLINES(bytecode_sv) long +xio_page IoPAGE(bytecode_sv) long +xio_page_len IoPAGE_LEN(bytecode_sv) long +xio_lines_left IoLINES_LEFT(bytecode_sv) long +xio_top_name IoTOP_NAME(bytecode_sv) pvcontents +xio_top_gv *(SV**)&IoTOP_GV(bytecode_sv) svindex +xio_fmt_name IoFMT_NAME(bytecode_sv) pvcontents +xio_fmt_gv *(SV**)&IoFMT_GV(bytecode_sv) svindex +xio_bottom_name IoBOTTOM_NAME(bytecode_sv) pvcontents +xio_bottom_gv *(SV**)&IoBOTTOM_GV(bytecode_sv) svindex +xio_subprocess IoSUBPROCESS(bytecode_sv) short +xio_type IoTYPE(bytecode_sv) char +xio_flags IoFLAGS(bytecode_sv) char +xcv_stash *(SV**)&CvSTASH(bytecode_sv) svindex +xcv_start CvSTART(bytecode_sv) opindex +xcv_root CvROOT(bytecode_sv) opindex +xcv_gv *(SV**)&CvGV(bytecode_sv) svindex +xcv_file CvFILE(bytecode_sv) pvcontents +xcv_depth CvDEPTH(bytecode_sv) long +xcv_padlist *(SV**)&CvPADLIST(bytecode_sv) svindex +xcv_outside *(SV**)&CvOUTSIDE(bytecode_sv) svindex +xcv_flags CvFLAGS(bytecode_sv) U16 +av_extend bytecode_sv SSize_t x +av_push bytecode_sv svindex x +xav_fill AvFILLp(bytecode_sv) SSize_t +xav_max AvMAX(bytecode_sv) SSize_t +xav_flags AvFLAGS(bytecode_sv) U8 +xhv_riter HvRITER(bytecode_sv) I32 +xhv_name HvNAME(bytecode_sv) pvcontents +hv_store bytecode_sv svindex x +sv_magic bytecode_sv char x +mg_obj SvMAGIC(bytecode_sv)->mg_obj svindex +mg_private SvMAGIC(bytecode_sv)->mg_private U16 +mg_flags SvMAGIC(bytecode_sv)->mg_flags U8 +mg_pv SvMAGIC(bytecode_sv) pvcontents x +xmg_stash *(SV**)&SvSTASH(bytecode_sv) svindex +gv_fetchpv bytecode_sv strconst x +gv_stashpv bytecode_sv strconst x +gp_sv GvSV(bytecode_sv) svindex +gp_refcnt GvREFCNT(bytecode_sv) U32 +gp_refcnt_add GvREFCNT(bytecode_sv) I32 x +gp_av *(SV**)&GvAV(bytecode_sv) svindex +gp_hv *(SV**)&GvHV(bytecode_sv) svindex +gp_cv *(SV**)&GvCV(bytecode_sv) svindex +gp_file GvFILE(bytecode_sv) pvcontents +gp_io *(SV**)&GvIOp(bytecode_sv) svindex +gp_form *(SV**)&GvFORM(bytecode_sv) svindex +gp_cvgen GvCVGEN(bytecode_sv) U32 +gp_line GvLINE(bytecode_sv) line_t +gp_share bytecode_sv svindex x +xgv_flags GvFLAGS(bytecode_sv) U8 op_next PL_op->op_next opindex op_sibling PL_op->op_sibling opindex op_ppaddr PL_op->op_ppaddr strconst x @@ -395,9 +399,9 @@ op_pv_tr cPVOP->op_pv op_tr_array op_redoop cLOOP->op_redoop opindex op_nextop cLOOP->op_nextop opindex op_lastop cLOOP->op_lastop opindex -cop_label cCOP->cop_label pvindex -cop_stashpv cCOP pvindex x -cop_file cCOP pvindex x +cop_label cCOP->cop_label pvcontents +cop_stashpv cCOP pvcontents x +cop_file cCOP pvcontents x cop_seq cCOP->cop_seq U32 cop_arybase cCOP->cop_arybase I32 cop_line cCOP line_t x @@ -405,6 +409,3 @@ cop_warnings cCOP->cop_warnings svindex main_start PL_main_start opindex main_root PL_main_root opindex curpad PL_curpad svindex x -push_begin PL_beginav svindex x -push_init PL_initav svindex x -push_end PL_endav svindex x @@ -504,8 +504,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { dTHR; - bool is_reg = IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode); - if (IoTYPE(io) == 's' || is_reg) + if (IoTYPE(io) == 's' + || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) { char *mode; if (out_raw) @@ -520,10 +520,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoIFP(io) = Nullfp; goto say_false; } - else { - if (is_reg) - IoIFP(io) = IoOFP(io); /* avoid double close() */ - } } else IoOFP(io) = fp; @@ -21,15 +21,14 @@ #endif #endif - -#define HALF_UPGRADE(start,end) { \ - U8* newstr; \ - STRLEN len; \ - len = end-start; \ - newstr = bytes_to_utf8(start, &len); \ - Copy(newstr,start,len,U8*); \ - end = start + len; \ - } +#define HALF_UPGRADE(start,end) \ + STMT_START { \ + U8* NeWsTr; \ + STRLEN LeN = LeN = (end) - (start); \ + NeWsTr = bytes_to_utf8(start, &LeN); \ + Copy(NeWsTr,start,LeN,U8*); \ + end = (start) + len; \ + } STMT_END STATIC I32 @@ -55,14 +54,15 @@ S_do_trans_simple(pTHX_ SV *sv) /* First, take care of non-UTF8 input strings, because they're easy */ if (!sutf) { - while (s < send) { + while (s < send) { if ((ch = tbl[*s]) >= 0) { - matches++; - *s++ = ch; - } else - s++; - } - SvSETMAGIC(sv); + matches++; + *s++ = ch; + } + else + s++; + } + SvSETMAGIC(sv); return matches; } @@ -83,12 +83,13 @@ S_do_trans_simple(pTHX_ SV *sv) else d = uv_to_utf8(d,ch); s += ulen; - } else { /* No match -> copy */ + } + else { /* No match -> copy */ while (ulen--) *d++ = *s++; } } - *d='\0'; + *d = '\0'; sv_setpvn(sv, (const char*)dstart, d - dstart); SvUTF8_on(sv); SvLEN_set(sv, 2*len+1); @@ -116,7 +117,7 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ while (s < send) { if (hasutf && *s & 0x80) - s+=UTF8SKIP(s); + s += UTF8SKIP(s); else { UV c; I32 ulen; @@ -127,7 +128,7 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ c = *s; if (c < 0x100 && tbl[c] >= 0) matches++; - s+=ulen; + s += ulen; } } @@ -160,7 +161,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ while (s < send) { if (hasutf && *s & 0x80) - s+=UTF8SKIP(s); + s += UTF8SKIP(s); else { if ((ch = tbl[*s]) >= 0) { *d = ch; @@ -170,7 +171,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ else p = d++; } - else if (ch == -1) /* -1 is unmapped character */ + else if (ch == -1) /* -1 is unmapped character */ *d++ = *s; /* -2 is delete character */ s++; } @@ -179,20 +180,20 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ else { while (s < send) { if (hasutf && *s & 0x80) - s+=UTF8SKIP(s); + s += UTF8SKIP(s); else { if ((ch = tbl[*s]) >= 0) { *d = ch; matches++; d++; } - else if (ch == -1) /* -1 is unmapped character */ + else if (ch == -1) /* -1 is unmapped character */ *d++ = *s; /* -2 is delete character */ s++; } } } - matches += send - d; /* account for disappeared chars */ + matches += send - d; /* account for disappeared chars */ *d = '\0'; SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); @@ -238,13 +239,13 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ if ((uv = swash_fetch(rv, s)) < none) { s += UTF8SKIP(s); matches++; - if (uv & 0x80 && !isutf++) + if ((uv & 0x80) && !isutf++) HALF_UPGRADE(dstart,d); d = uv_to_utf8(d, uv); } else if (uv == none) { int i; - i = UTF8SKIP(s); + i = UTF8SKIP(s); if (i > 1 && !isutf++) HALF_UPGRADE(dstart,d); while(i--) @@ -252,7 +253,7 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ } else if (uv == extra) { int i; - i = UTF8SKIP(s); + i = UTF8SKIP(s); s += i; matches++; if (i > 1 && !isutf++) @@ -351,32 +352,32 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ if (uv < none) { matches++; if (uv != puv) { - if (uv & 0x80 && !isutf++) + if ((uv & 0x80) && !isutf++) HALF_UPGRADE(dst,d); - d = uv_to_utf8(d, uv); + d = uv_to_utf8(d, uv); puv = uv; } s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; + I32 ulen; + *d++ = (U8)utf8_to_uv(s, &ulen); + s += ulen; puv = 0xfeedface; continue; } else if (uv == extra && !del) { matches++; if (uv != puv) { - d = uv_to_utf8(d, final); + d = uv_to_utf8(d, final); puv = final; } - s += UTF8SKIP(s); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } else { @@ -396,24 +397,24 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ } if (uv < none) { matches++; - d = uv_to_utf8(d, uv); - s += UTF8SKIP(s); + d = uv_to_utf8(d, uv); + s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; + I32 ulen; + *d++ = (U8)utf8_to_uv(s, &ulen); + s += ulen; continue; } else if (uv == extra && !del) { matches++; - d = uv_to_utf8(d, final); - s += UTF8SKIP(s); + d = uv_to_utf8(d, final); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } if (dst) @@ -450,19 +451,19 @@ Perl_do_trans(pTHX_ SV *sv) switch (PL_op->op_private & ~hasutf & 63) { case 0: - if (hasutf) - return do_trans_simple_utf8(sv); - else - return do_trans_simple(sv); + if (hasutf) + return do_trans_simple_utf8(sv); + else + return do_trans_simple(sv); case OPpTRANS_IDENTICAL: - if (hasutf) - return do_trans_count_utf8(sv); - else - return do_trans_count(sv); + if (hasutf) + return do_trans_count_utf8(sv); + else + return do_trans_count(sv); default: - if (hasutf) + if (hasutf) return do_trans_complex_utf8(sv); else return do_trans_complex(sv); @@ -1375,7 +1375,7 @@ Ap |bool |Gv_AMupdate |HV* stash p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp -Afp |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len +Ap |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash @@ -2256,7 +2256,6 @@ s |char* |gv_ename |GV *gv s |void |cv_dump |CV *cv s |CV* |cv_clone2 |CV *proto|CV *outside s |bool |scalar_mod_type|OP *o|I32 type -s |OP * |method_2entersub|OP *o|OP *o2|OP *svop s |OP * |my_kid |OP *o|OP *attrs s |OP * |dup_attrlist |OP *o s |void |apply_attrs |HV *stash|SV *target|OP *attrs diff --git a/embedvar.h b/embedvar.h index f6488c6977..3bd98d121f 100644 --- a/embedvar.h +++ b/embedvar.h @@ -196,7 +196,6 @@ #define PL_argvoutgv (PERL_GET_INTERP->Iargvoutgv) #define PL_basetime (PERL_GET_INTERP->Ibasetime) #define PL_beginav (PERL_GET_INTERP->Ibeginav) -#define PL_beginav_save (PERL_GET_INTERP->Ibeginav_save) #define PL_bitcount (PERL_GET_INTERP->Ibitcount) #define PL_bufend (PERL_GET_INTERP->Ibufend) #define PL_bufptr (PERL_GET_INTERP->Ibufptr) @@ -247,7 +246,6 @@ #define PL_exitlistlen (PERL_GET_INTERP->Iexitlistlen) #define PL_expect (PERL_GET_INTERP->Iexpect) #define PL_fdpid (PERL_GET_INTERP->Ifdpid) -#define PL_fdpid_mutex (PERL_GET_INTERP->Ifdpid_mutex) #define PL_filemode (PERL_GET_INTERP->Ifilemode) #define PL_forkprocess (PERL_GET_INTERP->Iforkprocess) #define PL_formfeed (PERL_GET_INTERP->Iformfeed) @@ -380,7 +378,6 @@ #define PL_subname (PERL_GET_INTERP->Isubname) #define PL_sv_arenaroot (PERL_GET_INTERP->Isv_arenaroot) #define PL_sv_count (PERL_GET_INTERP->Isv_count) -#define PL_sv_lock_mutex (PERL_GET_INTERP->Isv_lock_mutex) #define PL_sv_mutex (PERL_GET_INTERP->Isv_mutex) #define PL_sv_no (PERL_GET_INTERP->Isv_no) #define PL_sv_objcount (PERL_GET_INTERP->Isv_objcount) @@ -476,7 +473,6 @@ #define PL_argvoutgv (vTHX->Iargvoutgv) #define PL_basetime (vTHX->Ibasetime) #define PL_beginav (vTHX->Ibeginav) -#define PL_beginav_save (vTHX->Ibeginav_save) #define PL_bitcount (vTHX->Ibitcount) #define PL_bufend (vTHX->Ibufend) #define PL_bufptr (vTHX->Ibufptr) @@ -527,7 +523,6 @@ #define PL_exitlistlen (vTHX->Iexitlistlen) #define PL_expect (vTHX->Iexpect) #define PL_fdpid (vTHX->Ifdpid) -#define PL_fdpid_mutex (vTHX->Ifdpid_mutex) #define PL_filemode (vTHX->Ifilemode) #define PL_forkprocess (vTHX->Iforkprocess) #define PL_formfeed (vTHX->Iformfeed) @@ -660,7 +655,6 @@ #define PL_subname (vTHX->Isubname) #define PL_sv_arenaroot (vTHX->Isv_arenaroot) #define PL_sv_count (vTHX->Isv_count) -#define PL_sv_lock_mutex (vTHX->Isv_lock_mutex) #define PL_sv_mutex (vTHX->Isv_mutex) #define PL_sv_no (vTHX->Isv_no) #define PL_sv_objcount (vTHX->Isv_objcount) @@ -893,7 +887,6 @@ #define PL_argvoutgv (aTHXo->interp.Iargvoutgv) #define PL_basetime (aTHXo->interp.Ibasetime) #define PL_beginav (aTHXo->interp.Ibeginav) -#define PL_beginav_save (aTHXo->interp.Ibeginav_save) #define PL_bitcount (aTHXo->interp.Ibitcount) #define PL_bufend (aTHXo->interp.Ibufend) #define PL_bufptr (aTHXo->interp.Ibufptr) @@ -944,7 +937,6 @@ #define PL_exitlistlen (aTHXo->interp.Iexitlistlen) #define PL_expect (aTHXo->interp.Iexpect) #define PL_fdpid (aTHXo->interp.Ifdpid) -#define PL_fdpid_mutex (aTHXo->interp.Ifdpid_mutex) #define PL_filemode (aTHXo->interp.Ifilemode) #define PL_forkprocess (aTHXo->interp.Iforkprocess) #define PL_formfeed (aTHXo->interp.Iformfeed) @@ -1077,7 +1069,6 @@ #define PL_subname (aTHXo->interp.Isubname) #define PL_sv_arenaroot (aTHXo->interp.Isv_arenaroot) #define PL_sv_count (aTHXo->interp.Isv_count) -#define PL_sv_lock_mutex (aTHXo->interp.Isv_lock_mutex) #define PL_sv_mutex (aTHXo->interp.Isv_mutex) #define PL_sv_no (aTHXo->interp.Isv_no) #define PL_sv_objcount (aTHXo->interp.Isv_objcount) @@ -1174,7 +1165,6 @@ #define PL_Iargvoutgv PL_argvoutgv #define PL_Ibasetime PL_basetime #define PL_Ibeginav PL_beginav -#define PL_Ibeginav_save PL_beginav_save #define PL_Ibitcount PL_bitcount #define PL_Ibufend PL_bufend #define PL_Ibufptr PL_bufptr @@ -1225,7 +1215,6 @@ #define PL_Iexitlistlen PL_exitlistlen #define PL_Iexpect PL_expect #define PL_Ifdpid PL_fdpid -#define PL_Ifdpid_mutex PL_fdpid_mutex #define PL_Ifilemode PL_filemode #define PL_Iforkprocess PL_forkprocess #define PL_Iformfeed PL_formfeed @@ -1358,7 +1347,6 @@ #define PL_Isubname PL_subname #define PL_Isv_arenaroot PL_sv_arenaroot #define PL_Isv_count PL_sv_count -#define PL_Isv_lock_mutex PL_sv_lock_mutex #define PL_Isv_mutex PL_sv_mutex #define PL_Isv_no PL_sv_no #define PL_Isv_objcount PL_sv_objcount diff --git a/ext/B/B.pm b/ext/B/B.pm index 50364fa1d2..4512d916e6 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,12 +9,11 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(minus_c ppname save_BEGINs +@EXPORT_OK = qw(minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names main_root main_start main_cv svref_2object opnumber amagic_generation walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info - begin_av init_av end_av); + parents comppadlist sv_undef compile_stats timing_info init_av); sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; diff --git a/ext/B/B.xs b/ext/B/B.xs index bf5479518f..9e2985582a 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -81,7 +81,7 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ -static SV *specialsv_list[6]; +static SV *specialsv_list[4]; static opclass cc_opclass(pTHX_ OP *o) @@ -386,15 +386,11 @@ BOOT: specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = pWARN_ALL; - specialsv_list[5] = pWARN_NONE; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav -#define B_begin_av() PL_beginav_save -#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -406,12 +402,6 @@ BOOT: B::AV B_init_av() -B::AV -B_begin_av() - -B::AV -B_end_av() - B::CV B_main_cv() @@ -525,11 +515,6 @@ minus_c() CODE: PL_minus_c = TRUE; -void -save_BEGINs() - CODE: - PL_minus_c |= 0x10; - SV * cstring(sv) SV * sv @@ -708,8 +693,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) cSVOPo_sv -#define SVOP_gv(o) cGVOPo_gv +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm index b412927ab4..bc0eda935b 100644 --- a/ext/B/B/Asmdata.pm +++ b/ext/B/B/Asmdata.pm @@ -15,7 +15,7 @@ use Exporter; our(%insn_data, @insn_name, @optype, @specialsv_name); @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 pWARN_ALL pWARN_NONE); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); # XXX insn_data is initialised this way because with a large # %insn_data = (foo => [...], bar => [...], ...) initialiser @@ -27,121 +27,117 @@ $insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; $insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; $insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; $insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newop} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newopn} = [9, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [11, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [12, \&PUT_U32, "GET_U32"]; -$insn_data{pv_free} = [13, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [14, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [15, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [16, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [17, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [18, \&PUT_svindex, "GET_svindex"]; -$insn_data{xpv} = [19, \&PUT_none, "GET_none"]; -$insn_data{xiv32} = [20, \&PUT_I32, "GET_I32"]; -$insn_data{xiv64} = [21, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [22, \&PUT_NV, "GET_NV"]; -$insn_data{xlv_targoff} = [23, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targlen} = [24, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targ} = [25, \&PUT_svindex, "GET_svindex"]; -$insn_data{xlv_type} = [26, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [27, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [28, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [29, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [30, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page} = [32, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page_len} = [33, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines_left} = [34, \&PUT_I32, "GET_I32"]; -$insn_data{xio_top_name} = [36, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_top_gv} = [37, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [38, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_fmt_gv} = [39, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [40, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_bottom_gv} = [41, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [42, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [43, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [44, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_stash} = [45, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_start} = [46, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_root} = [47, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_gv} = [48, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_file} = [49, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xcv_depth} = [50, \&PUT_I32, "GET_I32"]; -$insn_data{xcv_padlist} = [51, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside} = [52, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_flags} = [53, \&PUT_U16, "GET_U16"]; -$insn_data{av_extend} = [54, \&PUT_I32, "GET_I32"]; -$insn_data{av_push} = [55, \&PUT_svindex, "GET_svindex"]; -$insn_data{xav_fill} = [56, \&PUT_I32, "GET_I32"]; -$insn_data{xav_max} = [57, \&PUT_I32, "GET_I32"]; -$insn_data{xav_flags} = [58, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [59, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [60, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{hv_store} = [61, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [62, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [63, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [64, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [65, \&PUT_U8, "GET_U8"]; -$insn_data{mg_pv} = [66, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xmg_stash} = [67, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [68, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [69, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [70, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [71, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [72, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [73, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_hv} = [74, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cv} = [75, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_file} = [76, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{gp_io} = [77, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_form} = [78, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cvgen} = [79, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [80, \&PUT_U16, "GET_U16"]; -$insn_data{gp_share} = [81, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [82, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [83, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [84, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [85, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [86, \&PUT_U32, "GET_U32"]; -$insn_data{op_type} = [87, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [88, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [89, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [90, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [91, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_last} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_other} = [93, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_children} = [94, \&PUT_U32, "GET_U32"]; -$insn_data{op_pmreplroot} = [95, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplrootgv} = [96, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplstart} = [97, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [98, \&PUT_opindex, "GET_opindex"]; -$insn_data{pregcomp} = [99, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [100, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [101, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [102, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_padix} = [103, \&PUT_U32, "GET_U32"]; -$insn_data{op_pv} = [104, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [105, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [106, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [108, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [109, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stashpv} = [110, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_file} = [111, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_seq} = [112, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [113, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [114, \&PUT_U16, "GET_U16"]; -$insn_data{cop_warnings} = [115, \&PUT_svindex, "GET_svindex"]; -$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{push_begin} = [119, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_init} = [120, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_end} = [121, \&PUT_svindex, "GET_svindex"]; +$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"]; +$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"]; +$insn_data{newop} = [7, \&PUT_U8, "GET_U8"]; +$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"]; +$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"]; +$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"]; +$insn_data{pv_free} = [12, \&PUT_none, "GET_none"]; +$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"]; +$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"]; +$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"]; +$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"]; +$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_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"]; +$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"]; +$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"]; +$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"]; +$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"]; +$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"]; +$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_top_gv} = [36, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_fmt_gv} = [38, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_bottom_gv} = [40, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"]; +$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"]; +$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"]; +$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_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_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"]; +$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"]; +$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"]; +$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"]; +$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{hv_store} = [60, \&PUT_svindex, "GET_svindex"]; +$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"]; +$insn_data{mg_obj} = [62, \&PUT_svindex, "GET_svindex"]; +$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"]; +$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"]; +$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xmg_stash} = [66, \&PUT_svindex, "GET_svindex"]; +$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"]; +$insn_data{gp_sv} = [69, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"]; +$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_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"]; +$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"]; +$insn_data{gp_share} = [80, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"]; +$insn_data{op_next} = [82, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_sibling} = [83, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"]; +$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"]; +$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"]; +$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"]; +$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"]; +$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_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/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm index 5e798ce485..6c51a9ad3e 100644 --- a/ext/B/B/Assembler.pm +++ b/ext/B/B/Assembler.pm @@ -4,17 +4,14 @@ # # 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::Assembler; use Exporter; use B qw(ppname); use B::Asmdata qw(%insn_data @insn_name); -use Config qw(%Config); -require ByteLoader; # we just need its $VERSIOM @ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh newasm endasm assemble); -$VERSION = 0.02; +@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments + parse_statement uncstring); use strict; my %opnumber; @@ -23,7 +20,7 @@ for ($i = 0; defined($opname = ppname($i)); $i++) { $opnumber{$opname} = $i; } -my($linenum, $errors, $out); # global state, set up by newasm +my ($linenum, $errors); sub error { my $str = shift; @@ -52,15 +49,13 @@ sub B::Asmdata::PUT_U8 { return $c; } -sub B::Asmdata::PUT_U16 { pack("S", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } -sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) - # may not even be portable between compilers -sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here +sub B::Asmdata::PUT_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 } -sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -84,7 +79,7 @@ sub B::Asmdata::PUT_PV { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); - return pack("L", length($arg)) . $arg; + return pack("N", length($arg)) . $arg; } sub B::Asmdata::PUT_comment_t { my $arg = shift; @@ -95,7 +90,7 @@ sub B::Asmdata::PUT_comment_t { } return $arg . "\n"; } -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } sub B::Asmdata::PUT_none { my $arg = shift; error "extraneous argument: $arg" if defined $arg; @@ -108,12 +103,12 @@ sub B::Asmdata::PUT_op_tr_array { error "wrong number of arguments to op_tr_array"; @ary = (0) x 256; } - return pack("S256", @ary); + return pack("n256", @ary); } # XXX Check this works sub B::Asmdata::PUT_IV64 { my $arg = shift; - return pack("LL", $arg >> 32, $arg & 0xffffffff); + return pack("NN", $arg >> 32, $arg & 0xffffffff); } my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", @@ -143,24 +138,6 @@ sub strip_comments { return $stmt; } -# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, -# ptrsize, byteorder -# nvtype is irrelevant (floats are stored as strings) -# byteorder is strconst not U32 because of varying size issues - -sub gen_header { - my $header = ""; - - $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' - $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); - $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); - $header .= B::Asmdata::PUT_U32($Config{ivsize}); - $header .= B::Asmdata::PUT_U32($Config{ptrsize}); - $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder})); - - $header; -} - sub parse_statement { my $stmt = shift; my ($insn, $arg) = $stmt =~ m{ @@ -206,52 +183,27 @@ sub assemble_insn { sub assemble_fh { my ($fh, $out) = @_; - my $line; - my $asm = newasm($out); + my ($line, $insn, $arg); + $linenum = 0; + $errors = 0; while ($line = <$fh>) { - assemble($line); + $linenum++; + chomp $line; + if ($debug) { + my $quotedline = $line; + $quotedline =~ s/\\/\\\\/g; + $quotedline =~ s/"/\\"/g; + &$out(assemble_insn("comment", qq("$quotedline"))); + } + $line = strip_comments($line) or next; + ($insn, $arg) = parse_statement($line); + &$out(assemble_insn($insn, $arg)); + if ($debug) { + &$out(assemble_insn("nop", undef)); + } } - endasm(); -} - -sub newasm { - my($outsub) = @_; - - die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; - die <<EOD if ref $out; -Can't have multiple byteassembly sessions at once! - (perhaps you forgot an endasm()?) -EOD - - $linenum = $errors = 0; - $out = $outsub; - - $out->(gen_header()); -} - -sub endasm { if ($errors) { - die "There were $errors assembly errors\n"; - } - $linenum = $errors = $out = 0; -} - -sub assemble { - my($line) = @_; - my ($insn, $arg); - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - $out->(assemble_insn("comment", qq("$quotedline"))); - } - $line = strip_comments($line) or next; - ($insn, $arg) = parse_statement($line); - $out->(assemble_insn($insn, $arg)); - if ($debug) { - $out->(assemble_insn("nop", undef)); + die "Assembly failed with $errors error(s)\n"; } } @@ -265,21 +217,14 @@ B::Assembler - Assemble Perl bytecode =head1 SYNOPSIS - use B::Assembler qw(newasm endasm assemble); - newasm(\&printsub); # sets up for assembly - assemble($buf); # assembles one line - endasm(); # closes down - - use B::Assembler qw(assemble_fh); - assemble_fh($fh, \&printsub); # assemble everything in $fh + use Assembler; =head1 DESCRIPTION See F<ext/B/B/Assembler.pm>. -=head1 AUTHORS +=head1 AUTHOR Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> -Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm index ef59c4af42..941a818f6b 100644 --- a/ext/B/B/Bytecode.pm +++ b/ext/B/B/Bytecode.pm @@ -6,18 +6,16 @@ # License or the Artistic License, as specified in the README file. # package B::Bytecode; - use strict; use Carp; -use B qw(main_cv main_root main_start comppadlist +use IO::File; + +use B qw(minus_c main_cv main_root main_start comppadlist class peekop walkoptree svref_2object cstring walksymtable - init_av begin_av end_av - SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK - SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV - GVf_IMPORTED_SV SVTYPEMASK + SVf_POK SVp_POK SVf_IOK SVp_IOK ); use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(newasm endasm assemble); +use B::Assembler qw(assemble_fh); my %optype_enum; my $i; @@ -33,76 +31,41 @@ sub POK () { SVf_POK|SVp_POK } # XXX Shouldn't be hardwired sub IOK () { SVf_IOK|SVp_IOK } -# Following is SVf_NOK|SVp_NOK -# XXX Shouldn't be hardwired -sub NOK () { SVf_NOK|SVp_NOK } - -# nonexistant flags (see B::GV::bytecode for usage) -sub GVf_IMPORTED_IO () { 0; } -sub GVf_IMPORTED_FORM () { 0; } - -my ($verbose, $no_assemble, $debug_bc, $debug_cv); -my @packages; # list of packages to compile - -sub asm (@) { # print replacement that knows about assembling - if ($no_assemble) { - print @_; - } else { - my $buf = join '', @_; - assemble($_) for (split /\n/, $buf); - } -} - -sub asmf (@) { # printf replacement that knows about assembling - if ($no_assemble) { - printf shift(), @_; - } else { - my $format = shift; - my $buf = sprintf $format, @_; - assemble($_) for (split /\n/, $buf); - } -} +my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); +my $assembler_pid; # Optimisation options. On the command line, use hyphens instead of # underscores for compatibility with gcc-style options. We use # underscores here because they are OK in (strict) barewords. -my ($compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (compress_nullops => \$compress_nullops, +my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); +my %optimise = (strip_syntax_tree => \$strip_syntree, + compress_nullops => \$compress_nullops, omit_sequence_numbers => \$omit_seq, bypass_nullops => \$bypass_nullops); -my $strip_syntree; # this is left here in case stripping the - # syntree ever becomes safe again - # -- BKS, June 2000 - my $nextix = 0; my %symtable; # maps object addresses to object indices. # Filled in at allocation (newsv/newop) time. - my %saved; # maps object addresses (for SVish classes) to "saved yet?" # flag. Set at FOO::bytecode time usually by SV::bytecode. # Manipulated via saved(), mark_saved(), unmark_saved(). -my %strtable; # maps shared strings to object indices - # Filled in at allocation (pvix) time - my $svix = -1; # we keep track of when the sv register contains an element # of the object table to avoid unnecessary repeated # consecutive ldsv instructions. - my $opix = -1; # Ditto for the op register. sub ldsv { my $ix = shift; if ($ix != $svix) { - asm "ldsv $ix\n"; + print "ldsv $ix\n"; $svix = $ix; } } sub stsv { my $ix = shift; - asm "stsv $ix\n"; + print "stsv $ix\n"; $svix = $ix; } @@ -113,14 +76,14 @@ sub set_svix { sub ldop { my $ix = shift; if ($ix != $opix) { - asm "ldop $ix\n"; + print "ldop $ix\n"; $opix = $ix; } } sub stop { my $ix = shift; - asm "stop $ix\n"; + print "stop $ix\n"; $opix = $ix; } @@ -137,29 +100,12 @@ sub pvstring { } } -sub nv { - # print full precision - my $str = sprintf "%.40f", $_[0]; - $str =~ s/0+$//; # remove trailing zeros - $str =~ s/\.$/.0/; - return $str; -} - sub saved { $saved{${$_[0]}} } sub mark_saved { $saved{${$_[0]}} = 1 } sub unmark_saved { $saved{${$_[0]}} = 0 } sub debug { $debug_bc = shift } -sub pvix { # save a shared PV (mainly for COPs) - return $strtable{$_[0]} if defined($strtable{$_[0]}); - asmf "newpv %s\n", pvstring($_[0]); - my $ix = $nextix++; - $strtable{$_[0]} = $ix; - asmf "stpv %d\n", $ix; - return $ix; -} - sub B::OBJECT::nyi { my $obj = shift; warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", @@ -183,7 +129,7 @@ sub B::OBJECT::objix { sub B::SV::newix { my ($sv, $ix) = @_; - asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); + printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); stsv($ix); } @@ -191,7 +137,7 @@ sub B::GV::newix { my ($gv, $ix) = @_; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); - asm "gv_fetchpv $name\n"; + print "gv_fetchpv $name\n"; stsv($ix); } @@ -200,7 +146,7 @@ sub B::HV::newix { my $name = $hv->NAME; if ($name) { # It's a stash - asmf "gv_stashpv %s\n", cstring($name); + printf "gv_stashpv %s\n", cstring($name); stsv($ix); } else { # It's an ordinary HV. Fall back to ordinary newix method @@ -212,7 +158,7 @@ sub B::SPECIAL::newix { my ($sv, $ix) = @_; # Special case. $$sv is not the address of the SV but an # index into svspecialsv_list. - asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; + printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; stsv($ix); } @@ -220,8 +166,8 @@ sub B::OP::newix { my ($op, $ix) = @_; my $class = class($op); my $typenum = $optype_enum{$class}; - croak("OP::newix: can't understand class $class") unless defined($typenum); - asm "newop $typenum\t# $class\n"; + croak "OP::newix: can't understand class $class" unless defined($typenum); + print "newop $typenum\t# $class\n"; stop($ix); } @@ -234,7 +180,7 @@ sub B::OP::bytecode { my $op = shift; my $next = $op->next; my $nextix; - my $sibix = $op->sibling->objix unless $strip_syntree; + my $sibix = $op->sibling->objix; my $ix = $op->objix; my $type = $op->type; @@ -243,24 +189,24 @@ sub B::OP::bytecode { } $nextix = $next->objix; - asmf "# %s\n", peekop($op) if $debug_bc; + printf "# %s\n", peekop($op) if $debug_bc; ldop($ix); - asm "op_next $nextix\n"; - asm "op_sibling $sibix\n" unless $strip_syntree; - asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; - asmf("op_seq %d\n", $op->seq) unless $omit_seq; + print "op_next $nextix\n"; + print "op_sibling $sibix\n" unless $strip_syntree; + 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) { - asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", + printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", $op->targ, $op->flags, $op->private; } } sub B::UNOP::bytecode { my $op = shift; - my $firstix = $op->first->objix unless $strip_syntree; + my $firstix = $op->first->objix; $op->B::OP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - asm "op_first $firstix\n"; + print "op_first $firstix\n"; } } @@ -268,7 +214,7 @@ sub B::LOGOP::bytecode { my $op = shift; my $otherix = $op->other->objix; $op->B::UNOP::bytecode; - asm "op_other $otherix\n"; + print "op_other $otherix\n"; } sub B::SVOP::bytecode { @@ -276,7 +222,7 @@ sub B::SVOP::bytecode { my $sv = $op->sv; my $svix = $sv->objix; $op->B::OP::bytecode; - asm "op_sv $svix\n"; + print "op_sv $svix\n"; $sv->bytecode; } @@ -284,7 +230,7 @@ sub B::PADOP::bytecode { my $op = shift; my $padix = $op->padix; $op->B::OP::bytecode; - asm "op_padix $padix\n"; + print "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -297,27 +243,27 @@ sub B::PVOP::bytecode { # if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness - asm "op_pv_tr ", join(",", @shorts), "\n"; + print "op_pv_tr ", join(",", @shorts), "\n"; } else { - asmf "newpv %s\nop_pv\n", pvstring($pv); + printf "newpv %s\nop_pv\n", pvstring($pv); } } sub B::BINOP::bytecode { my $op = shift; - my $lastix = $op->last->objix unless $strip_syntree; + my $lastix = $op->last->objix; $op->B::UNOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - asm "op_last $lastix\n"; + print "op_last $lastix\n"; } } sub B::LISTOP::bytecode { my $op = shift; - my $children = $op->children unless $strip_syntree; + my $children = $op->children; $op->B::BINOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - asm "op_children $children\n"; + print "op_children $children\n"; } } @@ -327,29 +273,28 @@ sub B::LOOP::bytecode { my $nextopix = $op->nextop->objix; my $lastopix = $op->lastop->objix; $op->B::LISTOP::bytecode; - asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; + print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; } sub B::COP::bytecode { my $op = shift; + my $stashpv = $op->stashpv; my $file = $op->file; my $line = $op->line; - if ($debug_bc) { # do this early to aid debugging - asmf "# line %s:%d\n", $file, $line; - } - my $stashpv = $op->stashpv; my $warnings = $op->warnings; my $warningsix = $warnings->objix; - my $labelix = pvix($op->label); - my $stashix = pvix($stashpv); - my $fileix = pvix($file); - $warnings->bytecode; + if ($debug_bc) { + printf "# line %s:%d\n", $file, $line; + } $op->B::OP::bytecode; - asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; -cop_label %d -cop_stashpv %d + printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; +newpv %s +cop_label +newpv %s +cop_stashpv cop_seq %d -cop_file %d +newpv %s +cop_file cop_arybase %d cop_line $line cop_warnings $warningsix @@ -377,13 +322,13 @@ sub B::PMOP::bytecode { } $op->B::LISTOP::bytecode; if ($opname eq "pushre") { - asmf "op_pmreplrootgv $replrootix\n"; + printf "op_pmreplrootgv $replrootix\n"; } else { - asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; + print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; } my $re = pvstring($op->precomp); # op_pmnext omitted since a perl bug means it's sometime corrupt - asmf <<"EOT", $op->pmflags, $op->pmpermflags; + printf <<"EOT", $op->pmflags, $op->pmpermflags; op_pmflags 0x%x op_pmpermflags 0x%x newpv $re @@ -398,7 +343,7 @@ sub B::SV::bytecode { my $refcnt = $sv->REFCNT; my $flags = sprintf("0x%x", $sv->FLAGS); ldsv($ix); - asm "sv_refcnt $refcnt\nsv_flags $flags\n"; + print "sv_refcnt $refcnt\nsv_flags $flags\n"; mark_saved($sv); } @@ -406,7 +351,7 @@ sub B::PV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; + printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; } sub B::IV::bytecode { @@ -414,14 +359,14 @@ sub B::IV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::SV::bytecode; - asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV + printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; } sub B::NV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - asmf "xnv %s\n", nv($sv->NVX); + printf "xnv %s\n", $sv->NVX; } sub B::RV::bytecode { @@ -431,7 +376,7 @@ sub B::RV::bytecode { my $rvix = $rv->objix; $rv->bytecode; $sv->B::SV::bytecode; - asm "xrv $rvix\n"; + print "xrv $rvix\n"; } sub B::PVIV::bytecode { @@ -439,7 +384,7 @@ sub B::PVIV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::PV::bytecode; - asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; } sub B::PVNV::bytecode { @@ -459,12 +404,12 @@ sub B::PVNV::bytecode { } else { my $pv = $sv->PV; $sv->B::IV::bytecode; - asmf "xnv %s\n", nv($sv->NVX); + printf "xnv %s\n", $sv->NVX; if ($flag == 1) { $pv .= "\0" . $sv->TABLE; - asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; + printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; } else { - asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; + printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; } } } @@ -486,9 +431,9 @@ sub B::PVMG::bytecode { # @mgobjix = map($_->OBJ->objix, @mgchain); $sv->B::PVNV::bytecode($flag); - asm "xmg_stash $stashix\n"; + print "xmg_stash $stashix\n"; foreach $mg (@mgchain) { - asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", + printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); } } @@ -497,7 +442,7 @@ sub B::PVLV::bytecode { my $sv = shift; return if saved($sv); $sv->B::PVMG::bytecode; - asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); + printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); xlv_targoff %d xlv_targlen %d xlv_type %s @@ -509,63 +454,46 @@ sub B::BM::bytecode { return if saved($sv); # See PVNV::bytecode for an explanation of what the argument does $sv->B::PVMG::bytecode(1); - asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", + printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; } -sub empty_gv { # is a GV empty except for imported stuff? - my $gv = shift; - - return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL - my @subfield_names = qw(AV HV CV FORM IO); - @subfield_names = grep {; - no strict 'refs'; - !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; - } @subfield_names; - return scalar @subfield_names; -} - sub B::GV::bytecode { my $gv = shift; return if saved($gv); - return unless grep { $_ eq $gv->STASH->NAME; } @packages; - return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt my $ix = $gv->objix; mark_saved($gv); ldsv($ix); - asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; + printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x EOT my $refcnt = $gv->REFCNT; - asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; return if $gv->is_empty; - asmf <<"EOT", $gv->LINE, pvix($gv->FILE); + printf <<"EOT", $gv->LINE, pvstring($gv->FILE); gp_line %d -gp_file %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; - asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; + printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { - asm "gp_share $egvix\n"; + print "gp_share $egvix\n"; } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; my @subfield_names = qw(SV AV HV CV FORM IO); - @subfield_names = grep {; - no strict 'refs'; - !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); - } @subfield_names; my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } # Now save all the subfields my $sv; @@ -595,10 +523,10 @@ sub B::HV::bytecode { } ldsv($ix); for ($i = 0; $i < @contents; $i += 2) { - asmf("newpv %s\nhv_store %d\n", + printf("newpv %s\nhv_store %d\n", pvstring($contents[$i]), $ixes[$i / 2]); } - asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; + printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; } } @@ -623,26 +551,22 @@ sub B::AV::bytecode { # create an AV with NEWSV and SvUPGRADE rather than doing newAV # which is what sets AvMAX and AvFILL. ldsv($ix); - asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST - asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; + printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; if ($fill > -1) { my $elix; foreach $elix (@ixes) { - asm "av_push $elix\n"; + print "av_push $elix\n"; } } else { if ($max > -1) { - asm "av_extend $max\n"; + print "av_extend $max\n"; } } - asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above } sub B::CV::bytecode { my $cv = shift; return if saved($cv); - return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); - my $fileix = pvix($cv->FILE); my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; @@ -657,10 +581,10 @@ sub B::CV::bytecode { # Reset sv register for $cv (since above ->objix calls stomped on it) ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; - asmf "xcv_file %d\n", $fileix; + 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 @@ -683,17 +607,17 @@ sub B::IO::bytecode { $io->B::PVMG::bytecode; ldsv($ix); - asm "xio_top_gv $top_gvix\n"; - asm "xio_fmt_gv $fmt_gvix\n"; - asm "xio_bottom_gv $bottom_gvix\n"; + print "xio_top_gv $top_gvix\n"; + print "xio_fmt_gv $fmt_gvix\n"; + print "xio_bottom_gv $bottom_gvix\n"; my $field; foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); + printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); } foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - asmf "xio_%s %d\n", lc($field), $io->$field(); + printf "xio_%s %d\n", lc($field), $io->$field(); } - asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; + printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; $top_gv->bytecode; $fmt_gv->bytecode; $bottom_gv->bytecode; @@ -704,7 +628,8 @@ sub B::SPECIAL::bytecode { } sub bytecompile_object { - for my $sv (@_) { + my $sv; + foreach $sv (@_) { svref_2object($sv)->bytecode; } } @@ -712,7 +637,7 @@ sub bytecompile_object { sub B::GV::bytecodecv { my $gv = shift; my $cv = $gv->CV; - if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { + if ($$cv && !saved($cv)) { if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); @@ -721,66 +646,43 @@ sub B::GV::bytecodecv { } } -sub save_call_queues { - if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls - for my $cv (begin_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - my $op = $cv->START; -OPLOOP: - while ($$op) { - if ($op->name eq 'require') { # save any BEGIN that does a require - $cv->bytecode; - asmf "push_begin %d\n", $cv->objix; - last OPLOOP; - } - $op = $op->next; - } - } - } - if (init_av()->isa("B::AV")) { - for my $cv (init_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - $cv->bytecode; - asmf "push_init %d\n", $cv->objix; - } - } - if (end_av()->isa("B::AV")) { - for my $cv (end_av()->ARRAY) { - next unless grep { $_ eq $cv->STASH->NAME; } @packages; - $cv->bytecode; - asmf "push_end %d\n", $cv->objix; - } - } -} - -sub symwalk { - no strict 'refs'; - my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; - if (grep { /^$_[0]/; } @packages) { - walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); - } - warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") - if $debug_bc; - $ok; -} - sub bytecompile_main { my $curpad = (comppadlist->ARRAY)[1]; my $curpadix = $curpad->objix; $curpad->bytecode; - save_call_queues(); - walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; + walkoptree(main_root, "bytecode"); warn "done main program, now walking symbol table\n" if $debug_bc; - if (@packages) { - no strict qw(refs); - walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); - } else { - die "No packages requested for compilation!\n"; + my ($pack, %exclude); + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars + FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol warnings + attributes File::Spec SelectSaver blib Cwd)) + { + $exclude{$pack."::"} = 1; + } + no strict qw(vars refs); + walksymtable(\%{"main::"}, "bytecodecv", sub { + warn "considering $_[0]\n" if $debug_bc; + return !defined($exclude{$_[0]}); + }); + if (!$module_only) { + printf "main_root %d\n", main_root->objix; + printf "main_start %d\n", main_start->objix; + printf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? } - asmf "main_root %d\n", main_root->objix; - asmf "main_start %d\n", main_start->objix; - asmf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? +} + +sub prepare_assemble { + my $newfh = IO::File->new_tmpfile; + select($newfh); + binmode $newfh; + return $newfh; +} + +sub do_assemble { + my $fh = shift; + seek($fh, 0, 0); # rewind the temporary file + assemble_fh($fh, sub { print OUT @_ }); } sub compile { @@ -788,7 +690,7 @@ sub compile { my ($option, $opt, $arg); open(OUT, ">&STDOUT"); binmode OUT; - select OUT; + select(OUT); OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { @@ -825,6 +727,8 @@ sub compile { } } elsif ($opt eq "v") { $verbose = 1; + } elsif ($opt eq "m") { + $module_only = 1; } elsif ($opt eq "S") { $no_assemble = 1; } elsif ($opt eq "f") { @@ -843,6 +747,9 @@ sub compile { foreach $ref (values %optimise) { $$ref = 0; } + if ($arg >= 6) { + $strip_syntree = 1; + } if ($arg >= 2) { $bypass_nullops = 1; } @@ -850,30 +757,28 @@ sub compile { $compress_nullops = 1; $omit_seq = 1; } - } elsif ($opt eq "P") { - $arg ||= shift @options; - push @packages, $arg; - } else { - warn qq(ignoring unknown option "$opt$arg"\n); } } - if (! @packages) { - warn "No package specified for compilation, assuming main::\n"; - @packages = qw(main); - } if (@options) { - die "Extraneous options left on B::Bytecode commandline: @options\n"; + return sub { + my $objname; + my $newfh; + $newfh = prepare_assemble() unless $no_assemble; + foreach $objname (@options) { + eval "bytecompile_object(\\$objname)"; + } + do_assemble($newfh) unless $no_assemble; + } } else { - return sub { - newasm(\&apr) unless $no_assemble; + return sub { + my $newfh; + $newfh = prepare_assemble() unless $no_assemble; bytecompile_main(); - endasm() unless $no_assemble; - }; + do_assemble($newfh) unless $no_assemble; + } } } -sub apr { print @_; } - 1; __END__ @@ -943,11 +848,18 @@ which is only used by perl's internal compiler. If op->op_next ever points to a NULLOP, replaces the op_next field with the first non-NULLOP in the path of execution. +=item B<-fstrip-syntax-tree> + +Leaves out code to fill in the pointers which link the internal syntax +tree together. They're not needed at run-time but leaving them out +will make it impossible to recompile or disassemble the resulting +program. It will also stop C<goto label> statements from working. + =item B<-On> Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. -B<-O2> adds B<-fbypass-nullops>. +B<-O6> adds B<-fstrip-syntax-tree>. =item B<-D> @@ -975,33 +887,33 @@ Prints each CV taken from the final symbol tree walk. Output (bytecode) assembler source rather than piping it through the assembler and outputting bytecode. -=item B<-Ppackage> - -Stores package in the output. - +=item B<-m> + +Compile as a module rather than a standalone program. Currently this +just means that the bytecodes for initialising C<main_start>, +C<main_root> and C<curpad> are omitted. + =back =head1 EXAMPLES - perl -MO=Bytecode,-O6,-ofoo.plc,-Pmain foo.pl + perl -MO=Bytecode,-O6,-o,foo.plc foo.pl - perl -MO=Bytecode,-S,-Pmain foo.pl > foo.S + perl -MO=Bytecode,-S foo.pl > foo.S assemble foo.S > foo.plc Note that C<assemble> lives in the C<B> subdirectory of your perl library directory. The utility called perlcc may also be used to help make use of this compiler. - perl -MO=Bytecode,-PFoo,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm =head1 BUGS -Output is still huge and there are still occasional crashes during -either compilation or ByteLoading. Current status: experimental. +Plenty. Current status: experimental. -=head1 AUTHORS +=head1 AUTHOR Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> -Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/ext/B/O.pm b/ext/B/O.pm index 2ef91edbd9..352f8d4206 100644 --- a/ext/B/O.pm +++ b/ext/B/O.pm @@ -1,5 +1,5 @@ package O; -use B qw(minus_c save_BEGINs); +use B qw(minus_c); use Carp; sub import { @@ -11,7 +11,6 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; - save_BEGINs; eval 'CHECK { &$compilesub() }'; } else { die $compilesub; diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index a2d400ae41..80ef936fce 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -8,11 +8,8 @@ open(OUT,">$out") || die "Cannot open $file:$!"; print "Extracting $out...\n"; foreach my $const (qw(AVf_REAL HEf_SVKEY - SVf_READONLY SVTYPEMASK - GVf_IMPORTED_AV GVf_IMPORTED_HV - GVf_IMPORTED_SV GVf_IMPORTED_CV - SVf_IOK SVf_IVisUV SVf_NOK SVf_POK - SVf_ROK SVp_IOK SVp_POK SVp_NOK)) + SVf_IOK SVf_IVisUV SVf_NOK SVf_POK + SVf_ROK SVp_IOK SVp_POK )) { doconst($const); } diff --git a/ext/ByteLoader/ByteLoader.pm b/ext/ByteLoader/ByteLoader.pm index 9c8c84d677..286d74697e 100644 --- a/ext/ByteLoader/ByteLoader.pm +++ b/ext/ByteLoader/ByteLoader.pm @@ -2,7 +2,7 @@ package ByteLoader; use XSLoader (); -$VERSION = 0.04; +$VERSION = 0.03; XSLoader::load 'ByteLoader', $VERSION; @@ -17,10 +17,10 @@ ByteLoader - load byte compiled perl code =head1 SYNOPSIS - use ByteLoader 0.04; + use ByteLoader 0.03; <byte code> - use ByteLoader 0.04; + use ByteLoader 0.03; <byte code> =head1 DESCRIPTION diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs index d3b435199e..7c3746bba7 100644 --- a/ext/ByteLoader/ByteLoader.xs +++ b/ext/ByteLoader/ByteLoader.xs @@ -4,74 +4,31 @@ #include "XSUB.h" #include "byterun.h" -/* Something arbitary for a buffer size */ -#define BYTELOADER_BUFFER 8096 - -int -bl_getc(struct byteloader_fdata *data) +static int +xgetc(PerlIO *io) { dTHX; - if (SvCUR(data->datasv) <= data->next_out) { - int result; - /* Run out of buffered data, so attempt to read some more */ - *(SvPV_nolen (data->datasv)) = '\0'; - SvCUR_set (data->datasv, 0); - data->next_out = 0; - result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); - - /* Filter returned error, or we got EOF and no data, then return EOF. - Not sure if filter is allowed to return EOF and add data simultaneously - Think not, but will bullet proof against it. */ - if (result < 0 || SvCUR(data->datasv) == 0) - return EOF; - /* Else there must be at least one byte present, which is good enough */ - } - - return *((char *) SvPV_nolen (data->datasv) + data->next_out++); + return PerlIO_getc(io); } -int -bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) +static int +xfread(char *buf, size_t size, size_t n, PerlIO *io) { dTHX; - char *start; - STRLEN len; - size_t wanted = size * n; - - start = SvPV (data->datasv, len); - if (len < (data->next_out + wanted)) { - int result; - - /* Shuffle data to start of buffer */ - len -= data->next_out; - if (len) { - memmove (start, start + data->next_out, len + 1); - SvCUR_set (data->datasv, len); - } else { - *start = '\0'; /* Avoid call to memmove. */ - SvCUR_set (data->datasv, 0); - } - data->next_out = 0; - - /* Attempt to read more data. */ - do { - result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); - - start = SvPV (data->datasv, len); - } while (result > 0 && len < wanted); - /* Loop while not (EOF || error) and short reads */ - - /* If not enough data read, truncate copy */ - if (wanted > len) - wanted = len; - } + int i = PerlIO_read(io, buf, n * size); + if (i > 0) + i /= size; + return i; +} - if (wanted > 0) { - memcpy (buf, start + data->next_out, wanted); - data->next_out += wanted; - wanted /= size; - } - return (int) wanted; +static void +freadpv(U32 len, void *data, XPV *pv) +{ + dTHX; + New(666, pv->xpv_pv, len, char); + PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len); + pv->xpv_len = len; + pv->xpv_cur = len - 1; } static I32 @@ -80,20 +37,14 @@ byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) dTHR; OP *saveroot = PL_main_root; OP *savestart = PL_main_start; - struct byteloader_state bstate; - struct byteloader_fdata data; - - data.next_out = 0; - data.datasv = FILTER_DATA(idx); - data.idx = idx; + struct bytestream bs; - bstate.bs_fdata = &data; - bstate.bs_obj_list = Null(void**); - bstate.bs_obj_list_fill = -1; - bstate.bs_sv = Nullsv; - bstate.bs_iv_overflows = 0; + bs.data = PL_rsfp; + bs.pfgetc = (int(*) (void*))xgetc; + bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; + bs.pfreadpv = freadpv; - byterun(aTHXo_ &bstate); + byterun(aTHXo_ bs); if (PL_in_eval) { OP *o; @@ -119,12 +70,8 @@ PROTOTYPES: ENABLE void import(...) - PREINIT: - SV *sv = newSVpvn ("", 0); PPCODE: - if (!sv) - croak ("Could not allocate ByteLoader buffers"); - filter_add(byteloader_filter, sv); + filter_add(byteloader_filter, NULL); void unimport(...) diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h index 296c2afd65..1621fed4eb 100644 --- a/ext/ByteLoader/bytecode.h +++ b/ext/ByteLoader/bytecode.h @@ -5,33 +5,29 @@ typedef char *op_tr_array; typedef int comment_t; typedef SV *svindex; typedef OP *opindex; -typedef char *pvindex; typedef IV IV64; #define BGET_FREAD(argp, len, nelem) \ - bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem)) -#define BGET_FGETC() bl_getc(bstate->bs_fdata) + bs.pfread((char*)(argp),(len),(nelem),bs.data) +#define BGET_FGETC() bs.pfgetc(bs.data) #define BGET_U32(arg) \ - BGET_FREAD(&arg, sizeof(U32), 1) + BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) #define BGET_I32(arg) \ - BGET_FREAD(&arg, sizeof(I32), 1) + BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg) #define BGET_U16(arg) \ - BGET_FREAD(&arg, sizeof(U16), 1) + BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg) #define BGET_U8(arg) arg = BGET_FGETC() -#define BGET_PV(arg) STMT_START { \ - BGET_U32(arg); \ - if (arg) { \ - New(666, bstate->bs_pv.xpv_pv, arg, char); \ - bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \ - bstate->bs_pv.xpv_len = arg; \ - bstate->bs_pv.xpv_cur = arg - 1; \ - } else { \ - bstate->bs_pv.xpv_pv = 0; \ - bstate->bs_pv.xpv_len = 0; \ - bstate->bs_pv.xpv_cur = 0; \ - } \ +#define BGET_PV(arg) STMT_START { \ + BGET_U32(arg); \ + if (arg) \ + bs.pfreadpv(arg, bs.data, &bytecode_pv); \ + else { \ + bytecode_pv.xpv_pv = 0; \ + bytecode_pv.xpv_len = 0; \ + bytecode_pv.xpv_cur = 0; \ + } \ } STMT_END #ifdef BYTELOADER_LOG_COMMENTS @@ -67,20 +63,22 @@ typedef IV IV64; arg = (I32)lo; \ } \ else { \ - bstate->bs_iv_overflows++; \ + bytecode_iv_overflows++; \ arg = 0; \ } \ } STMT_END -#define BGET_op_tr_array(arg) do { \ - unsigned short *ary; \ - int i; \ - New(666, ary, 256, unsigned short); \ - BGET_FREAD(ary, sizeof(unsigned short), 256); \ - arg = (char *) ary; \ +#define BGET_op_tr_array(arg) do { \ + unsigned short *ary; \ + int i; \ + New(666, ary, 256, unsigned short); \ + BGET_FREAD(ary, 256, 2); \ + for (i = 0; i < 256; i++) \ + ary[i] = PerlSock_ntohs(ary[i]); \ + arg = (char *) ary; \ } while (0) -#define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv +#define BGET_pvcontents(arg) arg = bytecode_pv.xpv_pv #define BGET_strconst(arg) STMT_START { \ for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ arg = PL_tokenbuf; \ @@ -93,21 +91,14 @@ typedef IV IV64; } STMT_END #define BGET_objindex(arg, type) STMT_START { \ + U32 ix; \ BGET_U32(ix); \ - arg = (type)bstate->bs_obj_list[ix]; \ + arg = (type)bytecode_obj_list[ix]; \ } STMT_END #define BGET_svindex(arg) BGET_objindex(arg, svindex) #define BGET_opindex(arg) BGET_objindex(arg, opindex) -#define BGET_pvindex(arg) STMT_START { \ - BGET_objindex(arg, pvindex); \ - arg = arg ? savepv(arg) : arg; \ - } STMT_END #define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg] -#define BSET_stpv(pv, arg) STMT_START { \ - BSET_OBJ_STORE(pv, arg); \ - SAVEFREEPV(pv); \ - } STMT_END #define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg #define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg @@ -119,29 +110,23 @@ typedef IV IV64; #define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV) #define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE) #define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) -#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur +#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bytecode_pv.xpv_cur #define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) #define BSET_xpv(sv) do { \ - SvPV_set(sv, bstate->bs_pv.xpv_pv); \ - SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ - SvLEN_set(sv, bstate->bs_pv.xpv_len); \ + SvPV_set(sv, bytecode_pv.xpv_pv); \ + SvCUR_set(sv, bytecode_pv.xpv_cur); \ + SvLEN_set(sv, bytecode_pv.xpv_len); \ } while (0) #define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) #define BSET_av_push(sv, arg) av_push((AV*)sv, arg) #define BSET_hv_store(sv, arg) \ - hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0) + hv_store((HV*)sv, bytecode_pv.xpv_pv, bytecode_pv.xpv_cur, arg, 0) #define BSET_pv_free(pv) Safefree(pv.xpv_pv) #define BSET_pregcomp(o, arg) \ ((PMOP*)o)->op_pmregexp = arg ? \ - CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0 -#define BSET_newsv(sv, arg) \ - STMT_START { \ - sv = (arg == SVt_PVAV ? (SV*)newAV() : \ - arg == SVt_PVHV ? (SV*)newHV() : \ - NEWSV(666,0)); \ - SvUPGRADE(sv, arg); \ - } STMT_END + CALLREGCOMP(aTHX_ arg, arg + bytecode_pv.xpv_cur, ((PMOP*)o)) : 0 +#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg) #define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \ memzero((char*)o,optype_size[arg])) #define BSET_newopn(o, arg) STMT_START { \ @@ -150,10 +135,7 @@ typedef IV IV64; oldop->op_next = o; \ } STMT_END -#define BSET_ret(foo) STMT_START { \ - Safefree(bstate->bs_obj_list); \ - return; \ - } STMT_END +#define BSET_ret(foo) return /* * Kludge special-case workaround for OP_MAPSTART @@ -170,85 +152,10 @@ typedef IV IV64; PL_comppad = (AV *)arg; \ pad = AvARRAY(arg); \ } STMT_END -/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() - -- BKS 6-2-2000 */ #define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) #define BSET_cop_line(cop, arg) CopLINE_set(cop,arg) #define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) -/* this is simply stolen from the code in newATTRSUB() */ -#define BSET_push_begin(ary,cv) \ - STMT_START { \ - I32 oldscope = PL_scopestack_ix; \ - ENTER; \ - SAVECOPFILE(&PL_compiling); \ - SAVECOPLINE(&PL_compiling); \ - save_svref(&PL_rs); \ - sv_setsv(PL_rs, PL_nrs); \ - if (!PL_beginav) \ - PL_beginav = newAV(); \ - av_push(PL_beginav, cv); \ - call_list(oldscope, PL_beginav); \ - PL_curcop = &PL_compiling; \ - PL_compiling.op_private = PL_hints; \ - LEAVE; \ - } STMT_END -#define BSET_push_init(ary,cv) \ - STMT_START { \ - av_unshift((PL_initav ? PL_initav : (PL_initav = newAV(), PL_initav)), 1); \ - av_store(PL_initav, 0, cv); \ - } STMT_END -#define BSET_push_end(ary,cv) \ - STMT_START { \ - av_unshift((PL_endav ? PL_endav : (PL_endav = newAV(), PL_endav)), 1); \ - av_store(PL_endav, 0, cv); \ - } STMT_END -#define BSET_OBJ_STORE(obj, ix) \ - (I32)ix > bstate->bs_obj_list_fill ? \ - bset_obj_store(aTHXo_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj) - -/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about - * what version of Perl it's being called under, it should do a 'require 5.6.0' or - * equivalent. However, since the header includes checks requiring an exact match in - * ByteLoader versions (we can't guarantee forward compatibility), you don't - * need to specify one: - * use ByteLoader; - * is all you need. - * -- BKS, June 2000 -*/ - -#define HEADER_FAIL(f, arg1, arg2) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2) - -#define BYTECODE_HEADER_CHECK \ - STMT_START { \ - U32 sz = 0; \ - strconst str; \ - \ - BGET_U32(sz); /* Magic: 'PLBC' */ \ - if (sz != 0x43424c50) { \ - HEADER_FAIL("bad magic (want 0x43424c50, got %#x)", sz, 0); \ - } \ - BGET_strconst(str); /* archname */ \ - if (strNE(str, ARCHNAME)) { \ - HEADER_FAIL("wrong architecture (want %s, you have %s)",str,ARCHNAME); \ - } \ - BGET_strconst(str); /* ByteLoader version */ \ - if (strNE(str, VERSION)) { \ - HEADER_FAIL("mismatched ByteLoader versions (want %s, you have %s)", \ - str, VERSION); \ - } \ - BGET_U32(sz); /* ivsize */ \ - if (sz != IVSIZE) { \ - HEADER_FAIL("different IVSIZE", 0, 0); \ - } \ - BGET_U32(sz); /* ptrsize */ \ - if (sz != PTRSIZE) { \ - HEADER_FAIL("different PTRSIZE", 0, 0); \ - } \ - BGET_strconst(str); /* byteorder */ \ - if (strNE(str, STRINGIFY(BYTEORDER))) { \ - HEADER_FAIL("different byteorder", 0, 0); \ - } \ - Safefree(str); \ - } STMT_END +#define BSET_OBJ_STORE(obj, ix) \ + (I32)ix > bytecode_obj_list_fill ? \ + bset_obj_store(aTHXo_ obj, (I32)ix) : (bytecode_obj_list[ix] = obj) diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c index 19f1f6b44c..a1044ab2c0 100644 --- a/ext/ByteLoader/byterun.c +++ b/ext/ByteLoader/byterun.c @@ -26,7 +26,7 @@ #include "bytecode.h" -static const int optype_size[] = { +static int optype_size[] = { sizeof(OP), sizeof(UNOP), sizeof(BINOP), @@ -40,35 +40,38 @@ static const int optype_size[] = { sizeof(COP) }; +static SV *specialsv_list[4]; + +static int bytecode_iv_overflows = 0; +static SV *bytecode_sv; +static XPV bytecode_pv; +static void **bytecode_obj_list; +static I32 bytecode_obj_list_fill = -1; + void * -bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix) +bset_obj_store(pTHXo_ void *obj, I32 ix) { - if (ix > bstate->bs_obj_list_fill) { - Renew(bstate->bs_obj_list, ix + 32, void*); - bstate->bs_obj_list_fill = ix + 31; + if (ix > bytecode_obj_list_fill) { + if (bytecode_obj_list_fill == -1) + New(666, bytecode_obj_list, ix + 1, void*); + else + Renew(bytecode_obj_list, ix + 1, void*); + bytecode_obj_list_fill = ix; } - bstate->bs_obj_list[ix] = obj; + bytecode_obj_list[ix] = obj; return obj; } void -byterun(pTHXo_ register struct byteloader_state *bstate) +byterun(pTHXo_ struct bytestream bs) { dTHR; - register int insn; - U32 ix; - SV *specialsv_list[6]; - - BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ - New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ - bstate->bs_obj_list_fill = 31; + int insn; specialsv_list[0] = Nullsv; specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = pWARN_ALL; - specialsv_list[5] = pWARN_NONE; while ((insn = BGET_FGETC()) != EOF) { switch (insn) { @@ -92,7 +95,7 @@ byterun(pTHXo_ register struct byteloader_state *bstate) { svindex arg; BGET_svindex(arg); - bstate->bs_sv = arg; + bytecode_sv = arg; break; } case INSN_LDOP: /* 2 */ @@ -106,7 +109,7 @@ byterun(pTHXo_ register struct byteloader_state *bstate) { U32 arg; BGET_U32(arg); - BSET_OBJ_STORE(bstate->bs_sv, arg); + BSET_OBJ_STORE(bytecode_sv, arg); break; } case INSN_STOP: /* 4 */ @@ -116,806 +119,778 @@ byterun(pTHXo_ register struct byteloader_state *bstate) BSET_OBJ_STORE(PL_op, arg); break; } - case INSN_STPV: /* 5 */ - { - U32 arg; - BGET_U32(arg); - BSET_stpv(bstate->bs_pv.xpv_pv, arg); - break; - } - case INSN_LDSPECSV: /* 6 */ + case INSN_LDSPECSV: /* 5 */ { U8 arg; BGET_U8(arg); - BSET_ldspecsv(bstate->bs_sv, arg); + BSET_ldspecsv(bytecode_sv, arg); break; } - case INSN_NEWSV: /* 7 */ + case INSN_NEWSV: /* 6 */ { U8 arg; BGET_U8(arg); - BSET_newsv(bstate->bs_sv, arg); + BSET_newsv(bytecode_sv, arg); break; } - case INSN_NEWOP: /* 8 */ + case INSN_NEWOP: /* 7 */ { U8 arg; BGET_U8(arg); BSET_newop(PL_op, arg); break; } - case INSN_NEWOPN: /* 9 */ + case INSN_NEWOPN: /* 8 */ { U8 arg; BGET_U8(arg); BSET_newopn(PL_op, arg); break; } - case INSN_NEWPV: /* 11 */ + case INSN_NEWPV: /* 9 */ { PV arg; BGET_PV(arg); break; } - case INSN_PV_CUR: /* 12 */ + case INSN_PV_CUR: /* 11 */ { STRLEN arg; BGET_U32(arg); - bstate->bs_pv.xpv_cur = arg; + bytecode_pv.xpv_cur = arg; break; } - case INSN_PV_FREE: /* 13 */ + case INSN_PV_FREE: /* 12 */ { - BSET_pv_free(bstate->bs_pv); + BSET_pv_free(bytecode_pv); break; } - case INSN_SV_UPGRADE: /* 14 */ + case INSN_SV_UPGRADE: /* 13 */ { char arg; BGET_U8(arg); - BSET_sv_upgrade(bstate->bs_sv, arg); + BSET_sv_upgrade(bytecode_sv, arg); break; } - case INSN_SV_REFCNT: /* 15 */ + case INSN_SV_REFCNT: /* 14 */ { U32 arg; BGET_U32(arg); - SvREFCNT(bstate->bs_sv) = arg; + SvREFCNT(bytecode_sv) = arg; break; } - case INSN_SV_REFCNT_ADD: /* 16 */ + case INSN_SV_REFCNT_ADD: /* 15 */ { I32 arg; BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(bstate->bs_sv), arg); + BSET_sv_refcnt_add(SvREFCNT(bytecode_sv), arg); break; } - case INSN_SV_FLAGS: /* 17 */ + case INSN_SV_FLAGS: /* 16 */ { U32 arg; BGET_U32(arg); - SvFLAGS(bstate->bs_sv) = arg; + SvFLAGS(bytecode_sv) = arg; break; } - case INSN_XRV: /* 18 */ + case INSN_XRV: /* 17 */ { svindex arg; BGET_svindex(arg); - SvRV(bstate->bs_sv) = arg; + SvRV(bytecode_sv) = arg; break; } - case INSN_XPV: /* 19 */ + case INSN_XPV: /* 18 */ { - BSET_xpv(bstate->bs_sv); + BSET_xpv(bytecode_sv); break; } - case INSN_XIV32: /* 20 */ + case INSN_XIV32: /* 19 */ { I32 arg; BGET_I32(arg); - SvIVX(bstate->bs_sv) = arg; + SvIVX(bytecode_sv) = arg; break; } - case INSN_XIV64: /* 21 */ + case INSN_XIV64: /* 20 */ { IV64 arg; BGET_IV64(arg); - SvIVX(bstate->bs_sv) = arg; + SvIVX(bytecode_sv) = arg; break; } - case INSN_XNV: /* 22 */ + case INSN_XNV: /* 21 */ { NV arg; BGET_NV(arg); - SvNVX(bstate->bs_sv) = arg; + SvNVX(bytecode_sv) = arg; break; } - case INSN_XLV_TARGOFF: /* 23 */ + case INSN_XLV_TARGOFF: /* 22 */ { STRLEN arg; BGET_U32(arg); - LvTARGOFF(bstate->bs_sv) = arg; + LvTARGOFF(bytecode_sv) = arg; break; } - case INSN_XLV_TARGLEN: /* 24 */ + case INSN_XLV_TARGLEN: /* 23 */ { STRLEN arg; BGET_U32(arg); - LvTARGLEN(bstate->bs_sv) = arg; + LvTARGLEN(bytecode_sv) = arg; break; } - case INSN_XLV_TARG: /* 25 */ + case INSN_XLV_TARG: /* 24 */ { svindex arg; BGET_svindex(arg); - LvTARG(bstate->bs_sv) = arg; + LvTARG(bytecode_sv) = arg; break; } - case INSN_XLV_TYPE: /* 26 */ + case INSN_XLV_TYPE: /* 25 */ { char arg; BGET_U8(arg); - LvTYPE(bstate->bs_sv) = arg; + LvTYPE(bytecode_sv) = arg; break; } - case INSN_XBM_USEFUL: /* 27 */ + case INSN_XBM_USEFUL: /* 26 */ { I32 arg; BGET_I32(arg); - BmUSEFUL(bstate->bs_sv) = arg; + BmUSEFUL(bytecode_sv) = arg; break; } - case INSN_XBM_PREVIOUS: /* 28 */ + case INSN_XBM_PREVIOUS: /* 27 */ { U16 arg; BGET_U16(arg); - BmPREVIOUS(bstate->bs_sv) = arg; + BmPREVIOUS(bytecode_sv) = arg; break; } - case INSN_XBM_RARE: /* 29 */ + case INSN_XBM_RARE: /* 28 */ { U8 arg; BGET_U8(arg); - BmRARE(bstate->bs_sv) = arg; + BmRARE(bytecode_sv) = arg; break; } - case INSN_XFM_LINES: /* 30 */ + case INSN_XFM_LINES: /* 29 */ { I32 arg; BGET_I32(arg); - FmLINES(bstate->bs_sv) = arg; + FmLINES(bytecode_sv) = arg; break; } - case INSN_XIO_LINES: /* 31 */ + case INSN_XIO_LINES: /* 30 */ { long arg; BGET_I32(arg); - IoLINES(bstate->bs_sv) = arg; + IoLINES(bytecode_sv) = arg; break; } - case INSN_XIO_PAGE: /* 32 */ + case INSN_XIO_PAGE: /* 31 */ { long arg; BGET_I32(arg); - IoPAGE(bstate->bs_sv) = arg; + IoPAGE(bytecode_sv) = arg; break; } - case INSN_XIO_PAGE_LEN: /* 33 */ + case INSN_XIO_PAGE_LEN: /* 32 */ { long arg; BGET_I32(arg); - IoPAGE_LEN(bstate->bs_sv) = arg; + IoPAGE_LEN(bytecode_sv) = arg; break; } - case INSN_XIO_LINES_LEFT: /* 34 */ + case INSN_XIO_LINES_LEFT: /* 33 */ { long arg; BGET_I32(arg); - IoLINES_LEFT(bstate->bs_sv) = arg; + IoLINES_LEFT(bytecode_sv) = arg; break; } - case INSN_XIO_TOP_NAME: /* 36 */ + case INSN_XIO_TOP_NAME: /* 34 */ { pvcontents arg; BGET_pvcontents(arg); - IoTOP_NAME(bstate->bs_sv) = arg; + IoTOP_NAME(bytecode_sv) = arg; break; } - case INSN_XIO_TOP_GV: /* 37 */ + case INSN_XIO_TOP_GV: /* 36 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoTOP_GV(bstate->bs_sv) = arg; + *(SV**)&IoTOP_GV(bytecode_sv) = arg; break; } - case INSN_XIO_FMT_NAME: /* 38 */ + case INSN_XIO_FMT_NAME: /* 37 */ { pvcontents arg; BGET_pvcontents(arg); - IoFMT_NAME(bstate->bs_sv) = arg; + IoFMT_NAME(bytecode_sv) = arg; break; } - case INSN_XIO_FMT_GV: /* 39 */ + case INSN_XIO_FMT_GV: /* 38 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoFMT_GV(bstate->bs_sv) = arg; + *(SV**)&IoFMT_GV(bytecode_sv) = arg; break; } - case INSN_XIO_BOTTOM_NAME: /* 40 */ + case INSN_XIO_BOTTOM_NAME: /* 39 */ { pvcontents arg; BGET_pvcontents(arg); - IoBOTTOM_NAME(bstate->bs_sv) = arg; + IoBOTTOM_NAME(bytecode_sv) = arg; break; } - case INSN_XIO_BOTTOM_GV: /* 41 */ + case INSN_XIO_BOTTOM_GV: /* 40 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(bstate->bs_sv) = arg; + *(SV**)&IoBOTTOM_GV(bytecode_sv) = arg; break; } - case INSN_XIO_SUBPROCESS: /* 42 */ + case INSN_XIO_SUBPROCESS: /* 41 */ { short arg; BGET_U16(arg); - IoSUBPROCESS(bstate->bs_sv) = arg; + IoSUBPROCESS(bytecode_sv) = arg; break; } - case INSN_XIO_TYPE: /* 43 */ + case INSN_XIO_TYPE: /* 42 */ { char arg; BGET_U8(arg); - IoTYPE(bstate->bs_sv) = arg; + IoTYPE(bytecode_sv) = arg; break; } - case INSN_XIO_FLAGS: /* 44 */ + case INSN_XIO_FLAGS: /* 43 */ { char arg; BGET_U8(arg); - IoFLAGS(bstate->bs_sv) = arg; + IoFLAGS(bytecode_sv) = arg; break; } - case INSN_XCV_STASH: /* 45 */ + case INSN_XCV_STASH: /* 44 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvSTASH(bstate->bs_sv) = arg; + *(SV**)&CvSTASH(bytecode_sv) = arg; break; } - case INSN_XCV_START: /* 46 */ + case INSN_XCV_START: /* 45 */ { opindex arg; BGET_opindex(arg); - CvSTART(bstate->bs_sv) = arg; + CvSTART(bytecode_sv) = arg; break; } - case INSN_XCV_ROOT: /* 47 */ + case INSN_XCV_ROOT: /* 46 */ { opindex arg; BGET_opindex(arg); - CvROOT(bstate->bs_sv) = arg; + CvROOT(bytecode_sv) = arg; break; } - case INSN_XCV_GV: /* 48 */ + case INSN_XCV_GV: /* 47 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvGV(bstate->bs_sv) = arg; + *(SV**)&CvGV(bytecode_sv) = arg; break; } - case INSN_XCV_FILE: /* 49 */ + case INSN_XCV_FILE: /* 48 */ { - pvindex arg; - BGET_pvindex(arg); - CvFILE(bstate->bs_sv) = arg; + pvcontents arg; + BGET_pvcontents(arg); + CvFILE(bytecode_sv) = arg; break; } - case INSN_XCV_DEPTH: /* 50 */ + case INSN_XCV_DEPTH: /* 49 */ { long arg; BGET_I32(arg); - CvDEPTH(bstate->bs_sv) = arg; + CvDEPTH(bytecode_sv) = arg; break; } - case INSN_XCV_PADLIST: /* 51 */ + case INSN_XCV_PADLIST: /* 50 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvPADLIST(bstate->bs_sv) = arg; + *(SV**)&CvPADLIST(bytecode_sv) = arg; break; } - case INSN_XCV_OUTSIDE: /* 52 */ + case INSN_XCV_OUTSIDE: /* 51 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvOUTSIDE(bstate->bs_sv) = arg; + *(SV**)&CvOUTSIDE(bytecode_sv) = arg; break; } - case INSN_XCV_FLAGS: /* 53 */ + case INSN_XCV_FLAGS: /* 52 */ { U16 arg; BGET_U16(arg); - CvFLAGS(bstate->bs_sv) = arg; + CvFLAGS(bytecode_sv) = arg; break; } - case INSN_AV_EXTEND: /* 54 */ + case INSN_AV_EXTEND: /* 53 */ { SSize_t arg; BGET_I32(arg); - BSET_av_extend(bstate->bs_sv, arg); + BSET_av_extend(bytecode_sv, arg); break; } - case INSN_AV_PUSH: /* 55 */ + case INSN_AV_PUSH: /* 54 */ { svindex arg; BGET_svindex(arg); - BSET_av_push(bstate->bs_sv, arg); + BSET_av_push(bytecode_sv, arg); break; } - case INSN_XAV_FILL: /* 56 */ + case INSN_XAV_FILL: /* 55 */ { SSize_t arg; BGET_I32(arg); - AvFILLp(bstate->bs_sv) = arg; + AvFILLp(bytecode_sv) = arg; break; } - case INSN_XAV_MAX: /* 57 */ + case INSN_XAV_MAX: /* 56 */ { SSize_t arg; BGET_I32(arg); - AvMAX(bstate->bs_sv) = arg; + AvMAX(bytecode_sv) = arg; break; } - case INSN_XAV_FLAGS: /* 58 */ + case INSN_XAV_FLAGS: /* 57 */ { U8 arg; BGET_U8(arg); - AvFLAGS(bstate->bs_sv) = arg; + AvFLAGS(bytecode_sv) = arg; break; } - case INSN_XHV_RITER: /* 59 */ + case INSN_XHV_RITER: /* 58 */ { I32 arg; BGET_I32(arg); - HvRITER(bstate->bs_sv) = arg; + HvRITER(bytecode_sv) = arg; break; } - case INSN_XHV_NAME: /* 60 */ + case INSN_XHV_NAME: /* 59 */ { pvcontents arg; BGET_pvcontents(arg); - HvNAME(bstate->bs_sv) = arg; + HvNAME(bytecode_sv) = arg; break; } - case INSN_HV_STORE: /* 61 */ + case INSN_HV_STORE: /* 60 */ { svindex arg; BGET_svindex(arg); - BSET_hv_store(bstate->bs_sv, arg); + BSET_hv_store(bytecode_sv, arg); break; } - case INSN_SV_MAGIC: /* 62 */ + case INSN_SV_MAGIC: /* 61 */ { char arg; BGET_U8(arg); - BSET_sv_magic(bstate->bs_sv, arg); + BSET_sv_magic(bytecode_sv, arg); break; } - case INSN_MG_OBJ: /* 63 */ + case INSN_MG_OBJ: /* 62 */ { svindex arg; BGET_svindex(arg); - SvMAGIC(bstate->bs_sv)->mg_obj = arg; + SvMAGIC(bytecode_sv)->mg_obj = arg; break; } - case INSN_MG_PRIVATE: /* 64 */ + case INSN_MG_PRIVATE: /* 63 */ { U16 arg; BGET_U16(arg); - SvMAGIC(bstate->bs_sv)->mg_private = arg; + SvMAGIC(bytecode_sv)->mg_private = arg; break; } - case INSN_MG_FLAGS: /* 65 */ + case INSN_MG_FLAGS: /* 64 */ { U8 arg; BGET_U8(arg); - SvMAGIC(bstate->bs_sv)->mg_flags = arg; + SvMAGIC(bytecode_sv)->mg_flags = arg; break; } - case INSN_MG_PV: /* 66 */ + case INSN_MG_PV: /* 65 */ { pvcontents arg; BGET_pvcontents(arg); - BSET_mg_pv(SvMAGIC(bstate->bs_sv), arg); + BSET_mg_pv(SvMAGIC(bytecode_sv), arg); break; } - case INSN_XMG_STASH: /* 67 */ + case INSN_XMG_STASH: /* 66 */ { svindex arg; BGET_svindex(arg); - *(SV**)&SvSTASH(bstate->bs_sv) = arg; + *(SV**)&SvSTASH(bytecode_sv) = arg; break; } - case INSN_GV_FETCHPV: /* 68 */ + case INSN_GV_FETCHPV: /* 67 */ { strconst arg; BGET_strconst(arg); - BSET_gv_fetchpv(bstate->bs_sv, arg); + BSET_gv_fetchpv(bytecode_sv, arg); break; } - case INSN_GV_STASHPV: /* 69 */ + case INSN_GV_STASHPV: /* 68 */ { strconst arg; BGET_strconst(arg); - BSET_gv_stashpv(bstate->bs_sv, arg); + BSET_gv_stashpv(bytecode_sv, arg); break; } - case INSN_GP_SV: /* 70 */ + case INSN_GP_SV: /* 69 */ { svindex arg; BGET_svindex(arg); - GvSV(bstate->bs_sv) = arg; + GvSV(bytecode_sv) = arg; break; } - case INSN_GP_REFCNT: /* 71 */ + case INSN_GP_REFCNT: /* 70 */ { U32 arg; BGET_U32(arg); - GvREFCNT(bstate->bs_sv) = arg; + GvREFCNT(bytecode_sv) = arg; break; } - case INSN_GP_REFCNT_ADD: /* 72 */ + case INSN_GP_REFCNT_ADD: /* 71 */ { I32 arg; BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(bstate->bs_sv), arg); + BSET_gp_refcnt_add(GvREFCNT(bytecode_sv), arg); break; } - case INSN_GP_AV: /* 73 */ + case INSN_GP_AV: /* 72 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvAV(bstate->bs_sv) = arg; + *(SV**)&GvAV(bytecode_sv) = arg; break; } - case INSN_GP_HV: /* 74 */ + case INSN_GP_HV: /* 73 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvHV(bstate->bs_sv) = arg; + *(SV**)&GvHV(bytecode_sv) = arg; break; } - case INSN_GP_CV: /* 75 */ + case INSN_GP_CV: /* 74 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvCV(bstate->bs_sv) = arg; + *(SV**)&GvCV(bytecode_sv) = arg; break; } - case INSN_GP_FILE: /* 76 */ + case INSN_GP_FILE: /* 75 */ { - pvindex arg; - BGET_pvindex(arg); - GvFILE(bstate->bs_sv) = arg; + pvcontents arg; + BGET_pvcontents(arg); + GvFILE(bytecode_sv) = arg; break; } - case INSN_GP_IO: /* 77 */ + case INSN_GP_IO: /* 76 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvIOp(bstate->bs_sv) = arg; + *(SV**)&GvIOp(bytecode_sv) = arg; break; } - case INSN_GP_FORM: /* 78 */ + case INSN_GP_FORM: /* 77 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvFORM(bstate->bs_sv) = arg; + *(SV**)&GvFORM(bytecode_sv) = arg; break; } - case INSN_GP_CVGEN: /* 79 */ + case INSN_GP_CVGEN: /* 78 */ { U32 arg; BGET_U32(arg); - GvCVGEN(bstate->bs_sv) = arg; + GvCVGEN(bytecode_sv) = arg; break; } - case INSN_GP_LINE: /* 80 */ + case INSN_GP_LINE: /* 79 */ { line_t arg; BGET_U16(arg); - GvLINE(bstate->bs_sv) = arg; + GvLINE(bytecode_sv) = arg; break; } - case INSN_GP_SHARE: /* 81 */ + case INSN_GP_SHARE: /* 80 */ { svindex arg; BGET_svindex(arg); - BSET_gp_share(bstate->bs_sv, arg); + BSET_gp_share(bytecode_sv, arg); break; } - case INSN_XGV_FLAGS: /* 82 */ + case INSN_XGV_FLAGS: /* 81 */ { U8 arg; BGET_U8(arg); - GvFLAGS(bstate->bs_sv) = arg; + GvFLAGS(bytecode_sv) = arg; break; } - case INSN_OP_NEXT: /* 83 */ + case INSN_OP_NEXT: /* 82 */ { opindex arg; BGET_opindex(arg); PL_op->op_next = arg; break; } - case INSN_OP_SIBLING: /* 84 */ + case INSN_OP_SIBLING: /* 83 */ { opindex arg; BGET_opindex(arg); PL_op->op_sibling = arg; break; } - case INSN_OP_PPADDR: /* 85 */ + case INSN_OP_PPADDR: /* 84 */ { strconst arg; BGET_strconst(arg); BSET_op_ppaddr(PL_op->op_ppaddr, arg); break; } - case INSN_OP_TARG: /* 86 */ + case INSN_OP_TARG: /* 85 */ { PADOFFSET arg; BGET_U32(arg); PL_op->op_targ = arg; break; } - case INSN_OP_TYPE: /* 87 */ + case INSN_OP_TYPE: /* 86 */ { OPCODE arg; BGET_U16(arg); BSET_op_type(PL_op, arg); break; } - case INSN_OP_SEQ: /* 88 */ + case INSN_OP_SEQ: /* 87 */ { U16 arg; BGET_U16(arg); PL_op->op_seq = arg; break; } - case INSN_OP_FLAGS: /* 89 */ + case INSN_OP_FLAGS: /* 88 */ { U8 arg; BGET_U8(arg); PL_op->op_flags = arg; break; } - case INSN_OP_PRIVATE: /* 90 */ + case INSN_OP_PRIVATE: /* 89 */ { U8 arg; BGET_U8(arg); PL_op->op_private = arg; break; } - case INSN_OP_FIRST: /* 91 */ + case INSN_OP_FIRST: /* 90 */ { opindex arg; BGET_opindex(arg); cUNOP->op_first = arg; break; } - case INSN_OP_LAST: /* 92 */ + case INSN_OP_LAST: /* 91 */ { opindex arg; BGET_opindex(arg); cBINOP->op_last = arg; break; } - case INSN_OP_OTHER: /* 93 */ + case INSN_OP_OTHER: /* 92 */ { opindex arg; BGET_opindex(arg); cLOGOP->op_other = arg; break; } - case INSN_OP_CHILDREN: /* 94 */ + case INSN_OP_CHILDREN: /* 93 */ { U32 arg; BGET_U32(arg); cLISTOP->op_children = arg; break; } - case INSN_OP_PMREPLROOT: /* 95 */ + case INSN_OP_PMREPLROOT: /* 94 */ { opindex arg; BGET_opindex(arg); cPMOP->op_pmreplroot = arg; break; } - case INSN_OP_PMREPLROOTGV: /* 96 */ + case INSN_OP_PMREPLROOTGV: /* 95 */ { svindex arg; BGET_svindex(arg); *(SV**)&cPMOP->op_pmreplroot = arg; break; } - case INSN_OP_PMREPLSTART: /* 97 */ + case INSN_OP_PMREPLSTART: /* 96 */ { opindex arg; BGET_opindex(arg); cPMOP->op_pmreplstart = arg; break; } - case INSN_OP_PMNEXT: /* 98 */ + case INSN_OP_PMNEXT: /* 97 */ { opindex arg; BGET_opindex(arg); *(OP**)&cPMOP->op_pmnext = arg; break; } - case INSN_PREGCOMP: /* 99 */ + case INSN_PREGCOMP: /* 98 */ { pvcontents arg; BGET_pvcontents(arg); BSET_pregcomp(PL_op, arg); break; } - case INSN_OP_PMFLAGS: /* 100 */ + case INSN_OP_PMFLAGS: /* 99 */ { U16 arg; BGET_U16(arg); cPMOP->op_pmflags = arg; break; } - case INSN_OP_PMPERMFLAGS: /* 101 */ + case INSN_OP_PMPERMFLAGS: /* 100 */ { U16 arg; BGET_U16(arg); cPMOP->op_pmpermflags = arg; break; } - case INSN_OP_SV: /* 102 */ + case INSN_OP_SV: /* 101 */ { svindex arg; BGET_svindex(arg); cSVOP->op_sv = arg; break; } - case INSN_OP_PADIX: /* 103 */ + case INSN_OP_PADIX: /* 102 */ { PADOFFSET arg; BGET_U32(arg); cPADOP->op_padix = arg; break; } - case INSN_OP_PV: /* 104 */ + case INSN_OP_PV: /* 103 */ { pvcontents arg; BGET_pvcontents(arg); cPVOP->op_pv = arg; break; } - case INSN_OP_PV_TR: /* 105 */ + case INSN_OP_PV_TR: /* 104 */ { op_tr_array arg; BGET_op_tr_array(arg); cPVOP->op_pv = arg; break; } - case INSN_OP_REDOOP: /* 106 */ + case INSN_OP_REDOOP: /* 105 */ { opindex arg; BGET_opindex(arg); cLOOP->op_redoop = arg; break; } - case INSN_OP_NEXTOP: /* 107 */ + case INSN_OP_NEXTOP: /* 106 */ { opindex arg; BGET_opindex(arg); cLOOP->op_nextop = arg; break; } - case INSN_OP_LASTOP: /* 108 */ + case INSN_OP_LASTOP: /* 107 */ { opindex arg; BGET_opindex(arg); cLOOP->op_lastop = arg; break; } - case INSN_COP_LABEL: /* 109 */ + case INSN_COP_LABEL: /* 108 */ { - pvindex arg; - BGET_pvindex(arg); + pvcontents arg; + BGET_pvcontents(arg); cCOP->cop_label = arg; break; } - case INSN_COP_STASHPV: /* 110 */ + case INSN_COP_STASHPV: /* 109 */ { - pvindex arg; - BGET_pvindex(arg); + pvcontents arg; + BGET_pvcontents(arg); BSET_cop_stashpv(cCOP, arg); break; } - case INSN_COP_FILE: /* 111 */ + case INSN_COP_FILE: /* 110 */ { - pvindex arg; - BGET_pvindex(arg); + pvcontents arg; + BGET_pvcontents(arg); BSET_cop_file(cCOP, arg); break; } - case INSN_COP_SEQ: /* 112 */ + case INSN_COP_SEQ: /* 111 */ { U32 arg; BGET_U32(arg); cCOP->cop_seq = arg; break; } - case INSN_COP_ARYBASE: /* 113 */ + case INSN_COP_ARYBASE: /* 112 */ { I32 arg; BGET_I32(arg); cCOP->cop_arybase = arg; break; } - case INSN_COP_LINE: /* 114 */ + case INSN_COP_LINE: /* 113 */ { line_t arg; BGET_U16(arg); BSET_cop_line(cCOP, arg); break; } - case INSN_COP_WARNINGS: /* 115 */ + case INSN_COP_WARNINGS: /* 114 */ { svindex arg; BGET_svindex(arg); cCOP->cop_warnings = arg; break; } - case INSN_MAIN_START: /* 116 */ + case INSN_MAIN_START: /* 115 */ { opindex arg; BGET_opindex(arg); PL_main_start = arg; break; } - case INSN_MAIN_ROOT: /* 117 */ + case INSN_MAIN_ROOT: /* 116 */ { opindex arg; BGET_opindex(arg); PL_main_root = arg; break; } - case INSN_CURPAD: /* 118 */ + case INSN_CURPAD: /* 117 */ { svindex arg; BGET_svindex(arg); BSET_curpad(PL_curpad, arg); break; } - case INSN_PUSH_BEGIN: /* 119 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_begin(PL_beginav, arg); - break; - } - case INSN_PUSH_INIT: /* 120 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_init(PL_initav, arg); - break; - } - case INSN_PUSH_END: /* 121 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_end(PL_endav, arg); - break; - } default: Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn); /* NOTREACHED */ diff --git a/ext/ByteLoader/byterun.h b/ext/ByteLoader/byterun.h index 1e67b8967e..f0de6b4820 100644 --- a/ext/ByteLoader/byterun.h +++ b/ext/ByteLoader/byterun.h @@ -8,149 +8,133 @@ /* * This file is autogenerated from bytecode.pl. Changes made here will be lost. */ -struct byteloader_fdata { - SV *datasv; - int next_out; - int idx; +struct bytestream { + void *data; + int (*pfgetc)(void *); + int (*pfread)(char *, size_t, size_t, void *); + void (*pfreadpv)(U32, void *, XPV *); }; -struct byteloader_state { - struct byteloader_fdata *bs_fdata; - SV *bs_sv; - void **bs_obj_list; - int bs_obj_list_fill; - XPV bs_pv; - int bs_iv_overflows; -}; - -int bl_getc(struct byteloader_fdata *); -int bl_read(struct byteloader_fdata *, char *, size_t, size_t); -extern void byterun(pTHXo_ struct byteloader_state *); - enum { INSN_RET, /* 0 */ INSN_LDSV, /* 1 */ INSN_LDOP, /* 2 */ INSN_STSV, /* 3 */ INSN_STOP, /* 4 */ - INSN_STPV, /* 5 */ - INSN_LDSPECSV, /* 6 */ - INSN_NEWSV, /* 7 */ - INSN_NEWOP, /* 8 */ - INSN_NEWOPN, /* 9 */ + INSN_LDSPECSV, /* 5 */ + INSN_NEWSV, /* 6 */ + INSN_NEWOP, /* 7 */ + INSN_NEWOPN, /* 8 */ + INSN_NEWPV, /* 9 */ INSN_NOP, /* 10 */ - INSN_NEWPV, /* 11 */ - INSN_PV_CUR, /* 12 */ - INSN_PV_FREE, /* 13 */ - INSN_SV_UPGRADE, /* 14 */ - INSN_SV_REFCNT, /* 15 */ - INSN_SV_REFCNT_ADD, /* 16 */ - INSN_SV_FLAGS, /* 17 */ - INSN_XRV, /* 18 */ - INSN_XPV, /* 19 */ - INSN_XIV32, /* 20 */ - INSN_XIV64, /* 21 */ - INSN_XNV, /* 22 */ - INSN_XLV_TARGOFF, /* 23 */ - INSN_XLV_TARGLEN, /* 24 */ - INSN_XLV_TARG, /* 25 */ - INSN_XLV_TYPE, /* 26 */ - INSN_XBM_USEFUL, /* 27 */ - INSN_XBM_PREVIOUS, /* 28 */ - INSN_XBM_RARE, /* 29 */ - INSN_XFM_LINES, /* 30 */ - INSN_XIO_LINES, /* 31 */ - INSN_XIO_PAGE, /* 32 */ - INSN_XIO_PAGE_LEN, /* 33 */ - INSN_XIO_LINES_LEFT, /* 34 */ + INSN_PV_CUR, /* 11 */ + INSN_PV_FREE, /* 12 */ + INSN_SV_UPGRADE, /* 13 */ + INSN_SV_REFCNT, /* 14 */ + INSN_SV_REFCNT_ADD, /* 15 */ + INSN_SV_FLAGS, /* 16 */ + INSN_XRV, /* 17 */ + INSN_XPV, /* 18 */ + INSN_XIV32, /* 19 */ + INSN_XIV64, /* 20 */ + INSN_XNV, /* 21 */ + INSN_XLV_TARGOFF, /* 22 */ + INSN_XLV_TARGLEN, /* 23 */ + INSN_XLV_TARG, /* 24 */ + INSN_XLV_TYPE, /* 25 */ + INSN_XBM_USEFUL, /* 26 */ + INSN_XBM_PREVIOUS, /* 27 */ + INSN_XBM_RARE, /* 28 */ + INSN_XFM_LINES, /* 29 */ + INSN_XIO_LINES, /* 30 */ + INSN_XIO_PAGE, /* 31 */ + INSN_XIO_PAGE_LEN, /* 32 */ + INSN_XIO_LINES_LEFT, /* 33 */ + INSN_XIO_TOP_NAME, /* 34 */ INSN_COMMENT, /* 35 */ - INSN_XIO_TOP_NAME, /* 36 */ - INSN_XIO_TOP_GV, /* 37 */ - INSN_XIO_FMT_NAME, /* 38 */ - INSN_XIO_FMT_GV, /* 39 */ - INSN_XIO_BOTTOM_NAME, /* 40 */ - INSN_XIO_BOTTOM_GV, /* 41 */ - INSN_XIO_SUBPROCESS, /* 42 */ - INSN_XIO_TYPE, /* 43 */ - INSN_XIO_FLAGS, /* 44 */ - INSN_XCV_STASH, /* 45 */ - INSN_XCV_START, /* 46 */ - INSN_XCV_ROOT, /* 47 */ - INSN_XCV_GV, /* 48 */ - INSN_XCV_FILE, /* 49 */ - INSN_XCV_DEPTH, /* 50 */ - INSN_XCV_PADLIST, /* 51 */ - INSN_XCV_OUTSIDE, /* 52 */ - INSN_XCV_FLAGS, /* 53 */ - INSN_AV_EXTEND, /* 54 */ - INSN_AV_PUSH, /* 55 */ - INSN_XAV_FILL, /* 56 */ - INSN_XAV_MAX, /* 57 */ - INSN_XAV_FLAGS, /* 58 */ - INSN_XHV_RITER, /* 59 */ - INSN_XHV_NAME, /* 60 */ - INSN_HV_STORE, /* 61 */ - INSN_SV_MAGIC, /* 62 */ - INSN_MG_OBJ, /* 63 */ - INSN_MG_PRIVATE, /* 64 */ - INSN_MG_FLAGS, /* 65 */ - INSN_MG_PV, /* 66 */ - INSN_XMG_STASH, /* 67 */ - INSN_GV_FETCHPV, /* 68 */ - INSN_GV_STASHPV, /* 69 */ - INSN_GP_SV, /* 70 */ - INSN_GP_REFCNT, /* 71 */ - INSN_GP_REFCNT_ADD, /* 72 */ - INSN_GP_AV, /* 73 */ - INSN_GP_HV, /* 74 */ - INSN_GP_CV, /* 75 */ - INSN_GP_FILE, /* 76 */ - INSN_GP_IO, /* 77 */ - INSN_GP_FORM, /* 78 */ - INSN_GP_CVGEN, /* 79 */ - INSN_GP_LINE, /* 80 */ - INSN_GP_SHARE, /* 81 */ - INSN_XGV_FLAGS, /* 82 */ - INSN_OP_NEXT, /* 83 */ - INSN_OP_SIBLING, /* 84 */ - INSN_OP_PPADDR, /* 85 */ - INSN_OP_TARG, /* 86 */ - INSN_OP_TYPE, /* 87 */ - INSN_OP_SEQ, /* 88 */ - INSN_OP_FLAGS, /* 89 */ - INSN_OP_PRIVATE, /* 90 */ - INSN_OP_FIRST, /* 91 */ - INSN_OP_LAST, /* 92 */ - INSN_OP_OTHER, /* 93 */ - INSN_OP_CHILDREN, /* 94 */ - INSN_OP_PMREPLROOT, /* 95 */ - INSN_OP_PMREPLROOTGV, /* 96 */ - INSN_OP_PMREPLSTART, /* 97 */ - INSN_OP_PMNEXT, /* 98 */ - INSN_PREGCOMP, /* 99 */ - INSN_OP_PMFLAGS, /* 100 */ - INSN_OP_PMPERMFLAGS, /* 101 */ - INSN_OP_SV, /* 102 */ - INSN_OP_PADIX, /* 103 */ - INSN_OP_PV, /* 104 */ - INSN_OP_PV_TR, /* 105 */ - INSN_OP_REDOOP, /* 106 */ - INSN_OP_NEXTOP, /* 107 */ - INSN_OP_LASTOP, /* 108 */ - INSN_COP_LABEL, /* 109 */ - INSN_COP_STASHPV, /* 110 */ - INSN_COP_FILE, /* 111 */ - INSN_COP_SEQ, /* 112 */ - INSN_COP_ARYBASE, /* 113 */ - INSN_COP_LINE, /* 114 */ - INSN_COP_WARNINGS, /* 115 */ - INSN_MAIN_START, /* 116 */ - INSN_MAIN_ROOT, /* 117 */ - INSN_CURPAD, /* 118 */ - INSN_PUSH_BEGIN, /* 119 */ - INSN_PUSH_INIT, /* 120 */ - INSN_PUSH_END, /* 121 */ - MAX_INSN = 121 + INSN_XIO_TOP_GV, /* 36 */ + INSN_XIO_FMT_NAME, /* 37 */ + INSN_XIO_FMT_GV, /* 38 */ + INSN_XIO_BOTTOM_NAME, /* 39 */ + INSN_XIO_BOTTOM_GV, /* 40 */ + INSN_XIO_SUBPROCESS, /* 41 */ + INSN_XIO_TYPE, /* 42 */ + INSN_XIO_FLAGS, /* 43 */ + INSN_XCV_STASH, /* 44 */ + INSN_XCV_START, /* 45 */ + INSN_XCV_ROOT, /* 46 */ + INSN_XCV_GV, /* 47 */ + INSN_XCV_FILE, /* 48 */ + INSN_XCV_DEPTH, /* 49 */ + INSN_XCV_PADLIST, /* 50 */ + INSN_XCV_OUTSIDE, /* 51 */ + INSN_XCV_FLAGS, /* 52 */ + INSN_AV_EXTEND, /* 53 */ + INSN_AV_PUSH, /* 54 */ + INSN_XAV_FILL, /* 55 */ + INSN_XAV_MAX, /* 56 */ + INSN_XAV_FLAGS, /* 57 */ + INSN_XHV_RITER, /* 58 */ + INSN_XHV_NAME, /* 59 */ + INSN_HV_STORE, /* 60 */ + INSN_SV_MAGIC, /* 61 */ + INSN_MG_OBJ, /* 62 */ + INSN_MG_PRIVATE, /* 63 */ + INSN_MG_FLAGS, /* 64 */ + INSN_MG_PV, /* 65 */ + INSN_XMG_STASH, /* 66 */ + INSN_GV_FETCHPV, /* 67 */ + INSN_GV_STASHPV, /* 68 */ + INSN_GP_SV, /* 69 */ + INSN_GP_REFCNT, /* 70 */ + INSN_GP_REFCNT_ADD, /* 71 */ + INSN_GP_AV, /* 72 */ + INSN_GP_HV, /* 73 */ + INSN_GP_CV, /* 74 */ + INSN_GP_FILE, /* 75 */ + INSN_GP_IO, /* 76 */ + INSN_GP_FORM, /* 77 */ + INSN_GP_CVGEN, /* 78 */ + INSN_GP_LINE, /* 79 */ + INSN_GP_SHARE, /* 80 */ + INSN_XGV_FLAGS, /* 81 */ + INSN_OP_NEXT, /* 82 */ + INSN_OP_SIBLING, /* 83 */ + INSN_OP_PPADDR, /* 84 */ + INSN_OP_TARG, /* 85 */ + INSN_OP_TYPE, /* 86 */ + INSN_OP_SEQ, /* 87 */ + INSN_OP_FLAGS, /* 88 */ + INSN_OP_PRIVATE, /* 89 */ + INSN_OP_FIRST, /* 90 */ + INSN_OP_LAST, /* 91 */ + INSN_OP_OTHER, /* 92 */ + INSN_OP_CHILDREN, /* 93 */ + INSN_OP_PMREPLROOT, /* 94 */ + INSN_OP_PMREPLROOTGV, /* 95 */ + INSN_OP_PMREPLSTART, /* 96 */ + INSN_OP_PMNEXT, /* 97 */ + INSN_PREGCOMP, /* 98 */ + INSN_OP_PMFLAGS, /* 99 */ + INSN_OP_PMPERMFLAGS, /* 100 */ + INSN_OP_SV, /* 101 */ + INSN_OP_PADIX, /* 102 */ + INSN_OP_PV, /* 103 */ + INSN_OP_PV_TR, /* 104 */ + INSN_OP_REDOOP, /* 105 */ + INSN_OP_NEXTOP, /* 106 */ + INSN_OP_LASTOP, /* 107 */ + INSN_COP_LABEL, /* 108 */ + INSN_COP_STASHPV, /* 109 */ + INSN_COP_FILE, /* 110 */ + INSN_COP_SEQ, /* 111 */ + INSN_COP_ARYBASE, /* 112 */ + INSN_COP_LINE, /* 113 */ + INSN_COP_WARNINGS, /* 114 */ + INSN_MAIN_START, /* 115 */ + INSN_MAIN_ROOT, /* 116 */ + INSN_CURPAD, /* 117 */ + MAX_INSN = 117 }; enum { @@ -167,3 +151,11 @@ enum { OPt_COP /* 10 */ }; +extern void byterun(pTHXo_ struct bytestream bs); + +#define INIT_SPECIALSV_LIST STMT_START { \ + PL_specialsv_list[0] = Nullsv; \ + PL_specialsv_list[1] = &PL_sv_undef; \ + PL_specialsv_list[2] = &PL_sv_yes; \ + PL_specialsv_list[3] = &PL_sv_no; \ + } STMT_END diff --git a/ext/IPC/SysV/Makefile.PL b/ext/IPC/SysV/Makefile.PL index b87f179be2..f994950d19 100644 --- a/ext/IPC/SysV/Makefile.PL +++ b/ext/IPC/SysV/Makefile.PL @@ -13,7 +13,7 @@ sub MY::libscan return '' if($path =~ m:/(RCS|CVS|SCCS)/: || $path =~ m:[~%]$: || - $path =~ m:(\.(orig|rej)|~)$: + $path =~ m:\.(orig|rej)$: ); $path; diff --git a/installperl b/installperl index 78d7ed7e6d..09ffc806dd 100755 --- a/installperl +++ b/installperl @@ -377,7 +377,6 @@ if (! $versiononly) { safe_unlink("$installscript/pstruct$scr_ext"); if ($^O eq 'dos' or $Is_VMS or $^O eq 'transit') { copy("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); - chmod(0755, "$installscript/pstruct$scr_ext"); } else { link("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext"); } diff --git a/intrpvar.h b/intrpvar.h index b9acb246fe..f84de796c7 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -140,10 +140,6 @@ PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */ /* subprocess state */ PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */ -#ifdef USE_THREADS -PERLVAR(Ifdpid_mutex, perl_mutex) /* mutex for fdpid array */ -#endif - /* internal state */ PERLVAR(Itainting, bool) /* doing taint checks */ PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */ @@ -250,29 +246,17 @@ PERLVAR(Isighandlerp, Sighandler_t) PERLVAR(Ixiv_arenaroot, XPV*) /* list of allocated xiv areas */ PERLVAR(Ixiv_root, IV *) /* free xiv list */ -PERLVAR(Ixnv_arenaroot, XPV*) /* list of allocated xnv areas */ PERLVAR(Ixnv_root, NV *) /* free xnv list */ -PERLVAR(Ixrv_arenaroot, XPV*) /* list of allocated xrv areas */ PERLVAR(Ixrv_root, XRV *) /* free xrv list */ -PERLVAR(Ixpv_arenaroot, XPV*) /* list of allocated xpv areas */ PERLVAR(Ixpv_root, XPV *) /* free xpv list */ -PERLVAR(Ixpviv_arenaroot,XPVIV*) /* list of allocated xpviv areas */ PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list */ -PERLVAR(Ixpvnv_arenaroot,XPVNV*) /* list of allocated xpvnv areas */ PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list */ -PERLVAR(Ixpvcv_arenaroot,XPVCV*) /* list of allocated xpvcv areas */ PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list */ -PERLVAR(Ixpvav_arenaroot,XPVAV*) /* list of allocated xpvav areas */ PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list */ -PERLVAR(Ixpvhv_arenaroot,XPVHV*) /* list of allocated xpvhv areas */ PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list */ -PERLVAR(Ixpvmg_arenaroot,XPVMG*) /* list of allocated xpvmg areas */ PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list */ -PERLVAR(Ixpvlv_arenaroot,XPVLV*) /* list of allocated xpvlv areas */ PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list */ -PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */ PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list */ -PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */ PERLVAR(Ihe_root, HE *) /* free he list */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ @@ -460,9 +444,26 @@ PERLVAR(IProc, struct IPerlProc*) PERLVAR(Iptr_table, PTR_TBL_t*) #endif -#if defined(USE_THREADS) -PERLVAR(Isv_lock_mutex, perl_mutex) /* Mutex for SvLOCK macro */ +#ifdef USE_THREADS +PERLVAR(Ifdpid_mutex, perl_mutex) /* mutex for fdpid array */ +PERLVAR(Isv_lock_mutex, perl_mutex) /* mutex for SvLOCK macro */ #endif -PERLVARI(Ibeginav_save, AV*, Nullav) /* save BEGIN{}s when compiling */ PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ + +PERLVAR(Ixnv_arenaroot, XPV*) /* list of allocated xnv areas */ +PERLVAR(Ixrv_arenaroot, XPV*) /* list of allocated xrv areas */ +PERLVAR(Ixpv_arenaroot, XPV*) /* list of allocated xpv areas */ +PERLVAR(Ixpviv_arenaroot,XPVIV*) /* list of allocated xpviv areas */ +PERLVAR(Ixpvnv_arenaroot,XPVNV*) /* list of allocated xpvnv areas */ +PERLVAR(Ixpvcv_arenaroot,XPVCV*) /* list of allocated xpvcv areas */ +PERLVAR(Ixpvav_arenaroot,XPVAV*) /* list of allocated xpvav areas */ +PERLVAR(Ixpvhv_arenaroot,XPVHV*) /* list of allocated xpvhv areas */ +PERLVAR(Ixpvmg_arenaroot,XPVMG*) /* list of allocated xpvmg areas */ +PERLVAR(Ixpvlv_arenaroot,XPVLV*) /* list of allocated xpvlv areas */ +PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */ +PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */ + +/* New variables must be added to the very end for binary compatibility. + * XSUB.h provides wrapper functions via perlapi.h that make this + * irrelevant, but not all code may be expected to #include XSUB.h. */ diff --git a/lib/Exporter.pm b/lib/Exporter.pm index 9a4382f42b..585109e7d0 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -42,12 +42,6 @@ sub import { $exports{$sym} = 1; } } - for (@_) { - #need to match first to avoid "Modification of a read-only value attempted" - if (/^\+/ and s/^\+//) { - (\&{"$pkg\::$_"})->(); #try AUTOLOAD now so calls are inlined - } - } if ($Verbose or $Debug or grep {/\W/ or $args and not exists $exports{$_} or @fail and $_ eq $fail[0] @@ -209,15 +203,6 @@ You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the specifications are being processed and what is actually being imported into modules. -=head2 Constants can be inlined - -AUTOLOADed constants can be inlined by prefixing them with a C<+>: - - use Socket qw(+AF_INET); - -Thusly prefixed constants are defined during the symbol import phase of -compilation, which means that by runtime they are true inlined constants. - =head2 Exporting without using Export's import method Exporter has a special method, 'export_to_level' which is used in situations diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index 8401feaac7..36c72219a9 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -40,7 +40,7 @@ sub install { my(%hash) = %$hash; my(%pack, $dir, $warn_permissions); - my($packlist) = ExtUtils::Packlist->new(undef); + my($packlist) = ExtUtils::Packlist->new(); # -w doesn't work reliably on FAT dirs $warn_permissions++ if $^O eq 'MSWin32'; local(*DIR); diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 65b0bd91c4..8e337d97fa 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -457,7 +457,7 @@ EOT push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib - *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe + *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); diff --git a/lib/File/Spec/Functions.pm b/lib/File/Spec/Functions.pm index 140738f443..0036ac1ded 100644 --- a/lib/File/Spec/Functions.pm +++ b/lib/File/Spec/Functions.pm @@ -3,7 +3,9 @@ package File::Spec::Functions; use File::Spec; use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '1.1'; require Exporter; diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index fc328db0fb..20bf8c9dce 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -3,9 +3,10 @@ package File::Spec::OS2; use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -@ISA = qw(File::Spec::Unix); -$VERSION = 1.0; +$VERSION = '1.1'; + +@ISA = qw(File::Spec::Unix); sub devnull { return "/dev/nul"; diff --git a/lib/base.pm b/lib/base.pm index b8d210e745..3cb42f5bfa 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -52,21 +52,14 @@ sub import { my $fields_base; my $pkg = caller(0); - my @attrs; - my $isa = \@{"$pkg\::ISA"}; - foreach my $base (@_) { - if ($base =~ /^[-+]/) { #attribute - push @attrs, $base; - next; - } next if $pkg->isa($base); - push @$isa, $base; + push @{"$pkg\::ISA"}, $base; unless (exists ${"$base\::"}{VERSION}) { eval "require $base"; # Only ignore "Can't locate" errors from our eval require. # Other fatal errors (syntax etc) must be reported. - die if $@ && $@ !~ /^Can\'t locate .*? at \(eval /; + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (%{"$base\::"}) { require Carp; Carp::croak("Base class package \"$base\" is empty.\n", @@ -94,10 +87,6 @@ sub import { require fields; fields::inherit($pkg, $fields_base); } - if (@attrs) { - require attributes; - attributes::->import($pkg, $isa, @attrs); - } } 1; @@ -614,7 +614,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; s = rx->subbeg + s1; - if (!rx->subbeg) + if (!rx->subbeg) break; getrx: @@ -2684,7 +2684,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!squash) { if (t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; + } } while (t < tend || tfirst <= tlast) { @@ -4467,7 +4469,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) * skipping the prototype check */ if (exists || SvPOK(cv)) - cv_ckproto(cv, gv, ps); + cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { SV* const_sv; @@ -6246,81 +6248,6 @@ Perl_ck_join(pTHX_ OP *o) return ck_fun(o); } -STATIC OP * -S_method_2entersub(pTHX_ OP *o, OP *o2, OP *svop) -{ - GV *gv; - SV *method = ((SVOP*)svop)->op_sv; - char *methname; - STRLEN methlen; - HV *stash; - OP *mop; - - if (svop->op_type == OP_METHOD_NAMED) { - methname = SvPV(method, methlen); - } - else { - return Nullop; - } - - if (o2->op_type == OP_CONST) { - STRLEN len; - char *pkg = SvPV(((SVOP*)o2)->op_sv, len); - stash = gv_stashpvn(pkg, len, FALSE); - } - else if (o2->op_type == OP_PADSV) { - /* my Dog $spot = shift; $spot->bark */ - SV *sv = *av_fetch(PL_comppad_name, o2->op_targ, FALSE); - if (sv && SvOBJECT(sv)) { - stash = SvSTASH(sv); - } - else { - return Nullop; - } - } - else { - return Nullop; - } - - /* -1 so cache globs are not created */ - /* XXX: support SUPER:: and UNIVERSAL, but not AUTOLOAD */ - if (!(stash && (gv = gv_fetchmeth(stash, methname, methlen, -1)) && - isGV(gv))) { - return Nullop; - } - - /* XXX: check entire @ISA tree for readonly-ness ? */ - if (GvSTASH(CvGV(GvCV(gv))) != stash) { - GV **gvp, *isagv; - AV *av; - gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); - av = (gvp && (isagv = *gvp) && isagv != (GV*)&PL_sv_undef) ? - GvAV(isagv) : Nullav; - - if (isagv && av && !SvREADONLY((SV*)av)) { - return Nullop; /* @ISA is not frozen */ - } - - gv = CvGV(GvCV(gv)); /* point to the real gv */ - } - - if (o2->op_type == OP_CONST) { - /* remove bareword-ness of class name */ - o2->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT); - } - - for (mop = o2; mop->op_sibling->op_sibling; mop = mop->op_sibling) ; - - op_free(mop->op_sibling); /* loose OP_METHOD_NAMED */ - mop->op_sibling = scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))); - - ((cUNOPo->op_first->op_sibling) - ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first->op_sibling = o2; - - return ck_subr(o); -} - OP * Perl_ck_subr(pTHX_ OP *o) { @@ -6355,16 +6282,8 @@ Perl_ck_subr(pTHX_ OP *o) } } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { - if ((PL_hints & HINT_CT_MRESOLVE) && /* use base qw(... +readonly) */ - (o2->op_type == OP_CONST || o2->op_type == OP_PADSV)) { - OP *nop; - if ((nop = method_2entersub(o, o2, cvop))) { - return nop; - } - } - if (o2->op_type == OP_CONST) { + if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; - } else if (o2->op_type == OP_LIST) { OP *o = ((UNOP*)o2)->op_first->op_sibling; if (o && o->op_type == OP_CONST) @@ -3675,14 +3675,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) { - /* save PL_beginav for compiler */ - if (! PL_beginav_save) - PL_beginav_save = newAV(); - av_push(PL_beginav_save, (SV*)cv); - } else { - SAVEFREESV(cv); - } + SAVEFREESV(cv); #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else @@ -2589,7 +2589,6 @@ enum { /* pass one of these to get_vtbl */ #define HINT_NEW_STRING 0x00008000 #define HINT_NEW_RE 0x00010000 #define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */ -#define HINT_CT_MRESOLVE 0x00040000 /* resolve methods at compile time */ #define HINT_RE_TAINT 0x00100000 #define HINT_RE_EVAL 0x00200000 diff --git a/perlapi.c b/perlapi.c index 6a54b94b22..6a54b94b22 100755..100644 --- a/perlapi.c +++ b/perlapi.c diff --git a/perlapi.h b/perlapi.h index 4a95fbb0cc..de0e7ccdc5 100755..100644 --- a/perlapi.h +++ b/perlapi.h @@ -130,8 +130,6 @@ START_EXTERN_C #define PL_basetime (*Perl_Ibasetime_ptr(aTHXo)) #undef PL_beginav #define PL_beginav (*Perl_Ibeginav_ptr(aTHXo)) -#undef PL_beginav_save -#define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHXo)) #undef PL_bitcount #define PL_bitcount (*Perl_Ibitcount_ptr(aTHXo)) #undef PL_bufend @@ -232,8 +230,6 @@ START_EXTERN_C #define PL_expect (*Perl_Iexpect_ptr(aTHXo)) #undef PL_fdpid #define PL_fdpid (*Perl_Ifdpid_ptr(aTHXo)) -#undef PL_fdpid_mutex -#define PL_fdpid_mutex (*Perl_Ifdpid_mutex_ptr(aTHXo)) #undef PL_filemode #define PL_filemode (*Perl_Ifilemode_ptr(aTHXo)) #undef PL_forkprocess @@ -498,8 +494,6 @@ START_EXTERN_C #define PL_sv_arenaroot (*Perl_Isv_arenaroot_ptr(aTHXo)) #undef PL_sv_count #define PL_sv_count (*Perl_Isv_count_ptr(aTHXo)) -#undef PL_sv_lock_mutex -#define PL_sv_lock_mutex (*Perl_Isv_lock_mutex_ptr(aTHXo)) #undef PL_sv_mutex #define PL_sv_mutex (*Perl_Isv_mutex_ptr(aTHXo)) #undef PL_sv_no diff --git a/pod/perl5004delta.pod b/pod/perl5004delta.pod index 2ade235703..85a8f96161 100644 --- a/pod/perl5004delta.pod +++ b/pod/perl5004delta.pod @@ -1489,7 +1489,7 @@ subroutine, and outside that is another subroutine; and the anonymous (innermost) subroutine is referencing a lexical variable defined in the outermost subroutine. For example: - sub outermost { my $x; sub middle { sub { $x } } } + sub outermost { my $a; sub middle { sub { $a } } } If the anonymous subroutine is called or referenced (directly or indirectly) from the outermost subroutine, it will share the variable diff --git a/pod/perl56delta.pod b/pod/perl56delta.pod index 16a06c43a5..5a824ac8e5 100644 --- a/pod/perl56delta.pod +++ b/pod/perl56delta.pod @@ -487,7 +487,7 @@ required for C<< foo(10)->('bar') >>. =head2 Boolean assignment operators are legal lvalues -Constructs such as C<($x ||= 2) += 1> are now allowed. +Constructs such as C<($a ||= 2) += 1> are now allowed. =head2 exists() is supported on subroutine names diff --git a/pod/perlbook.pod b/pod/perlbook.pod index 44f0233ee1..1b322fb576 100644 --- a/pod/perlbook.pod +++ b/pod/perlbook.pod @@ -4,13 +4,12 @@ perlbook - Perl book information =head1 DESCRIPTION -The Camel Book, officially known as I<Programming Perl, Third Edition, -July 2000>, by Larry Wall et al, ISBN 0-596-00027-8, is the definitive -reference work covering nearly all of Perl. You can order it and -other Perl books from O'Reilly & Associates, 1-800-998-9938. -Local/overseas is +1 707 829 0515. If you can locate an O'Reilly -order form, you can also fax to +1 707 829 0104. If you're -web-connected, you can even mosey on over to http://www.oreilly.com/ +The Camel Book, officially known as I<Programming Perl, Second Edition>, +by Larry Wall et al, is the definitive reference work covering nearly +all of Perl. You can order it and other Perl books from O'Reilly & +Associates, 1-800-998-9938. Local/overseas is +1 707 829 0515. If you +can locate an O'Reilly order form, you can also fax to +1 707 829 0104. +If you're web-connected, you can even mosey on over to http://www.oreilly.com/ for an online order form. Other Perl books from various publishers and authors diff --git a/pod/perlboot.pod b/pod/perlboot.pod index c9ee9a5aff..b549f45e49 100644 --- a/pod/perlboot.pod +++ b/pod/perlboot.pod @@ -87,8 +87,8 @@ And once again, this results in: That's not fun yet. Same number of characters, all constant, no variables. But yet, the parts are separable now. Watch: - $x = "Cow"; - $x->speak; # invokes Cow->speak + $a = "Cow"; + $a->speak; # invokes Cow->speak Ahh! Now that the package name has been parted from the subroutine name, we can use a variable package name. And this time, we've got @@ -392,8 +392,8 @@ So far, we've seen the method arrow syntax: or the equivalent: - $x = "Class"; - $x->method(@args); + $a = "Class"; + $a->method(@args); which constructs an argument list of: diff --git a/pod/perlbot.pod b/pod/perlbot.pod index e4952661b0..bc4e4da1f7 100644 --- a/pod/perlbot.pod +++ b/pod/perlbot.pod @@ -104,14 +104,14 @@ variables. Named parameters are also demonstrated. package main; - $x = Foo->new( 'High' => 42, 'Low' => 11 ); - print "High=$x->{'High'}\n"; - print "Low=$x->{'Low'}\n"; - - $y = Bar->new( 'Left' => 78, 'Right' => 40 ); - print "Left=$y->[0]\n"; - print "Right=$y->[1]\n"; - + $a = Foo->new( 'High' => 42, 'Low' => 11 ); + print "High=$a->{'High'}\n"; + print "Low=$a->{'Low'}\n"; + + $b = Bar->new( 'Left' => 78, 'Right' => 40 ); + print "Left=$b->[0]\n"; + print "Right=$b->[1]\n"; + =head1 SCALAR INSTANCE VARIABLES An anonymous scalar can be used when only one instance variable is needed. @@ -127,8 +127,8 @@ An anonymous scalar can be used when only one instance variable is needed. package main; - $x = Foo->new( 42 ); - print "a=$$x\n"; + $a = Foo->new( 42 ); + print "a=$$a\n"; =head1 INSTANCE VARIABLE INHERITANCE @@ -159,9 +159,9 @@ object. package main; - $x = Foo->new; - print "buz = ", $x->{'buz'}, "\n"; - print "biz = ", $x->{'biz'}, "\n"; + $a = Foo->new; + print "buz = ", $a->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; @@ -191,9 +191,9 @@ relationships between objects. package main; - $x = Foo->new; - print "buz = ", $x->{'Bar'}->{'buz'}, "\n"; - print "biz = ", $x->{'biz'}, "\n"; + $a = Foo->new; + print "buz = ", $a->{'Bar'}->{'buz'}, "\n"; + print "biz = ", $a->{'biz'}, "\n"; @@ -314,8 +314,8 @@ that it is impossible to override the BAZ() method. package main; - $x = FOO->new; - $x->bar; + $a = FOO->new; + $a->bar; Now we try to override the BAZ() method. We would like FOO::bar() to call GOOP::BAZ(), but this cannot happen because FOO::bar() explicitly calls @@ -351,8 +351,8 @@ FOO::private::BAZ(). package main; - $x = GOOP->new; - $x->bar; + $a = GOOP->new; + $a->bar; To create reusable code we must modify class FOO, flattening class FOO::private. The next example shows a reusable class FOO which allows the @@ -386,8 +386,8 @@ method GOOP::BAZ() to be used in place of FOO::BAZ(). package main; - $x = GOOP->new; - $x->bar; + $a = GOOP->new; + $a->bar; =head1 CLASS CONTEXT AND THE OBJECT @@ -444,10 +444,10 @@ method where that data is located. package main; - $x = Bar->new; - $y = Foo->new; - $x->enter; - $y->enter; + $a = Bar->new; + $b = Foo->new; + $a->enter; + $b->enter; =head1 INHERITING A CONSTRUCTOR @@ -476,8 +476,8 @@ object will be a BAR not a FOO, even though the constructor is in class FOO. package main; - $x = BAR->new; - $x->baz; + $a = BAR->new; + $a->baz; =head1 DELEGATION @@ -4418,7 +4418,7 @@ PP(pp_pack) patcopy++; continue; } - if (datumtype == 'U' && pat==patcopy+1) + if (datumtype == 'U' && pat == patcopy+1) SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') @@ -149,64 +149,33 @@ PP(pp_concat) bool left_utf = DO_UTF8(left); bool right_utf = DO_UTF8(right); - if (left_utf != right_utf) { - if (TARG == right && !right_utf) { - sv_utf8_upgrade(TARG); /* Now straight binary copy */ - SvUTF8_on(TARG); - } - else { - /* Set TARG to PV(left), then add right */ - char *l, *c; - STRLEN targlen; - if (TARG == right) - /* Need a safe copy elsewhere since we're just about to - write onto TARG */ - s = strdup(SvPV(right,len)); - else - s = SvPV(right,len); - l = SvPV(left, targlen); - if (TARG != left) - sv_setpvn(TARG,l,targlen); - if (!left_utf) - sv_utf8_upgrade(TARG); - /* Extend TARG to length of right (s) */ - targlen = SvCUR(TARG) + len; - if (!right_utf) { - /* plus one for each hi-byte char if we have to upgrade */ - for (c = s; *c; c++) { - if (*c & 0x80) - targlen++; - } - } - SvGROW(TARG, targlen+1); - /* And now copy, maybe upgrading right to UTF8 on the fly */ - for (c = SvEND(TARG); *s; s++) { - if (*s & 0x80 && !right_utf) - c = (char*)uv_to_utf8((U8*)c, *s); - else - *c++ = *s; - } - SvCUR_set(TARG, targlen); - *SvEND(TARG) = '\0'; - SvUTF8_on(TARG); - SETs(TARG); - RETURN; - } - } - if (TARG != left) { + if (right_utf && !left_utf) + sv_utf8_upgrade(left); s = SvPV(left,len); + SvUTF8_off(TARG); if (TARG == right) { + if (left_utf && !right_utf) + sv_utf8_upgrade(right); sv_insert(TARG, 0, 0, s, len); + if (left_utf || right_utf) + SvUTF8_on(TARG); SETs(TARG); RETURN; } sv_setpvn(TARG,s,len); } - else if (SvGMAGICAL(TARG)) + else if (SvGMAGICAL(TARG)) { mg_get(TARG); - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) + if (right_utf && !left_utf) + sv_utf8_upgrade(left); + } + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ + s = SvPV_force(TARG, len); + } + if (left_utf && !right_utf) + sv_utf8_upgrade(right); s = SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) @@ -225,7 +194,7 @@ PP(pp_concat) } else sv_setpvn(TARG,s,len); /* suppress warning */ - if (left_utf) + if (left_utf || right_utf) SvUTF8_on(TARG); SETTARG; RETURN; @@ -2649,8 +2649,7 @@ tryagain: FAIL("trailing \\ in regexp"); /* FALL THROUGH */ default: - if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && - isALPHA(*p) && *p != '_') + if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p)) Perl_warner(aTHX_ WARN_REGEXP, "/%.127s/: Unrecognized escape \\%c passed through", PL_regprecomp, @@ -2963,8 +2962,7 @@ S_regclass(pTHX) PL_regcomp_parse += numlen; break; default: - if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && - isALPHA(value) && value != (UV)'_') + if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value)) Perl_warner(aTHX_ WARN_REGEXP, "/%.127s/: Unrecognized escape \\%c in character class passed through", PL_regprecomp, @@ -3448,8 +3446,7 @@ S_regclassutf8(pTHX) PL_regcomp_parse += numlen; break; default: - if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && - isALPHA(value) && value != (U32)'_') + if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value)) Perl_warner(aTHX_ WARN_REGEXP, "/%.127s/: Unrecognized escape \\%c in character class passed through", PL_regprecomp, @@ -1022,13 +1022,6 @@ indicated number of bytes (remember to reserve space for an extra trailing NUL character). Calls C<sv_grow> to perform the expansion if necessary. Returns a pointer to the character buffer. -=for apidoc Am|void|SvLOCK|SV* sv -Aquires an internal mutex for a SV. Used to make sure multiple threads -don't stomp on the guts of an SV at the same time - -=for apidoc Am|void|SvUNLOCK|SV* sv -Release the internal mutex for an SV. - =cut */ @@ -1064,9 +1057,6 @@ Release the internal mutex for an SV. SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) #ifdef DEBUGGING - -#define SvLOCK(sv) MUTEX_LOCK(&PL_sv_lock_mutex) -#define SvUNLOCK(sv) MUTEX_UNLOCK(&PL_sv_lock_mutex) #define SvPEEK(sv) sv_peek(sv) #else #define SvPEEK(sv) "" diff --git a/t/op/filetest.t b/t/op/filetest.t index e00d5fb7b0..e00d5fb7b0 100644..100755 --- a/t/op/filetest.t +++ b/t/op/filetest.t diff --git a/t/op/subst_amp.t b/t/op/subst_amp.t index e2e7c0e542..e2e7c0e542 100644..100755 --- a/t/op/subst_amp.t +++ b/t/op/subst_amp.t diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 768b792c35..5d0c291ea0 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -46,15 +46,12 @@ Strange *+?{} on zero-length expression at - line 4. ######## # regcomp.c [S_regatom] $x = '\m' ; -$y = '\_' ; use warnings 'regexp' ; $a =~ /a$x/ ; -$b =~ /b$y/ ; no warnings 'regexp' ; $a =~ /a$x/ ; -$b =~ /b$y/ ; EXPECT -/a\m/: Unrecognized escape \m passed through at - line 5. +/a\m/: Unrecognized escape \m passed through at - line 4. ######## # regcomp.c [S_regpposixcc S_checkposixcc] BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 } @@ -162,9 +159,7 @@ EXPECT # regcomp.c [S_regclass S_regclassutf8] use warnings 'regexp' ; $a =~ /[a\zb]/ ; -$b =~ /[a\_b]/ ; no warnings 'regexp' ; $a =~ /[a\zb]/ ; -$b =~ /[a\_b]/ ; EXPECT /[a\zb]/: Unrecognized escape \z in character class passed through at - line 3. diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index b410e19d72..64f5368588 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -529,10 +529,8 @@ Ambiguous use of * resolved as operator * at - line 10. # toke.c use warnings 'misc' ; my $a = "\m" ; -my $b = "\_" ; no warnings 'misc' ; $a = "\m" ; -$b = "\_" ; EXPECT Unrecognized escape \m passed through at - line 3. ######## @@ -282,6 +282,8 @@ # define UNLOCK_CRED_MUTEX MUTEX_UNLOCK(&PL_cred_mutex) # define LOCK_FDPID_MUTEX MUTEX_LOCK(&PL_fdpid_mutex) # define UNLOCK_FDPID_MUTEX MUTEX_UNLOCK(&PL_fdpid_mutex) +# define LOCK_SV_LOCK_MUTEX MUTEX_LOCK(&PL_sv_lock_mutex) +# define UNLOCK_SV_LOCK_MUTEX MUTEX_UNLOCK(&PL_sv_lock_mutex) /* Values and macros for thr->flags */ #define THRf_STATE_MASK 7 @@ -385,6 +387,14 @@ typedef struct condpair { # define UNLOCK_FDPID_MUTEX #endif +#ifndef LOCK_SV_LOCK_MUTEX +# define LOCK_SV_LOCK_MUTEX +#endif + +#ifndef UNLOCK_SV_LOCK_MUTEX +# define UNLOCK_SV_LOCK_MUTEX +#endif + /* THR, SET_THR, and dTHR are there for compatibility with old versions */ #ifndef THR # define THR PERL_GET_THX @@ -326,7 +326,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif -#ifdef PERL_UTF16_FILTER +#ifndef PERL_NO_UTF16_FILTER STATIC I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { @@ -987,8 +987,8 @@ S_sublex_start(pTHX) p = SvPV(sv, len); nsv = newSVpvn(p, len); - if (SvUTF8(sv)) - SvUTF8_on(nsv); + if (SvUTF8(sv)) + SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; } @@ -1242,11 +1242,10 @@ S_scan_const(pTHX_ char *start) min = (U8)*d; /* first char in range */ max = (U8)d[1]; /* last char in range */ - if (min > max) { - Perl_croak(aTHX_ - "Invalid [] range \"%c-%c\" in transliteration operator", - min, max); + Perl_croak(aTHX_ + "Invalid [] range \"%c-%c\" in transliteration operator", + min, max); } #ifndef ASCIIish @@ -1269,15 +1268,15 @@ S_scan_const(pTHX_ char *start) /* mark the range as done, and continue */ dorange = FALSE; - didrange = TRUE; + didrange = TRUE; continue; } /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { - if (didrange) { + if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); - } + } if (utf) { *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */ s++; @@ -1285,9 +1284,10 @@ S_scan_const(pTHX_ char *start) } dorange = TRUE; s++; - } else { - didrange = FALSE; - } + } + else { + didrange = FALSE; + } } /* if we get here, we're not doing a transliteration */ @@ -1406,7 +1406,7 @@ S_scan_const(pTHX_ char *start) default: { dTHR; - if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_') + if (ckWARN(WARN_MISC) && isALNUM(*s)) Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); @@ -2020,17 +2020,19 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) return (sv_gets(sv, fp, append)); } -STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len) +STATIC HV * +S_find_in_my_stash(pTHX_ char *pkgname, I32 len) { GV *gv; - if (*pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) + if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) return PL_curstash; if (len > 2 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && - (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) { - return GvHV(gv); /* Foo:: */ + (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) + { + return GvHV(gv); /* Foo:: */ } /* use constant CLASS => 'MyClass' */ @@ -2504,8 +2506,8 @@ Perl_yylex(pTHX) goto retry; } do { - bool bof; - bof = PL_rsfp && (PerlIO_tell(PL_rsfp)==0); /* *Before* read! */ + bool bof; + bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { fake_eof: if (PL_rsfp) { @@ -2542,8 +2544,8 @@ Perl_yylex(pTHX) PL_doextract = FALSE; } } - if (bof) - s = swallow_bom(s); + if (bof) + s = swallow_bom(s); incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -6171,8 +6173,8 @@ S_scan_trans(pTHX_ char *start) Perl_croak(aTHX_ "Transliteration replacement not terminated"); } - New(803,tbl,256,short); - o = newPVOP(OP_TRANS, 0, (char*)tbl); + New(803,tbl,256,short); + o = newPVOP(OP_TRANS, 0, (char*)tbl); complement = del = squash = 0; while (strchr("cds", *s)) { @@ -7404,57 +7406,57 @@ Perl_yyerror(pTHX_ char *s) return 0; } - STATIC char* -S_swallow_bom(pTHX_ U8 *s) { +S_swallow_bom(pTHX_ U8 *s) +{ STRLEN slen; slen = SvCUR(PL_linestr); switch (*s) { - case 0xFF: - if (s[1] == 0xFE) { - /* UTF-16 little-endian */ -#ifdef PERL_UTF16_FILTER - U8 *news; + case 0xFF: + if (s[1] == 0xFE) { + /* UTF-16 little-endian */ +#ifndef PERL_NO_UTF16_FILTER + U8 *news; #endif - if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ - Perl_croak(aTHX_ "Unsupported script encoding"); -#ifdef PERL_UTF16_FILTER - s+=2; - filter_add(S_utf16rev_textfilter, NULL); - New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8); - PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s); - s = news; + if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ + Perl_croak(aTHX_ "Unsupported script encoding"); +#ifndef PERL_NO_UTF16_FILTER + s += 2; + filter_add(S_utf16rev_textfilter, NULL); + New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8); + PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s); + s = news; #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding"); #endif - } - break; - + } + break; case 0xFE: - if (s[1] == 0xFF) { /* UTF-16 big-endian */ -#ifdef PERL_UTF16_FILTER - U8 *news; - filter_add(S_utf16_textfilter, NULL); - New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8); - PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s); - s = news; + if (s[1] == 0xFF) { /* UTF-16 big-endian */ +#ifndef PERL_NO_UTF16_FILTER + U8 *news; + filter_add(S_utf16_textfilter, NULL); + New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8); + PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s); + s = news; #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding"); #endif - } - break; - - case 0xEF: - if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { - s+=3; /* UTF-8 */ - } - break; - case 0: - if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ - s[2] == 0xFE && s[3] == 0xFF) - Perl_croak(aTHX_ "Unsupported script encoding"); -} -return s; + } + break; + case 0xEF: + if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { + s += 3; /* UTF-8 */ + } + break; + case 0: + if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ + s[2] == 0xFE && s[3] == 0xFF) + { + Perl_croak(aTHX_ "Unsupported script encoding"); + } + } + return s; } #ifdef PERL_OBJECT @@ -3502,11 +3502,9 @@ Perl_sv_lock(pTHX_ SV *osv) MAGIC *mg; SV *sv = osv; - SvLOCK(osv); + LOCK_SV_LOCK_MUTEX; if (SvROK(sv)) { sv = SvRV(sv); - SvUNLOCK(osv); - SvLOCK(sv); } mg = condpair_magic(sv); @@ -3523,7 +3521,7 @@ Perl_sv_lock(pTHX_ SV *osv) MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } - SvUNLOCK(sv); + UNLOCK_SV_LOCK_MUTEX; return sv; } diff --git a/utils/c2ph.PL b/utils/c2ph.PL index 3781daca96..38b259f0db 100644 --- a/utils/c2ph.PL +++ b/utils/c2ph.PL @@ -1393,11 +1393,8 @@ chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; unlink 'pstruct'; print "Linking c2ph to pstruct.\n"; if (defined $Config{d_link}) { - eval { link 'c2ph', 'pstruct'; }; - goto NOLINK if ($@ && $@ =~ /function is unimplemented/); # Win32 has $Config{d_link}, - # but Win9X doesn't have it + link 'c2ph', 'pstruct'; } else { -NOLINK: unshift @INC, '../lib'; require File::Copy; File::Copy::syscopy('c2ph', 'pstruct'); diff --git a/win32/makefile.mk b/win32/makefile.mk index dd2179284b..6722a5efcf 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1005,15 +1005,14 @@ $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES) perldll.def\n) $(IMPLIB) $*.lib $@ .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -mdll -o $@ -Wl,--base-file,perl.base \ - -Wl,--image-base,0x28000000 $(BLINK_FLAGS) \ + $(LINK32) -mdll -o $@ -Wl,--base-file -Wl,perl.base $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) dlltool --output-lib $(PERLIMPLIB) \ --dllname $(PERLDLL:b).dll \ --def perldll.def \ --base-file perl.base \ --output-exp perl.exp - $(LINK32) -mdll -o $@ -Wl,--image-base,0x28000000 $(BLINK_FLAGS) \ + $(LINK32) -mdll -o $@ $(BLINK_FLAGS) \ $(mktmp $(LKPRE) $(PERLDLL_OBJ:s,\,\\) $(LIBFILES) \ perl.exp $(LKPOST)) .ELSE @@ -1068,7 +1067,7 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES) $(@:s,\,\\),\n \ $(PERLIMPLIB) $(LIBFILES)\n) .ELIF "$(CCTYPE)" == "GCC" - $(LINK32) -mconsole -o $@ -Wl,--stack,0x800000 $(BLINK_FLAGS) \ + $(LINK32) -mconsole -o $@ $(BLINK_FLAGS) \ $(PERLEXE_OBJ) $(PERLIMPLIB) $(LIBFILES) .ELSE $(LINK32) -subsystem:console -out:$@ -stack:0x1000000 $(BLINK_FLAGS) \ diff --git a/win32/win32.c b/win32/win32.c index a4e1a7938b..60777fa36f 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -15,6 +15,11 @@ #define Win32_Winsock #endif #include <windows.h> +#ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */ +# include <shellapi.h> +#else + LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs); +#endif #include <winnt.h> #include <io.h> @@ -41,7 +46,6 @@ #endif #include <string.h> #include <stdarg.h> -#include <stdlib.h> /* get a real declaration of sys_nerr */ #include <float.h> #include <time.h> #if defined(_MSC_VER) || defined(__MINGW32__) @@ -1609,11 +1613,7 @@ win32_uname(struct utsname *name) GetSystemInfo(&info); #if defined(__BORLANDC__) || defined(__MINGW32__) -#ifndef _STRUCT_NAME -# define _STRUCT_NAME(s) s -# define _UNION_NAME(u) u -#endif - switch (info._UNION_NAME(u.)_STRUCT_NAME(s.)wProcessorArchitecture) { + switch (info.u.s.wProcessorArchitecture) { #else switch (info.wProcessorArchitecture) { #endif @@ -2057,6 +2057,9 @@ win32_feof(FILE *fp) DllExport char * win32_strerror(int e) { +#ifndef __BORLANDC__ /* Borland intolerance */ + extern int sys_nerr; +#endif DWORD source = 0; if (e < 0 || e > sys_nerr) { @@ -2491,8 +2494,8 @@ Nt4CreateHardLinkW( StreamId.dwStreamAttributes = 0; StreamId.dwStreamNameSize = 0; #if defined(__BORLANDC__) || defined(__MINGW32__) - StreamId.Size._UNION_NAME(u.)HighPart = 0; - StreamId.Size._UNION_NAME(u.)LowPart = dwLen; + StreamId.Size.u.HighPart = 0; + StreamId.Size.u.LowPart = dwLen; #else StreamId.Size.HighPart = 0; StreamId.Size.LowPart = dwLen; @@ -4100,21 +4103,13 @@ win32_free_argvw(pTHXo_ void *ptr) } } -typedef LPWSTR* (WINAPI CLTARGVW)(LPCWSTR lpCommandLine, int * pNumArgs); -/* load shell32.dll on demand (reduces number of DLLs loaded on startup by 1/3) - -- BKS 5-28-2000 */ void win32_argv2utf8(int argc, char** argv) { dTHXo; char* psz; int length, wargc; - HANDLE hDll = LoadLibraryA("shell32.dll"); - CLTARGVW *pCommandLineToArgvW = NULL; - LPWSTR* lpwStr = NULL; - if (hDll && (pCommandLineToArgvW = (CLTARGVW*)GetProcAddress(hDll, "CommandLineToArgvW"))) { - lpwStr = (*pCommandLineToArgvW)(GetCommandLineW(), &wargc); - } + LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc); if (lpwStr && argc) { while (argc--) { length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL); @@ -4124,7 +4119,6 @@ win32_argv2utf8(int argc, char** argv) } call_atexit(win32_free_argvw, argv); } - if (hDll) - FreeLibrary(hDll); GlobalFree((HGLOBAL)lpwStr); } + @@ -48,7 +48,7 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { name = SvPV(attr, len); - if ((negated = (*name == '-')) || (*name == '+')) { + if ((negated = (*name == '-'))) { name++; len--; } @@ -87,34 +87,6 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) } break; } - case SVt_IV: - case SVt_NV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVAV: - case SVt_PVHV: - switch ((int)len) { - case 8: - switch (*name) { - case 'r': - if (strEQ(name, "readonly")) { - if (negated) - SvREADONLY_off(sv); - else - SvREADONLY_on(sv); - if (SvTYPE(sv) == SVt_PVAV && SvMAGIC(sv) - && mg_find(sv, 'I')) { /* @ISA */ - if (negated) - PL_hints &= ~HINT_CT_MRESOLVE; - else - PL_hints |= HINT_CT_MRESOLVE; - } - continue; - } - break; - } - } break; default: /* nothing, yet */ |