diff options
Diffstat (limited to 'contrib/perl5/ext/B')
| -rw-r--r-- | contrib/perl5/ext/B/B.pm | 77 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B.xs | 51 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Asmdata.pm | 185 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Assembler.pm | 119 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Bytecode.pm | 415 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/C.pm | 30 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/CC.pm | 2 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Debug.pm | 17 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Deparse.pm | 448 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Disassembler.pm | 7 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Lint.pm | 6 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Showlex.pm | 23 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Stash.pm | 10 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/B/Terse.pm | 13 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/Makefile.PL | 20 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/O.pm | 3 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/defsubs_h.PL | 13 | ||||
| -rw-r--r-- | contrib/perl5/ext/B/ramblings/flip-flop | 4 |
18 files changed, 910 insertions, 533 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index 4512d91..c58e769 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -9,11 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(minus_c ppname + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs +@EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber amagic_generation - walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info init_av); + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -54,6 +60,21 @@ use strict; package B::OBJECT; } +sub B::GV::SAFENAME { + my $name = (shift())->NAME; + + # The regex below corresponds to the isCONTROLVAR macro + # from toke.c + + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + return $name; +} + +sub B::IV::int_value { + my ($self) = @_; + return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); +} + my $debug; my $op_count = 0; my @parents = (); @@ -125,6 +146,7 @@ sub objsym { sub walkoptree_exec { my ($op, $method, $level) = @_; + $level ||= 0; my ($sym, $ppname); my $prefix = " " x $level; for (; $$op; $op = $op->next) { @@ -184,7 +206,7 @@ sub walksymtable { *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -326,8 +348,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item IV +Returns the value of the IV, I<interpreted as +a signed integer>. This will be misleading +if C<FLAGS & SVf_IVisUV>. Perhaps you want the +C<int_value> method instead? + =item IVX +=item UVX + +=item int_value + +This method returns the value of the IV as an integer. +It differs from C<IV> in that it returns the correct +value regardless of whether it's stored signed or +unsigned. + =item needs64bits =item packiv @@ -358,6 +394,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item PV +This method is the one you usually want. It constructs a +string using the length and offset information in the struct: +for ordinary scalars it will return the string that you'd see +from Perl, even if it contains null characters. + +=item PVX + +This method is less often useful. It assumes that the string +stored in the struct is null-terminated, and disregards the +length information. + +It is the appropriate method to use if you need to get the name +of a lexical variable from a padname array. Lexical variable names +are always stored with a null terminator, and the length field +(SvCUR) is overloaded for other purposes and can't be relied on here. + =back =head2 B::PVMG METHODS @@ -426,6 +478,21 @@ This method returns TRUE if the GP field of the GV is NULL. =item NAME +=item SAFENAME + +This method returns the name of the glob, but if the first +character of the name is a control character, then it converts +it to ^X first, so that *^G would return "^G" rather than "\cG". + +It's useful if you want to print out the name of a variable. +If you restrict yourself to globs which exist at compile-time +then the result ought to be unambiguous, because code like +C<${"^G"} = 1> is compiled as two ops - a constant string and +a dereference (rv2gv) - so that the glob is created at runtime. + +If you're working with globs at runtime, and need to disambiguate +*^G from *{"^G"}, then you should use the raw NAME method. + =item STASH =item SV diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 9e29855..1005747 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -81,7 +81,7 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ -static SV *specialsv_list[4]; +static SV *specialsv_list[6]; static opclass cc_opclass(pTHX_ OP *o) @@ -386,11 +386,15 @@ BOOT: specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_begin_av() PL_beginav_save +#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -402,6 +406,12 @@ BOOT: B::AV B_init_av() +B::AV +B_begin_av() + +B::AV +B_end_av() + B::CV B_main_cv() @@ -515,6 +525,11 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_minus_c |= 0x10; + SV * cstring(sv) SV * sv @@ -567,11 +582,12 @@ char * OP_name(o) B::OP o CODE: - ST(0) = sv_newmortal(); - sv_setpv(ST(0), PL_op_name[o->op_type]); + RETVAL = PL_op_name[o->op_type]; + OUTPUT: + RETVAL -char * +void OP_ppaddr(o) B::OP o PREINIT: @@ -633,13 +649,20 @@ B::OP LOGOP_other(o) B::LOGOP o -#define LISTOP_children(o) o->op_children - MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ U32 LISTOP_children(o) B::LISTOP o + OP * kid = NO_INIT + int i = NO_INIT + CODE: + i = 0; + for (kid = o->op_first; kid; kid = kid->op_sibling) + i++; + RETVAL = i; + OUTPUT: + RETVAL #define PMOP_pmreplroot(o) o->op_pmreplroot #define PMOP_pmreplstart(o) o->op_pmreplstart @@ -693,8 +716,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) cSVOPo->op_sv -#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ @@ -862,11 +885,11 @@ packiv(sv) MODULE = B PACKAGE = B::NV PREFIX = Sv -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -878,6 +901,10 @@ SvRV(sv) MODULE = B PACKAGE = B::PV PREFIX = Sv +char* +SvPVX(sv) + B::PV sv + void SvPV(sv) B::PV sv @@ -1210,7 +1237,7 @@ CvXSUBANY(cv) MODULE = B PACKAGE = B::CV -U8 +U16 CvFLAGS(cv) B::CV cv @@ -1251,7 +1278,7 @@ HvARRAY(hv) I32 len; (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); - while (sv = hv_iternextsv(hv, &key, &len)) { + while ((sv = hv_iternextsv(hv, &key, &len))) { PUSHs(newSVpvn(key, len)); PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm index bc0eda9..dc176be 100644 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ b/contrib/perl5/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); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); # XXX insn_data is initialised this way because with a large # %insn_data = (foo => [...], bar => [...], ...) initialiser @@ -27,93 +27,93 @@ $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{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{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_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; $insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; $insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; @@ -128,9 +128,9 @@ $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_label} = [108, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_stashpv} = [109, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_file} = [110, \&PUT_pvindex, "GET_pvindex"]; $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"]; @@ -138,6 +138,9 @@ $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"]; +$insn_data{push_begin} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_init} = [119, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_end} = [120, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index 6c51a9a..5e798ce 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -4,14 +4,17 @@ # # 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 assemble_insn strip_comments - parse_statement uncstring); +@EXPORT_OK = qw(assemble_fh newasm endasm assemble); +$VERSION = 0.02; use strict; my %opnumber; @@ -20,7 +23,7 @@ for ($i = 0; defined($opname = ppname($i)); $i++) { $opnumber{$opname} = $i; } -my ($linenum, $errors); +my($linenum, $errors, $out); # global state, set up by newasm sub error { my $str = shift; @@ -49,13 +52,15 @@ sub B::Asmdata::PUT_U8 { return $c; } -sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_NV { sprintf("%lf\0", $_[0]) } -sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here +sub B::Asmdata::PUT_U16 { pack("S", $_[0]) } +sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) + # may not even be portable between compilers +sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -79,7 +84,7 @@ sub B::Asmdata::PUT_PV { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); - return pack("N", length($arg)) . $arg; + return pack("L", length($arg)) . $arg; } sub B::Asmdata::PUT_comment_t { my $arg = shift; @@ -90,7 +95,7 @@ sub B::Asmdata::PUT_comment_t { } return $arg . "\n"; } -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above sub B::Asmdata::PUT_none { my $arg = shift; error "extraneous argument: $arg" if defined $arg; @@ -103,12 +108,12 @@ sub B::Asmdata::PUT_op_tr_array { error "wrong number of arguments to op_tr_array"; @ary = (0) x 256; } - return pack("n256", @ary); + return pack("S256", @ary); } # XXX Check this works sub B::Asmdata::PUT_IV64 { my $arg = shift; - return pack("NN", $arg >> 32, $arg & 0xffffffff); + return pack("LL", $arg >> 32, $arg & 0xffffffff); } my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", @@ -138,6 +143,24 @@ 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{ @@ -183,27 +206,52 @@ sub assemble_insn { sub assemble_fh { my ($fh, $out) = @_; - my ($line, $insn, $arg); - $linenum = 0; - $errors = 0; + my $line; + my $asm = newasm($out); while ($line = <$fh>) { - $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)); - } + assemble($line); } + 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 "Assembly failed with $errors error(s)\n"; + 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)); } } @@ -217,14 +265,21 @@ B::Assembler - Assemble Perl bytecode =head1 SYNOPSIS - use Assembler; + 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 =head1 DESCRIPTION See F<ext/B/B/Assembler.pm>. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm index 27003b6..54d7c53 100644 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -6,16 +6,18 @@ # License or the Artistic License, as specified in the README file. # package B::Bytecode; + use strict; use Carp; -use IO::File; - -use B qw(minus_c main_cv main_root main_start comppadlist +use B qw(main_cv main_root main_start comppadlist class peekop walkoptree svref_2object cstring walksymtable - SVf_POK SVp_POK SVf_IOK SVp_IOK + init_av begin_av end_av + SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK + SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV + GVf_IMPORTED_SV SVTYPEMASK ); use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(assemble_fh); +use B::Assembler qw(newasm endasm assemble); my %optype_enum; my $i; @@ -31,41 +33,76 @@ sub POK () { SVf_POK|SVp_POK } # XXX Shouldn't be hardwired sub IOK () { SVf_IOK|SVp_IOK } -my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); -my $assembler_pid; +# 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); + } +} # 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 ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (strip_syntax_tree => \$strip_syntree, - compress_nullops => \$compress_nullops, +my ($compress_nullops, $omit_seq, $bypass_nullops); +my %optimise = (compress_nullops => \$compress_nullops, omit_sequence_numbers => \$omit_seq, bypass_nullops => \$bypass_nullops); +my $strip_syntree; # this is left here in case stripping the + # syntree ever becomes safe again + # -- BKS, June 2000 + my $nextix = 0; my %symtable; # maps object addresses to object indices. # Filled in at allocation (newsv/newop) time. + my %saved; # maps object addresses (for SVish classes) to "saved yet?" # flag. Set at FOO::bytecode time usually by SV::bytecode. # Manipulated via saved(), mark_saved(), unmark_saved(). +my %strtable; # maps shared strings to object indices + # Filled in at allocation (pvix) time + my $svix = -1; # we keep track of when the sv register contains an element # of the object table to avoid unnecessary repeated # consecutive ldsv instructions. + my $opix = -1; # Ditto for the op register. sub ldsv { my $ix = shift; if ($ix != $svix) { - print "ldsv $ix\n"; + asm "ldsv $ix\n"; $svix = $ix; } } sub stsv { my $ix = shift; - print "stsv $ix\n"; + asm "stsv $ix\n"; $svix = $ix; } @@ -76,14 +113,14 @@ sub set_svix { sub ldop { my $ix = shift; if ($ix != $opix) { - print "ldop $ix\n"; + asm "ldop $ix\n"; $opix = $ix; } } sub stop { my $ix = shift; - print "stop $ix\n"; + asm "stop $ix\n"; $opix = $ix; } @@ -100,12 +137,29 @@ 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", @@ -129,7 +183,7 @@ sub B::OBJECT::objix { sub B::SV::newix { my ($sv, $ix) = @_; - printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); + asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); stsv($ix); } @@ -137,7 +191,7 @@ sub B::GV::newix { my ($gv, $ix) = @_; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); - print "gv_fetchpv $name\n"; + asm "gv_fetchpv $name\n"; stsv($ix); } @@ -146,7 +200,7 @@ sub B::HV::newix { my $name = $hv->NAME; if ($name) { # It's a stash - printf "gv_stashpv %s\n", cstring($name); + asmf "gv_stashpv %s\n", cstring($name); stsv($ix); } else { # It's an ordinary HV. Fall back to ordinary newix method @@ -158,7 +212,7 @@ sub B::SPECIAL::newix { my ($sv, $ix) = @_; # Special case. $$sv is not the address of the SV but an # index into svspecialsv_list. - printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; + asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; stsv($ix); } @@ -166,8 +220,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); - print "newop $typenum\t# $class\n"; + croak("OP::newix: can't understand class $class") unless defined($typenum); + asm "newop $typenum\t# $class\n"; stop($ix); } @@ -180,7 +234,7 @@ sub B::OP::bytecode { my $op = shift; my $next = $op->next; my $nextix; - my $sibix = $op->sibling->objix; + my $sibix = $op->sibling->objix unless $strip_syntree; my $ix = $op->objix; my $type = $op->type; @@ -189,24 +243,24 @@ sub B::OP::bytecode { } $nextix = $next->objix; - printf "# %s\n", peekop($op) if $debug_bc; + asmf "# %s\n", peekop($op) if $debug_bc; ldop($ix); - 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; + asm "op_next $nextix\n"; + asm "op_sibling $sibix\n" unless $strip_syntree; + asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; + asmf("op_seq %d\n", $op->seq) unless $omit_seq; if ($type || !$compress_nullops) { - printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", + asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", $op->targ, $op->flags, $op->private; } } sub B::UNOP::bytecode { my $op = shift; - my $firstix = $op->first->objix; + my $firstix = $op->first->objix unless $strip_syntree; $op->B::OP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_first $firstix\n"; + asm "op_first $firstix\n"; } } @@ -214,7 +268,7 @@ sub B::LOGOP::bytecode { my $op = shift; my $otherix = $op->other->objix; $op->B::UNOP::bytecode; - print "op_other $otherix\n"; + asm "op_other $otherix\n"; } sub B::SVOP::bytecode { @@ -222,7 +276,7 @@ sub B::SVOP::bytecode { my $sv = $op->sv; my $svix = $sv->objix; $op->B::OP::bytecode; - print "op_sv $svix\n"; + asm "op_sv $svix\n"; $sv->bytecode; } @@ -230,7 +284,7 @@ sub B::PADOP::bytecode { my $op = shift; my $padix = $op->padix; $op->B::OP::bytecode; - print "op_padix $padix\n"; + asm "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -243,27 +297,18 @@ sub B::PVOP::bytecode { # if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness - print "op_pv_tr ", join(",", @shorts), "\n"; + asm "op_pv_tr ", join(",", @shorts), "\n"; } else { - printf "newpv %s\nop_pv\n", pvstring($pv); + asmf "newpv %s\nop_pv\n", pvstring($pv); } } sub B::BINOP::bytecode { my $op = shift; - my $lastix = $op->last->objix; + my $lastix = $op->last->objix unless $strip_syntree; $op->B::UNOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_last $lastix\n"; - } -} - -sub B::LISTOP::bytecode { - my $op = shift; - my $children = $op->children; - $op->B::BINOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_children $children\n"; + asm "op_last $lastix\n"; } } @@ -273,28 +318,29 @@ sub B::LOOP::bytecode { my $nextopix = $op->nextop->objix; my $lastopix = $op->lastop->objix; $op->B::LISTOP::bytecode; - print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; + asm "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; - if ($debug_bc) { - printf "# line %s:%d\n", $file, $line; - } + my $labelix = pvix($op->label); + my $stashix = pvix($stashpv); + my $fileix = pvix($file); + $warnings->bytecode; $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; -newpv %s -cop_label -newpv %s -cop_stashpv + asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; +cop_label %d +cop_stashpv %d cop_seq %d -newpv %s -cop_file +cop_file %d cop_arybase %d cop_line $line cop_warnings $warningsix @@ -322,13 +368,13 @@ sub B::PMOP::bytecode { } $op->B::LISTOP::bytecode; if ($opname eq "pushre") { - printf "op_pmreplrootgv $replrootix\n"; + asmf "op_pmreplrootgv $replrootix\n"; } else { - print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; + asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; } my $re = pvstring($op->precomp); # op_pmnext omitted since a perl bug means it's sometime corrupt - printf <<"EOT", $op->pmflags, $op->pmpermflags; + asmf <<"EOT", $op->pmflags, $op->pmpermflags; op_pmflags 0x%x op_pmpermflags 0x%x newpv $re @@ -343,7 +389,7 @@ sub B::SV::bytecode { my $refcnt = $sv->REFCNT; my $flags = sprintf("0x%x", $sv->FLAGS); ldsv($ix); - print "sv_refcnt $refcnt\nsv_flags $flags\n"; + asm "sv_refcnt $refcnt\nsv_flags $flags\n"; mark_saved($sv); } @@ -351,7 +397,7 @@ sub B::PV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; } sub B::IV::bytecode { @@ -359,14 +405,14 @@ sub B::IV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::SV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV } sub B::NV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); } sub B::RV::bytecode { @@ -376,7 +422,7 @@ sub B::RV::bytecode { my $rvix = $rv->objix; $rv->bytecode; $sv->B::SV::bytecode; - print "xrv $rvix\n"; + asm "xrv $rvix\n"; } sub B::PVIV::bytecode { @@ -384,7 +430,7 @@ sub B::PVIV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::PV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; } sub B::PVNV::bytecode { @@ -404,12 +450,12 @@ sub B::PVNV::bytecode { } else { my $pv = $sv->PV; $sv->B::IV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); if ($flag == 1) { $pv .= "\0" . $sv->TABLE; - printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; + asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; } else { - printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; } } } @@ -431,9 +477,9 @@ sub B::PVMG::bytecode { # @mgobjix = map($_->OBJ->objix, @mgchain); $sv->B::PVNV::bytecode($flag); - print "xmg_stash $stashix\n"; + asm "xmg_stash $stashix\n"; foreach $mg (@mgchain) { - printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", + asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); } } @@ -442,7 +488,7 @@ sub B::PVLV::bytecode { my $sv = shift; return if saved($sv); $sv->B::PVMG::bytecode; - printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); + asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); xlv_targoff %d xlv_targlen %d xlv_type %s @@ -454,46 +500,63 @@ sub B::BM::bytecode { return if saved($sv); # See PVNV::bytecode for an explanation of what the argument does $sv->B::PVMG::bytecode(1); - printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", + asmf "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); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; + asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x EOT my $refcnt = $gv->REFCNT; - printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; return if $gv->is_empty; - printf <<"EOT", $gv->LINE, pvstring($gv->FILE); + asmf <<"EOT", $gv->LINE, pvix($gv->FILE); gp_line %d -newpv %s -gp_file +gp_file %d EOT my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); my $egv = $gv->EGV; my $egvix = $egv->objix; my $gvrefcnt = $gv->GvREFCNT; - printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; + asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { - print "gp_share $egvix\n"; + asm "gp_share $egvix\n"; } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; my @subfield_names = qw(SV AV HV CV FORM IO); + @subfield_names = grep {; + no strict 'refs'; + !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); + } @subfield_names; my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } # Now save all the subfields my $sv; @@ -523,10 +586,10 @@ sub B::HV::bytecode { } ldsv($ix); for ($i = 0; $i < @contents; $i += 2) { - printf("newpv %s\nhv_store %d\n", + asmf("newpv %s\nhv_store %d\n", pvstring($contents[$i]), $ixes[$i / 2]); } - printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; + asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; } } @@ -551,22 +614,26 @@ sub B::AV::bytecode { # create an AV with NEWSV and SvUPGRADE rather than doing newAV # which is what sets AvMAX and AvFILL. ldsv($ix); - printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; + asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST + asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; if ($fill > -1) { my $elix; foreach $elix (@ixes) { - print "av_push $elix\n"; + asm "av_push $elix\n"; } } else { if ($max > -1) { - print "av_extend $max\n"; + asm "av_extend $max\n"; } } + asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above } sub B::CV::bytecode { my $cv = shift; return if saved($cv); + return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); + my $fileix = pvix($cv->FILE); my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; @@ -581,10 +648,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++) { - printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; - printf "newpv %s\nxcv_file\n", pvstring($cv->FILE); + asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + asmf "xcv_file %d\n", $fileix; # Now save all the subfields (except for CvROOT which was handled # above) and CvSTART (now the initial element of @subfields). shift @subfields; # bye-bye CvSTART @@ -607,17 +674,17 @@ sub B::IO::bytecode { $io->B::PVMG::bytecode; ldsv($ix); - print "xio_top_gv $top_gvix\n"; - print "xio_fmt_gv $fmt_gvix\n"; - print "xio_bottom_gv $bottom_gvix\n"; + asm "xio_top_gv $top_gvix\n"; + asm "xio_fmt_gv $fmt_gvix\n"; + asm "xio_bottom_gv $bottom_gvix\n"; my $field; foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); + asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); } foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - printf "xio_%s %d\n", lc($field), $io->$field(); + asmf "xio_%s %d\n", lc($field), $io->$field(); } - printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; + asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; $top_gv->bytecode; $fmt_gv->bytecode; $bottom_gv->bytecode; @@ -628,8 +695,7 @@ sub B::SPECIAL::bytecode { } sub bytecompile_object { - my $sv; - foreach $sv (@_) { + for my $sv (@_) { svref_2object($sv)->bytecode; } } @@ -637,7 +703,7 @@ sub bytecompile_object { sub B::GV::bytecodecv { my $gv = shift; my $cv = $gv->CV; - if ($$cv && !saved($cv)) { + if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); @@ -646,43 +712,66 @@ sub B::GV::bytecodecv { } } -sub bytecompile_main { - my $curpad = (comppadlist->ARRAY)[1]; - my $curpadix = $curpad->objix; - $curpad->bytecode; - walkoptree(main_root, "bytecode"); - warn "done main program, now walking symbol table\n" if $debug_bc; - my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol - SelectSaver blib Cwd)) - { - $exclude{$pack."::"} = 1; +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; + } } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "bytecodecv", sub { - warn "considering $_[0]\n" if $debug_bc; - return !defined($exclude{$_[0]}); - }); - if (!$module_only) { - printf "main_root %d\n", main_root->objix; - printf "main_start %d\n", main_start->objix; - printf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? + if (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 prepare_assemble { - my $newfh = IO::File->new_tmpfile; - select($newfh); - binmode $newfh; - return $newfh; +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 do_assemble { - my $fh = shift; - seek($fh, 0, 0); # rewind the temporary file - assemble_fh($fh, sub { print OUT @_ }); +sub bytecompile_main { + my $curpad = (comppadlist->ARRAY)[1]; + my $curpadix = $curpad->objix; + $curpad->bytecode; + save_call_queues(); + walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; + warn "done main program, now walking symbol table\n" if $debug_bc; + if (@packages) { + no strict qw(refs); + walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); + } else { + die "No packages requested for compilation!\n"; + } + asmf "main_root %d\n", main_root->objix; + asmf "main_start %d\n", main_start->objix; + asmf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? } sub compile { @@ -690,7 +779,7 @@ sub compile { my ($option, $opt, $arg); open(OUT, ">&STDOUT"); binmode OUT; - select(OUT); + select OUT; OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { @@ -727,8 +816,6 @@ 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") { @@ -747,9 +834,6 @@ sub compile { foreach $ref (values %optimise) { $$ref = 0; } - if ($arg >= 6) { - $strip_syntree = 1; - } if ($arg >= 2) { $bypass_nullops = 1; } @@ -757,28 +841,30 @@ sub compile { $compress_nullops = 1; $omit_seq = 1; } + } elsif ($opt eq "u") { + $arg ||= shift @options; + push @packages, $arg; + } else { + warn qq(ignoring unknown option "$opt$arg"\n); } } + if (! @packages) { + warn "No package specified for compilation, assuming main::\n"; + @packages = qw(main); + } if (@options) { - 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; - } + die "Extraneous options left on B::Bytecode commandline: @options\n"; } else { - return sub { - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; + return sub { + newasm(\&apr) unless $no_assemble; bytecompile_main(); - do_assemble($newfh) unless $no_assemble; - } + endasm() unless $no_assemble; + }; } } +sub apr { print @_; } + 1; __END__ @@ -848,18 +934,11 @@ 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<-O6> adds B<-fstrip-syntax-tree>. +B<-O2> adds B<-fbypass-nullops>. =item B<-D> @@ -887,33 +966,33 @@ Prints each CV taken from the final symbol tree walk. Output (bytecode) assembler source rather than piping it through the assembler and outputting bytecode. -=item B<-m> - -Compile as a module rather than a standalone program. Currently this -just means that the bytecodes for initialising C<main_start>, -C<main_root> and C<curpad> are omitted. - +=item B<-upackage> + +Stores package in the output. + =back =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl - perl -MO=Bytecode,-S foo.pl > foo.S + perl -MO=Bytecode,-S,-umain foo.pl > foo.S assemble foo.S > foo.plc Note that C<assemble> lives in the C<B> subdirectory of your perl library directory. The utility called perlcc may also be used to help make use of this compiler. - perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm =head1 BUGS -Plenty. Current status: experimental. +Output is still huge and there are still occasional crashes during +either compilation or ByteLoading. Current status: experimental. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index d0c8159..4befe79 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -225,11 +225,10 @@ sub B::LISTOP::save { my ($op, $level) = @_; my $sym = objsym($op); return $sym if defined $sym; - $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last}, - $op->children)); + $op->private, ${$op->first}, ${$op->last})); my $ix = $listopsect->index; $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); savesym($op, "(OP*)&listop_list[$ix]"); @@ -255,11 +254,11 @@ sub B::LOOP::save { #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, - $op->children, ${$op->redoop}, ${$op->nextop}, + ${$op->redoop}, ${$op->nextop}, ${$op->lastop})); my $ix = $loopsect->index; $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); @@ -351,10 +350,10 @@ sub B::PMOP::save { # pmnext handling is broken in perl itself, I think. Bad op_pmnext # fields aren't noticed in perl's runtime (unless you try reset) but we # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x", ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, - ${$op->first}, ${$op->last}, $op->children, + ${$op->first}, ${$op->last}, $replrootfield, $replstartfield, $op->pmflags, $op->pmpermflags,)); my $pm = sprintf("pmop_list[%d]", $pmopsect->index); @@ -1020,9 +1019,8 @@ sub output_all { print <<"EOT"; static int $init_name() { - dTHR; dTARG; - djSP; + dSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -1050,15 +1048,15 @@ typedef struct { STRLEN xpv_cur; /* length of xp_pv as a C string */ STRLEN xpv_len; /* allocated size */ IV xof_off; /* integer value */ - double xnv_nv; /* numeric value, if any */ + NV xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) (CV*); - void * xcv_xsubany; + void (*xcv_xsub) (pTHXo_ CV*); + ANY xcv_xsubany; GV * xcv_gv; char * xcv_file; long xcv_depth; /* >= 2 indicates recursive call */ @@ -1174,7 +1172,7 @@ xs_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print "\n#ifdef USE_DYNAMIC_LOADING"; print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; @@ -1210,7 +1208,7 @@ dl_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); print("\ttarg=sv_newmortal();\n"); @@ -1338,7 +1336,7 @@ sub should_save # Now see if current package looks like an OO class this is probably too strong. foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) { - if ($package->can($m)) + if (UNIVERSAL::can($package, $m)) { warn "$package has method $m: saving package\n";#debug return mark_package($package); @@ -1368,7 +1366,7 @@ sub walkpackages if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walkpackages(\%glob, $recurse, $sym); } diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index c5ca2a3..51922ee 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -151,7 +151,7 @@ sub init_pp { $ppname = shift; $runtime_list_ref = []; $declare_ref = {}; - runtime("djSP;"); + runtime("dSP;"); declare("I32", "oldsave"); declare("SV", "**svp"); map { declare("SV", "*$_") } qw(sv src dst left right); diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm index ae7a973..049195b 100644 --- a/contrib/perl5/ext/B/B/Debug.pm +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -33,6 +33,16 @@ sub B::BINOP::debug { printf "\top_last\t\t0x%x\n", ${$op->last}; } +sub B::LOOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; + op_redoop 0x%x + op_nextop 0x%x + op_lastop 0x%x +EOT +} + sub B::LOGOP::debug { my ($op) = @_; $op->B::UNOP::debug(); @@ -53,7 +63,6 @@ sub B::PMOP::debug { printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmshort->debug; $op->pmreplroot->debug; } @@ -209,14 +218,14 @@ EOT sub B::GV::debug { my ($gv) = @_; if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME; + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; return; } my ($sv) = $gv->SV; my ($av) = $gv->AV; my ($cv) = $gv->CV; $gv->B::SV::debug; - printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; + printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; NAME %s STASH %s (0x%x) SV 0x%x @@ -244,7 +253,7 @@ sub B::SPECIAL::debug { sub compile { my $order = shift; B::clearsym(); - if ($order eq "exec") { + if ($order && $order eq "exec") { return sub { walkoptree_exec(main_start, "debug") } } else { return sub { walkoptree(main_root, "debug") } diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm index cd53c11..ead02e1 100644 --- a/contrib/perl5/ext/B/B/Deparse.pm +++ b/contrib/perl5/ext/B/B/Deparse.pm @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -8,16 +8,16 @@ package B::Deparse; use Carp 'cluck', 'croak'; -use Config; use B qw(class main_root main_start main_cv svref_2object opnumber OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY SVf_IOK SVf_NOK SVf_ROK SVf_POK + CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.59; +$VERSION = 0.60; use strict; # Changes between 0.50 and 0.51: @@ -83,6 +83,12 @@ use strict; # - added support for Chip's OP_METHOD_NAMED # - added support for Ilya's OPpTARGET_MY optimization # - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures # Todo: # - finish tr/// changes @@ -93,8 +99,8 @@ use strict; # - left/right context # - recognize `use utf8', `use integer', etc # - treat top-level block specially for incremental output -# - interpret in high bit chars in string as utf8 \x{...} (when?) -# - copy comments (look at real text with $^P?) +# - interpret high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) @@ -108,7 +114,6 @@ use strict; # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - auto-apply `-u'? -# - while{} with one-statement continue => for(; XXX; XXX) {}? # - -uPackage:: descend recursively? # - here-docs? # - <DATA>? @@ -252,17 +257,17 @@ sub walk_sub { walk_tree($op, sub { my $op = shift; if ($op->name eq "gv") { - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); if ($op->next->name eq "entersub") { - next if $self->{'subs_done'}{$$gv}++; - next if class($gv->CV) eq "SPECIAL"; + return if $self->{'subs_done'}{$$gv}++; + return if class($gv->CV) eq "SPECIAL"; $self->todo($gv, $gv->CV, 0); $self->walk_sub($gv->CV); } elsif ($op->next->name eq "enterwrite" or ($op->next->name eq "rv2gv" and $op->next->next->name eq "enterwrite")) { - next if $self->{'forms_done'}{$$gv}++; - next if class($gv->FORM) eq "SPECIAL"; + return if $self->{'forms_done'}{$$gv}++; + return if class($gv->FORM) eq "SPECIAL"; $self->todo($gv, $gv->FORM, 1); $self->walk_sub($gv->FORM); } @@ -345,6 +350,10 @@ sub new { $self->{'cuddle'} = "\n"; $self->{'indent_size'} = 4; $self->{'use_tabs'} = 0; + $self->{'expand'} = 0; + $self->{'unquote'} = 0; + $self->{'linenums'} = 0; + $self->{'parens'} = 0; $self->{'ex_const'} = "'???'"; while (my $arg = shift @_) { if (substr($arg, 0, 2) eq "-u") { @@ -357,6 +366,8 @@ sub new { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; } } return $self; @@ -378,7 +389,7 @@ sub compile { while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } - print indent(join("", @text)), "\n" if @text; + print $self->indent(join("", @text)), "\n" if @text; } } @@ -393,6 +404,7 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; +# cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); @@ -433,6 +445,13 @@ sub deparse_sub { if ($cv->FLAGS & SVf_POK) { $proto = "(". $cv->PV . ") "; } + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { + $proto .= ": "; + $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; + $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; + $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + } + local($self->{'curcv'}) = $cv; local($self->{'curstash'}) = $self->{'curstash'}; if (not null $cv->ROOT) { @@ -553,7 +572,11 @@ sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("local", $text, $cx, 16); + if (want_scalar($op)) { + return "local $text"; + } else { + return $self->maybe_parens_func("local", $text, $cx, 16); + } } else { return $text; } @@ -581,7 +604,11 @@ sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("my", $text, $cx, 16); + if (want_scalar($op)) { + return "my $text"; + } else { + return $self->maybe_parens_func("my", $text, $cx, 16); + } } else { return $text; } @@ -672,70 +699,69 @@ sub pp_entertry { # see also leavetry return "XXX"; } -# leave and scope/lineseq should probably share code -sub pp_leave { +sub lineseq { my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - local($self->{'curstash'}) = $self->{'curstash'}; - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - for (; !null($kid); $kid = $kid->sibling) { + my(@ops) = @_; + my($expr, @exprs); + for (my $i = 0; $i < @ops; $i++) { $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + last if $i > $#ops; } - $expr .= $self->deparse($kid, 0); + if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and + $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) + { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } - if ($cx > 0) { # inside an expression - return "do { " . join(";\n", @exprs) . " }"; - } else { - return join(";\n", @exprs) . ";"; - } + return join(";\n", @exprs); } -sub pp_scope { - my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { - $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + local($self->{'curstash'}) = $self->{'curstash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; } - $expr .= $self->deparse($kid, 0); - push @exprs, $expr if length $expr; + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . join(";\n", @exprs) . " }"; + return "do { " . $self->lineseq(@kids) . " }"; } else { - return join(";\n", @exprs) . ";"; + return $self->lineseq(@kids) . ";"; } } -sub pp_lineseq { pp_scope(@_) } +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. @@ -747,7 +773,7 @@ sub gv_name { my $self = shift; my $gv = shift; my $stash = $gv->STASH->NAME; - my $name = $gv->NAME; + my $name = $gv->SAFENAME; if ($stash eq $self->{'curstash'} or $globalnames{$name} or $name =~ /^[^A-Za-z_]/) { @@ -755,8 +781,8 @@ sub gv_name { } else { $stash = $stash . "::"; } - if ($name =~ /^([\cA-\cZ])$/) { - $name = "^" . chr(64 + ord($1)); + if ($name =~ /^\^../) { + $name = "{$name}"; # ${^WARNING_BITS} etc } return $stash . $name; } @@ -840,7 +866,7 @@ sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) } +sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } sub pp_negate { maybe_targmy(@_, \&real_negate) } sub real_negate { @@ -917,7 +943,6 @@ sub pp_prototype { unop(@_, "prototype") } sub pp_close { unop(@_, "close") } sub pp_fileno { unop(@_, "fileno") } sub pp_umask { unop(@_, "umask") } -sub pp_binmode { unop(@_, "binmode") } sub pp_untie { unop(@_, "untie") } sub pp_tied { unop(@_, "tied") } sub pp_dbmclose { unop(@_, "dbmclose") } @@ -1373,11 +1398,14 @@ sub logop { my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + if ($cx == 0 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + } elsif ($cx == 0 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; @@ -1457,6 +1485,7 @@ sub pp_return { listop(@_, "return") } sub pp_open { listop(@_, "open") } sub pp_pipe_op { listop(@_, "pipe") } sub pp_tie { listop(@_, "tie") } +sub pp_binmode { listop(@_, "binmode") } sub pp_dbmopen { listop(@_, "dbmopen") } sub pp_sselect { listop(@_, "select") } sub pp_select { listop(@_, "select") } @@ -1653,6 +1682,13 @@ sub pp_list { } } +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; @@ -1660,52 +1696,55 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and is_scope($true) and is_scope($false)) { + unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } + } + $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->name eq "lineseq") { # braces w/o scope => elsif - my $head = "if ($cond) {\n\t$true\n\b}"; - my @elsifs; - while (!null($false) and $false->name eq "lineseq") { - my $newop = $false->first->sibling->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; } - $false = $self->deparse($false, 0); - return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; + return $head . join($cuddle, "", @elsifs) . $false; } -sub pp_leaveloop { +sub loop_common { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; + my $body; + my $cond = undef; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) + $cond = ""; } else { $bare = 1; } + $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; @@ -1737,62 +1776,60 @@ sub pp_leaveloop { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; - $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"} - ->{$kid->name}; - $head = "$name (" . $self->deparse($kid->first, 1) . ") "; - $kid = $kid->first->sibling; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } - # The third-to-last kid is the continue block if the pointer used - # by `next BLOCK' points to its first OP, which happens to be the - # the op_next of the head of the _previous_ statement. - # Unless it's a bare loop, in which case it's last, since there's - # no unstack or extra nextstate. - # Except if the previous head isn't null but the first kid is - # (because it's a nulled out nextstate in a scope), in which - # case the head's next is advanced past the null but the nextop's - # isn't, so we need to try nextop->next. - my $precont; - my $cont = $kid->first; - if ($bare) { - while (!null($cont->sibling)) { - $precont = $cont; - $cont = $cont->sibling; - } - } else { - while (!null($cont->sibling->sibling->sibling)) { - $precont = $cont; - $cont = $cont->sibling; + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's penultimate child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the third-to-last child in the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(@states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; } - } - if ($precont and $ {$precont->next} == $ {$enter->nextop} - || $ {$precont->next} == $ {$enter->nextop->next} ) - { - my $state = $kid->first; - my $cuddle = $self->{'cuddle'}; - my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { - $expr = ""; - if (is_state $state) { - $expr = $self->deparse($state, 0); - $state = $state->sibling; - last if null $kid; - } - $expr .= $self->deparse($state, 0); - push @exprs, $expr if $expr; - } - $kid = join(";\n", @exprs); - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; } else { $cont = "\cK"; - $kid = $self->deparse($kid, 0); + $body = $self->deparse($body, 0); } - return $head . "{\n\t" . $kid . "\n\b}" . $cont; + return $head . "{\n\t" . $body . "\n\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling, $cx, $init); } sub pp_leavetry { @@ -1814,7 +1851,7 @@ sub pp_null { } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op); + return $self->dquote($op, $cx); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -1832,21 +1869,10 @@ sub pp_null { } } -# the aassign in-common check messes up SvCUR (always setting it -# to a value >= 100), but it's probably safe to assume there -# won't be any NULs in the names of my() variables. (with -# stash variables, I wouldn't be so sure) -sub padname_fix { - my $str = shift; - $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; - return $str; -} - sub padname { my $self = shift; my $targ = shift; - my $str = $self->padname_sv($targ)->PV; - return padname_fix($str); + return $self->padname_sv($targ)->PVX; } sub padany { @@ -1879,37 +1905,34 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } -sub maybe_padgv { +sub gv_or_padgv { my $self = shift; my $op = shift; - my $gv; - if ($Config{useithreads}) { - $gv = $self->padval($op->padix); - } - else { - $gv = $op->gv; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; } - return $gv; } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -2220,7 +2243,7 @@ sub pp_entersub { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { - my $gv = $self->maybe_padgv($kid->first); + my $gv = $self->gv_or_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } @@ -2252,9 +2275,9 @@ sub pp_entersub { } else { if (defined $proto and $proto eq "") { return $kid; - } elsif ($proto eq "\$") { + } elsif (defined $proto and $proto eq "\$") { return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($proto or $simple) { + } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; @@ -2350,7 +2373,7 @@ sub const { if (class($sv) eq "SPECIAL") { return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif ($sv->FLAGS & SVf_IOK) { - return $sv->IV; + return $sv->int_value; } elsif ($sv->FLAGS & SVf_NOK) { return $sv->NV; } elsif ($sv->FLAGS & SVf_ROK) { @@ -2381,7 +2404,9 @@ sub pp_const { # return $self->const_sv($op)->PV; # } my $sv = $self->const_sv($op); - return const($sv); +# return const($sv); + my $c = const $sv; + return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c; } sub dq { @@ -2391,7 +2416,13 @@ sub dq { if ($type eq "const") { return uninterp(escape_str(unback($self->const_sv($op)->PV))); } elsif ($type eq "concat") { - return $self->dq($op->first) . $self->dq($op->last); + my $first = $self->dq($op->first); + my $last = $self->dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2418,7 +2449,7 @@ sub pp_backtick { sub dquote { my $self = shift; - my($op, $cx) = shift; + my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, @@ -2486,7 +2517,7 @@ sub pchr { # ASCII sub collapse { my(@chars) = @_; - my($c, $str, $tr); + my($str, $c, $tr) = (""); for ($c = 0; $c < @chars; $c++) { $tr = $chars[$c]; $str .= pchr($tr); @@ -2539,7 +2570,7 @@ sub tr_decode_byte { } @from = @newfrom; } - unless ($flags & OPpTRANS_DELETE) { + unless ($flags & OPpTRANS_DELETE || !@to) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } my($from, $to); @@ -2678,9 +2709,15 @@ sub re_dq { my $op = shift; my $type = $op->name; if ($type eq "const") { - return uninterp($self->const_sv($op)->PV); + return re_uninterp($self->const_sv($op)->PV); } elsif ($type eq "concat") { - return $self->re_dq($op->first) . $self->re_dq($op->last); + my $first = $self->re_dq($op->first); + my $last = $self->re_dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2842,8 +2879,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>] - I<prog.pl> +B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> =head1 DESCRIPTION @@ -2988,6 +3025,55 @@ file is compiled as a main program. =back +=item B<-x>I<LEVEL> + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I<LEVEL> should be a digit, with higher values +meaning more expansion. As with B<-q>, this actually involves turning off +special cases in B::Deparse's normal operations. + +If I<LEVEL> is at least 3, for loops will be translated into equivalent +while loops with continue blocks; for instance + + for ($i = 0; $i < 10; ++$i) { + print $i; + } + +turns into + + $i = 0; + while ($i < 10) { + print $i; + } continue { + ++$i + } + +Note that in a few cases this translation can't be perfectly carried back +into the source code -- if the loop's initializer declares a my variable, +for instance, it won't have the correct scope outside of the loop. + +If I<LEVEL> is at least 7, if statements will be translated into equivalent +expressions using C<&&>, C<?:> and C<do {}>; for instance + + print 'hi' if $nice; + if ($nice) { + print 'hi'; + } + if ($nice) { + print 'hi'; + } else { + print 'bye'; + } + +turns into + + $nice and print 'hi'; + $nice and do { print 'hi' }; + $nice ? do { print 'hi' } : do { print 'bye' }; + +Long sequences of elsifs will turn into nested ternary operators, which +B::Deparse doesn't know how to indent nicely. + =back =head1 USING B::Deparse AS A MODULE @@ -3034,7 +3120,7 @@ See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier +Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index d054a2d..212532b 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -31,6 +31,13 @@ sub GET_U16 { return unpack("n", $str); } +sub GET_NV { + my $fh = shift; + my $str = $fh->readn(8); + croak "reached EOF while reading NV" unless length($str) == 8; + return unpack("N", $str); +} + sub GET_U32 { my $fh = shift; my $str = $fh->readn(4); diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm index ed0d07d..094b3cf 100644 --- a/contrib/perl5/ext/B/B/Lint.pm +++ b/contrib/perl5/ext/B/B/Lint.pm @@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents +use B qw(walkoptree main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY ); @@ -277,12 +277,12 @@ sub B::GV::lintcv { return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; + walkoptree($root, "lint") if $$root; } sub do_lint { my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; + walkoptree(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); diff --git a/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm index 648f95d..842ca3e 100644 --- a/contrib/perl5/ext/B/B/Showlex.pm +++ b/contrib/perl5/ext/B/B/Showlex.pm @@ -12,7 +12,24 @@ use B::Terse (); # to see the names of file scope lexicals used by bar.pl # -sub showarray { +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + print "$i: "; + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + $sv->terse; + } + } +} + +sub showvaluearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; @@ -26,8 +43,8 @@ sub showarray { sub showlex { my ($objname, $namesav, $valsav) = @_; - showarray("Pad of lexical names for $objname", $namesav); - showarray("Pad of lexical values for $objname", $valsav); + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); } sub showlex_obj { diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm index 0a3543e..f3a8247 100644 --- a/contrib/perl5/ext/B/B/Stash.pm +++ b/contrib/perl5/ext/B/B/Stash.pm @@ -2,11 +2,19 @@ # vishalb@hotmail.com package B::Stash; +=pod + +=head1 NAME + +B::Stash - show what stashes are loaded + +=cut + BEGIN { %Seen = %INC } CHECK { my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_;} @arr; + @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; print "-umain,-u", join (",-u",@arr) ,"\n"; } sub scan{ diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm index 66b5cfc..52f0549 100644 --- a/contrib/perl5/ext/B/B/Terse.pm +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -1,7 +1,7 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec - main_start main_root cstring svref_2object); +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow + main_start main_root cstring svref_2object SVf_IVisUV); use B::Asmdata qw(@specialsv_name); sub terse { @@ -15,7 +15,7 @@ sub terse { } sub compile { - my $order = shift; + my $order = @_ ? shift : ""; my @options = @_; B::clearsym(); if (@options) { @@ -37,7 +37,7 @@ sub compile { } sub indent { - my $level = shift; + my $level = @_ ? shift : 0; return " " x $level; } @@ -102,13 +102,14 @@ sub B::GV::terse { $stash = $stash . "::"; } print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; + printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; } sub B::IV::terse { my ($sv, $level) = @_; print indent($level); - printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; + my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; + printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; } sub B::NV::terse { diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index cb9696b..dcf6a1d 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -1,5 +1,6 @@ use ExtUtils::MakeMaker; use Config; +use File::Spec; my $e = $Config{'exe_ext'}; my $o = $Config{'obj_ext'}; @@ -29,8 +30,19 @@ sub post_constants { "\nLIBS = $Config::Config{libs}\n" } -sub postamble { -' -B$(OBJ_EXT) : defsubs.h -' +sub upupfile { + File::Spec->catfile(File::Spec->updir, + File::Spec->updir, $_[0]); +} + +sub MY::postamble { + my $op_h = upupfile('op.h'); + my $cop_h = upupfile('cop.h'); + my $noecho = shift->{NOECHO}; +" +B\$(OBJ_EXT) : defsubs.h + +defsubs.h :: $op_h $cop_h + $noecho \$(NOOP) +" } diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm index 352f8d4..2ef91ed 100644 --- a/contrib/perl5/ext/B/O.pm +++ b/contrib/perl5/ext/B/O.pm @@ -1,5 +1,5 @@ package O; -use B qw(minus_c); +use B qw(minus_c save_BEGINs); use Carp; sub import { @@ -11,6 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; + save_BEGINs; eval 'CHECK { &$compilesub() }'; } else { die $compilesub; diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL index 80ef936..da6566b 100644 --- a/contrib/perl5/ext/B/defsubs_h.PL +++ b/contrib/perl5/ext/B/defsubs_h.PL @@ -6,16 +6,23 @@ my ($out) = __FILE__ =~ /(^.*)\.PL/i; $out =~ s/_h$/.h/; open(OUT,">$out") || die "Cannot open $file:$!"; print "Extracting $out...\n"; -foreach my $const (qw(AVf_REAL +foreach my $const (qw( + AVf_REAL HEf_SVKEY + SVf_READONLY SVTYPEMASK + GVf_IMPORTED_AV GVf_IMPORTED_HV + GVf_IMPORTED_SV GVf_IMPORTED_CV + CVf_METHOD CVf_LOCKED CVf_LVALUE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK - SVf_ROK SVp_IOK SVp_POK )) + SVf_ROK SVp_IOK SVp_POK SVp_NOK + )) { doconst($const); } foreach my $file (qw(op.h cop.h)) { - open(OPH,"../../$file") || die "Cannot open ../../$file:$!"; + my $path = $^O eq 'MacOS' ? ":::$file" : "../../$file"; + open(OPH,"$path") || die "Cannot open $path:$!"; while (<OPH>) { doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop index e0cb8ff..e08333d 100644 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -9,13 +9,13 @@ PP(pp_range) } pp_range is a LOGOP. -In array context, it just returns op_next. +In list context, it just returns op_next. In scalar context it checks the truth of targ and returns op_other if true, op_next if false. flip is an UNOP. It "looks after" its child which is always a pp_range LOGOP. -In array context, it just returns the child's op_other. +In list context, it just returns the child's op_other. In scalar context, there are three possible outcomes: (1) set child's targ to 1, our targ to 1 and return op_next. (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other. |
