summaryrefslogtreecommitdiff
path: root/ext/B
diff options
context:
space:
mode:
Diffstat (limited to 'ext/B')
-rw-r--r--ext/B/B.pm5
-rw-r--r--ext/B/B.xs23
-rw-r--r--ext/B/B/Asmdata.pm228
-rw-r--r--ext/B/B/Assembler.pm119
-rw-r--r--ext/B/B/Bytecode.pm410
-rw-r--r--ext/B/B/Debug.pm3
-rw-r--r--ext/B/B/Deparse.pm14
-rw-r--r--ext/B/Makefile.PL20
-rw-r--r--ext/B/O.pm3
-rw-r--r--ext/B/defsubs_h.PL10
-rw-r--r--ext/B/ramblings/flip-flop4
11 files changed, 514 insertions, 325 deletions
diff --git a/ext/B/B.pm b/ext/B/B.pm
index 4512d916e6..50364fa1d2 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -9,11 +9,12 @@ package B;
use XSLoader ();
require Exporter;
@ISA = qw(Exporter);
-@EXPORT_OK = qw(minus_c ppname
+@EXPORT_OK = qw(minus_c ppname save_BEGINs
class peekop cast_I32 cstring cchar hash threadsv_names
main_root main_start main_cv svref_2object opnumber amagic_generation
walkoptree walkoptree_slow walkoptree_exec walksymtable
- parents comppadlist sv_undef compile_stats timing_info init_av);
+ parents comppadlist sv_undef compile_stats timing_info
+ begin_av init_av end_av);
sub OPf_KIDS ();
use strict;
@B::SV::ISA = 'B::OBJECT';
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 9e2985582a..f1f0e65781 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -81,7 +81,7 @@ static char *opclassnames[] = {
static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */
-static SV *specialsv_list[4];
+static SV *specialsv_list[6];
static opclass
cc_opclass(pTHX_ OP *o)
@@ -386,11 +386,15 @@ BOOT:
specialsv_list[1] = &PL_sv_undef;
specialsv_list[2] = &PL_sv_yes;
specialsv_list[3] = &PL_sv_no;
+ specialsv_list[4] = pWARN_ALL;
+ specialsv_list[5] = pWARN_NONE;
#include "defsubs.h"
}
#define B_main_cv() PL_main_cv
#define B_init_av() PL_initav
+#define B_begin_av() PL_beginav_save
+#define B_end_av() PL_endav
#define B_main_root() PL_main_root
#define B_main_start() PL_main_start
#define B_amagic_generation() PL_amagic_generation
@@ -402,6 +406,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
@@ -693,8 +708,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_
@@ -1210,7 +1225,7 @@ CvXSUBANY(cv)
MODULE = B PACKAGE = B::CV
-U8
+U16
CvFLAGS(cv)
B::CV cv
diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm
index bc0eda935b..b412927ab4 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);
+@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,117 +27,121 @@ $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{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"];
+$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"];
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 6c51a9ad3e..5e798ce485 100644
--- a/ext/B/B/Assembler.pm
+++ b/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/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm
index 941a818f6b..bea023a038 100644
--- a/ext/B/B/Bytecode.pm
+++ b/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,27 @@ 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";
+ asm "op_last $lastix\n";
}
}
sub B::LISTOP::bytecode {
my $op = shift;
- my $children = $op->children;
+ my $children = $op->children unless $strip_syntree;
$op->B::BINOP::bytecode;
if (($op->type || !$compress_nullops) && !$strip_syntree) {
- print "op_children $children\n";
+ asm "op_children $children\n";
}
}
@@ -273,28 +327,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 +377,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 +398,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 +406,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 +414,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 +431,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 +439,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 +459,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 +486,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 +497,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 +509,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 +595,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 +623,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 +657,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 +683,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 +704,7 @@ sub B::SPECIAL::bytecode {
}
sub bytecompile_object {
- my $sv;
- foreach $sv (@_) {
+ for my $sv (@_) {
svref_2object($sv)->bytecode;
}
}
@@ -637,7 +712,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 +721,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 warnings
- attributes File::Spec 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;
+ }
+ }
}
- 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 (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 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 +788,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 +825,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 +843,6 @@ sub compile {
foreach $ref (values %optimise) {
$$ref = 0;
}
- if ($arg >= 6) {
- $strip_syntree = 1;
- }
if ($arg >= 2) {
$bypass_nullops = 1;
}
@@ -757,28 +850,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 +943,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 +975,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/ext/B/B/Debug.pm b/ext/B/B/Debug.pm
index ae7a9733bc..1327591e7f 100644
--- a/ext/B/B/Debug.pm
+++ b/ext/B/B/Debug.pm
@@ -53,7 +53,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;
}
@@ -244,7 +243,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/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index b6e1097593..5c5c5eb9cb 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -14,6 +14,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber
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.591;
@@ -432,6 +433,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) {
@@ -839,7 +847,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 {
@@ -2487,7 +2495,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);
@@ -2540,7 +2548,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);
diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL
index cb9696bf41..dcf6a1db15 100644
--- a/ext/B/Makefile.PL
+++ b/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/ext/B/O.pm b/ext/B/O.pm
index 352f8d4206..2ef91edbd9 100644
--- a/ext/B/O.pm
+++ b/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/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL
index 80ef936fce..800bb2ca7d 100644
--- a/ext/B/defsubs_h.PL
+++ b/ext/B/defsubs_h.PL
@@ -6,10 +6,16 @@ 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);
}
diff --git a/ext/B/ramblings/flip-flop b/ext/B/ramblings/flip-flop
index e0cb8ff620..e08333d172 100644
--- a/ext/B/ramblings/flip-flop
+++ b/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.
View Lorry Controller Status