Skip to content
Browse files

B-C-1.04_18

git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@21 ed534f1a-1453-0410-ab30-dfc593a8b23c
  • Loading branch information...
1 parent b2c53d9 commit baa8afd58a6027398380a8680818625d11fd23f6 @rurban committed Jul 28, 2008
Showing with 553 additions and 508 deletions.
  1. +1 −1 ByteLoader/ByteLoader.pm
  2. +5 −0 ByteLoader/ByteLoader.xs
  3. +48 −38 ByteLoader/bytecode.h
  4. +61 −88 ByteLoader/byterun.c
  5. +42 −41 ByteLoader/byterun.h
  6. +23 −6 Changes
  7. +13 −10 META.yml
  8. +20 −20 STATUS
  9. +10 −17 bytecode.pl
  10. +30 −34 lib/B/Asmdata.pm
  11. +67 −54 lib/B/Bytecode.pm
  12. +37 −35 lib/B/C.pm
  13. +42 −12 lib/B/CC.pm
  14. +1 −1 lib/B/Disassembler.pm
  15. +38 −38 script/perlcc.PL
  16. +24 −24 t/TESTS
  17. +3 −7 t/assembler.t
  18. +5 −1 t/b.t
  19. +32 −37 t/bytecode.t
  20. +17 −16 t/c.t
  21. +14 −13 t/cc.t
  22. +1 −1 t/o.t
  23. +4 −5 t/stash.t
  24. +7 −3 t/testc.sh
  25. +8 −6 t/testplc.sh
View
2 ByteLoader/ByteLoader.pm
@@ -2,7 +2,7 @@ package ByteLoader;
use XSLoader ();
-our $VERSION = '0.06_03';
+our $VERSION = '0.06_04';
# XSLoader problem:
# ByteLoader version 0.0601 required--this is only version 0.06_01 at ./bytecode2.plc line 2.
# on use ByteLoader $ByteLoader::VERSION;
View
5 ByteLoader/ByteLoader.xs
@@ -144,3 +144,8 @@ import(package="ByteLoader", ...)
if (!sv)
croak ("Could not allocate ByteLoader buffers");
filter_add(byteloader_filter, sv);
+
+void
+unimport(...)
+ PPCODE:
+ filter_del(byteloader_filter);
View
86 ByteLoader/bytecode.h
@@ -7,6 +7,7 @@ typedef SV *svindex;
typedef OP *opindex;
typedef char *pvindex;
typedef HEK *hekindex;
+typedef IV IV64;
#if (PERL_VERSION <= 8) && (PERL_SUBVERSION < 8)
#include "ppport.h"
@@ -43,7 +44,27 @@ typedef HEK *hekindex;
"Different IVSIZE %d for IV", \
bl_header.ivsize); \
} \
- } STMT_END
+ } STMT_END
+/*
+ * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
+ * machines such that 32-bit machine compilers don't whine about the shift
+ * count being too high even though the code is never reached there.
+ */
+#define BGET_IV64(arg) STMT_START { \
+ U32 hi, lo; \
+ BGET_U32(hi); \
+ BGET_U32(lo); \
+ if (sizeof(IV) == 8) \
+ arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \
+ else if (((I32)hi == -1 && (I32)lo < 0) \
+ || ((I32)hi == 0 && (I32)lo >= 0)) { \
+ arg = (I32)lo; \
+ } \
+ else { \
+ bstate->bs_iv_overflows++; \
+ arg = 0; \
+ } \
+ } STMT_END
#define BGET_PADOFFSET(arg) BGET_OR_CROAK(arg, PADOFFSET)
#define BGET_long(arg) STMT_START { \
@@ -71,7 +92,7 @@ typedef HEK *hekindex;
#define BGET_PV(arg) STMT_START { \
BGET_U32(arg); \
if (arg) { \
- New(0, bstate->bs_pv.xpv_pv, (U32)arg, char); \
+ New(666, bstate->bs_pv.xpv_pv, (U32)arg, char); \
bl_read(bstate->bs_fdata, bstate->bs_pv.xpv_pv, (U32)arg, 1); \
bstate->bs_pv.xpv_len = (U32)arg; \
bstate->bs_pv.xpv_cur = (U32)arg - 1; \
@@ -99,11 +120,10 @@ typedef HEK *hekindex;
do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
#endif
-
#define BGET_op_tr_array(arg) do { \
unsigned short *ary, len; \
BGET_U16(len); \
- New(0, ary, len, unsigned short); \
+ New(666, ary, len, unsigned short); \
BGET_FREAD(ary, sizeof(unsigned short), len); \
arg = (char *) ary; \
} while (0)
@@ -226,56 +246,42 @@ typedef HEK *hekindex;
#else /* >= 5.10 */
-// see op.c:newPMOP
-// must use a SV now. build it on the fly from the given pv.
-// TODO: use op_pmflags or re->extflags?
-// op_pmflags is just a small subset of re->extflags
-// need to copy from the current pv to a new sv
+/* see op.c:newPMOP
+ * Must use a SV now. build it on the fly from the given pv.
+ * rx->extflags is constructed from op_pmflags in pregcomp
+ * | PMf_COMPILETIME removed from op_pmflags to fix substr crashes with empty check_substr
+ * TODO: 5.11 could use newSVpvn_flags with SVf_TEMP
+ */
#define BSET_pregcomp(o, arg) \
STMT_START { \
- REGEXP* rx = arg ? \
- CALLREGCOMP(aTHX_ newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags | PMf_COMPILETIME) : \
- Null(REGEXP*); \
assert(SvPOK(PL_regex_pad[0])); \
- if (SvCUR(PL_regex_pad[0])) { \
- /* Pop off the "packed" IV from the end. */ \
- SV *const repointer_list = PL_regex_pad[0]; \
- const char *p = SvEND(repointer_list) - sizeof(IV); \
- const IV offset = *((IV*)p); \
- assert(SvCUR(repointer_list) % sizeof(IV) == 0); \
- \
- SvEND_set(repointer_list, p); \
- \
- cPMOPx(o)->op_pmoffset = offset; \
- /* This slot should be free, so assert this: */ \
- assert(PL_regex_pad[offset] == &PL_sv_undef); \
- } else { \
- SV * const repointer = &PL_sv_undef; \
- av_push(PL_regex_padav, repointer); \
- cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
- PL_regex_pad = AvARRAY(PL_regex_padav); \
- } \
+ PM_SETRE(cPMOPx(o), arg \
+ ? CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags) \
+ : Null(REGEXP*)); \
} STMT_END
#endif
#else /* ! USE_ITHREADS */
#if PERL_VERSION < 10
+/* PM_SETRE only since 5.8 */
#define BSET_pregcomp(o, arg) \
STMT_START { \
- PM_SETRE(((PMOP*)o), (arg ? \
+ (((PMOP*)o)->op_pmregexp = (arg ? \
CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)): \
Null(REGEXP*))); \
} STMT_END
#else
-#define BSET_pregcomp(o, arg) \
- STMT_START { \
- SV* repointer; \
- REGEXP* rx = arg ? \
- CALLREGCOMP(aTHX_ newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags | PMf_COMPILETIME) : \
- Null(REGEXP*); \
- PM_SETRE(((PMOP*)o), rx); \
+/* | PMf_COMPILETIME removed from op_pmflags to fix substr crashes with empty check_substr */
+#define BSET_pregcomp(o, arg) \
+ STMT_START { \
+ SV* repointer; \
+ REGEXP* rx = arg ? \
+ CALLREGCOMP(aTHX_ newSVpvn(arg, strlen(arg)), \
+ cPMOPx(o)->op_pmflags) \
+ : Null(REGEXP*); \
+ PM_SETRE(((PMOP*)o), rx); \
} STMT_END
#endif
@@ -299,7 +305,11 @@ typedef HEK *hekindex;
BSET_OBJ_STOREX(sv); \
} STMT_END
+#if (PERL_VERSION > 6)
#define BSET_newop(o, size) NewOpSz(666, o, size)
+#else
+#define BSET_newop(o, size) (o=(OP*)safemalloc(size), memzero(o, size))
+#endif
/* arg is encoded as type <<7 and size */
#define BSET_newopx(o, arg) STMT_START { \
register int size = arg & 0x7f; \
View
149 ByteLoader/byterun.c
@@ -16,9 +16,17 @@
#include "perl.h"
#define NO_XSLOCKS
#include "XSUB.h"
+#if PERL_VERSION < 8
+ #define NEED_sv_2pv_flags
+ #include "ppport.h"
+#endif
-#ifndef PL_tokenbuf /* Change 31252: move PL_tokenbuf into the PL_parser struct */
-#define PL_tokenbuf (PL_parser->tokenbuf)
+/* Change 31252: move PL_tokenbuf into the PL_parser struct */
+#if (PERL_VERSION > 8) && (!defined(PL_tokenbuf))
+ #define PL_tokenbuf (PL_parser->tokenbuf)
+#endif
+#if (PERL_VERSION < 8) && (!defined(DEBUG_v))
+ #define DEBUG_v(a) DEBUG_l(a)
#endif
#include "byterun.h"
@@ -63,12 +71,12 @@ int bytecode_header_check(pTHX_ struct byteloader_state *bstate, U32 *isjit) {
}
BGET_strconst(str,80); /* archname */
if (strNE(str, ARCHNAME)) {
- HEADER_WARN2("wrong architecture (want %s, you have %s)",str,ARCHNAME);
+ HEADER_WARN2("wrong architecture (want %s, you have %s)", str, ARCHNAME);
}
strcpy(bl_header.archname, str);
BGET_strconst(str,16); /* fail if lower ByteLoader version */
- if (strLT(str, VERSION)) {
+ if (strNE(str, VERSION)) { /* when we support lower => strLT */
HEADER_FAIL2("mismatched ByteLoader versions (want %s, you have %s)",
str, VERSION);
}
@@ -103,15 +111,16 @@ int bytecode_header_check(pTHX_ struct byteloader_state *bstate, U32 *isjit) {
bl_header.longsize = 8;
}
- BGET_strconst(str,16); /* 12345678 */
- if (strNE(str, "12345678")) {
+ {
+ char supported[8]; /* config.h BYTEORDER: 0x1234 */
+ sprintf(supported, "%x", BYTEORDER);
+ BGET_strconst(str, 16); /* 12345678 or 1234 */
+ if (strNE(str, supported)) {
HEADER_WARN2("cannot yet convert different byteorders (want %s, you have %s)",
- "12345678", str);
- if (strNE(str, "56781234")) {
- HEADER_WARN1("invalid byteorder %s)", str);
- }
+ supported, str);
+ }
+ strcpy(bl_header.byteorder, str);
}
- strcpy(bl_header.byteorder, str);
return 1;
}
@@ -123,14 +132,15 @@ byterun(pTHX_ struct byteloader_state *bstate)
U32 ix;
SV *specialsv_list[7];
- bytecode_header_check(aTHX_ bstate, &isjit); /* croak if incorrect platform, set isjit on PLJC magic header */
+ bytecode_header_check(aTHX_ bstate, &isjit); /* croak if incorrect platform,
+ set isjit on PLJC magic header */
if (isjit) {
Perl_croak(aTHX_ "PLJC-magic: No JIT support yet\n");
return 0; /*jitrun(aTHX_ &bstate);*/
} else {
- Newx(bstate->bs_obj_list, 32, void*); /* set op objlist */
+ New(0, bstate->bs_obj_list, 32, void*); /* set op objlist */
bstate->bs_obj_list_fill = 31;
- bstate->bs_obj_list[0] = NULL; /* first is always Null */
+ bstate->bs_obj_list[0] = NULL; /* first is always Null */
bstate->bs_ix = 1;
CopLINE(PL_curcop) = bstate->bs_fdata->next_out;
DEBUG_l( Perl_deb(aTHX_ "(bstate.bs_fdata.idx %d)\n", bstate->bs_fdata->idx));
@@ -148,7 +158,9 @@ byterun(pTHX_ struct byteloader_state *bstate)
while ((insn = BGET_FGETC()) != EOF) {
CopLINE(PL_curcop) = bstate->bs_fdata->next_out;
+#ifdef DEBUG_t_TEST_
if (PL_op && DEBUG_t_TEST_) debop(PL_op);
+#endif
switch (insn) {
case INSN_COMMENT: /* 35 */
{
@@ -782,7 +794,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
{
pvcontents arg;
BGET_pvcontents(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) mg_name pvcontents:%d\n", insn, arg));
+ DEBUG_v(Perl_deb(aTHX_ "(insn %3d) mg_name pvcontents:\"%s\"\n", insn, arg));
BSET_mg_name(SvMAGIC(bstate->bs_sv), arg);
DEBUG_v(Perl_deb(aTHX_ " BSET_mg_name(SvMAGIC(bstate->bs_sv), arg)\n"));
break;
@@ -1145,7 +1157,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
{
pvcontents arg;
BGET_pvcontents(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) pregcomp pvcontents:%d\n", insn, arg));
+ DEBUG_v(Perl_deb(aTHX_ "(insn %3d) pregcomp pvcontents:\"%s\"\n", insn, arg));
BSET_pregcomp(PL_op, arg);
DEBUG_v(Perl_deb(aTHX_ " BSET_pregcomp(PL_op, arg)\n"));
break;
@@ -1159,19 +1171,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cPMOP->op_pmflags = arg;\n"));
break;
}
-#if PERL_VERSION < 11
- case INSN_OP_REFLAGS: /* 113 */
- {
- U32 arg;
- BGET_U32(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) op_reflags U32:%d\n", insn, arg));
- PM_GETRE(cPMOP)->extflags = arg;
- DEBUG_v(Perl_deb(aTHX_ " PM_GETRE(cPMOP)->extflags = arg;\n"));
- break;
- }
-#else
-#endif
- case INSN_OP_SV: /* 114 */
+ case INSN_OP_SV: /* 113 */
{
svindex arg;
BGET_svindex(arg);
@@ -1180,7 +1180,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cSVOP->op_sv = arg;\n"));
break;
}
- case INSN_OP_PADIX: /* 115 */
+ case INSN_OP_PADIX: /* 114 */
{
PADOFFSET arg;
BGET_PADOFFSET(arg);
@@ -1189,16 +1189,16 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cPADOP->op_padix = arg;\n"));
break;
}
- case INSN_OP_PV: /* 116 */
+ case INSN_OP_PV: /* 115 */
{
pvcontents arg;
BGET_pvcontents(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) op_pv pvcontents:%d\n", insn, arg));
+ DEBUG_v(Perl_deb(aTHX_ "(insn %3d) op_pv pvcontents:\"%s\"\n", insn, arg));
cPVOP->op_pv = arg;
DEBUG_v(Perl_deb(aTHX_ " cPVOP->op_pv = arg;\n"));
break;
}
- case INSN_OP_PV_TR: /* 117 */
+ case INSN_OP_PV_TR: /* 116 */
{
op_tr_array arg;
BGET_op_tr_array(arg);
@@ -1207,7 +1207,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cPVOP->op_pv = arg;\n"));
break;
}
- case INSN_OP_REDOOP: /* 118 */
+ case INSN_OP_REDOOP: /* 117 */
{
opindex arg;
BGET_opindex(arg);
@@ -1216,7 +1216,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cLOOP->op_redoop = arg;\n"));
break;
}
- case INSN_OP_NEXTOP: /* 119 */
+ case INSN_OP_NEXTOP: /* 118 */
{
opindex arg;
BGET_opindex(arg);
@@ -1225,7 +1225,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cLOOP->op_nextop = arg;\n"));
break;
}
- case INSN_OP_LASTOP: /* 120 */
+ case INSN_OP_LASTOP: /* 119 */
{
opindex arg;
BGET_opindex(arg);
@@ -1234,35 +1234,17 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cLOOP->op_lastop = arg;\n"));
break;
}
- case INSN_COP_LABEL: /* 121 */
+ case INSN_COP_LABEL: /* 120 */
{
pvindex arg;
BGET_pvindex(arg);
DEBUG_v(Perl_deb(aTHX_ "(insn %3d) cop_label pvindex:\"%s\"\n", insn, arg, ix));
- cCOP->cop_label = arg;
- DEBUG_v(Perl_deb(aTHX_ " cCOP->cop_label = arg;\n"));
- break;
- }
- case INSN_COP_STASHPV: /* 122 */
- {
- pvindex arg;
- BGET_pvindex(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) cop_stashpv pvindex:\"%s\"\n", insn, arg, ix));
- BSET_cop_stashpv(cCOP, arg);
- DEBUG_v(Perl_deb(aTHX_ " BSET_cop_stashpv(cCOP, arg)\n"));
- break;
- }
- case INSN_COP_FILE: /* 123 */
- {
- pvindex arg;
- BGET_pvindex(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) cop_file pvindex:\"%s\"\n", insn, arg, ix));
- BSET_cop_file(cCOP, arg);
- DEBUG_v(Perl_deb(aTHX_ " BSET_cop_file(cCOP, arg)\n"));
+ BSET_cop_label(cCOP, arg);
+ DEBUG_v(Perl_deb(aTHX_ " BSET_cop_label(cCOP, arg)\n"));
break;
}
#ifndef USE_ITHREADS
- case INSN_COP_STASH: /* 124 */
+ case INSN_COP_STASH: /* 121 */
{
svindex arg;
BGET_svindex(arg);
@@ -1271,7 +1253,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_cop_stash(cCOP, arg)\n"));
break;
}
- case INSN_COP_FILEGV: /* 125 */
+ case INSN_COP_FILEGV: /* 122 */
{
svindex arg;
BGET_svindex(arg);
@@ -1281,7 +1263,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
break;
}
#endif
- case INSN_COP_SEQ: /* 126 */
+ case INSN_COP_SEQ: /* 123 */
{
U32 arg;
BGET_U32(arg);
@@ -1290,7 +1272,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cCOP->cop_seq = arg;\n"));
break;
}
- case INSN_COP_LINE: /* 127 */
+ case INSN_COP_LINE: /* 124 */
{
line_t arg;
BGET_U32(arg);
@@ -1299,7 +1281,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " cCOP->cop_line = arg;\n"));
break;
}
- case INSN_COP_WARNINGS: /* 128 */
+ case INSN_COP_WARNINGS: /* 125 */
{
svindex arg;
BGET_svindex(arg);
@@ -1308,7 +1290,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_cop_warnings(cCOP, arg)\n"));
break;
}
- case INSN_MAIN_START: /* 129 */
+ case INSN_MAIN_START: /* 126 */
{
opindex arg;
BGET_opindex(arg);
@@ -1317,7 +1299,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " PL_main_start = arg;\n"));
break;
}
- case INSN_MAIN_ROOT: /* 130 */
+ case INSN_MAIN_ROOT: /* 127 */
{
opindex arg;
BGET_opindex(arg);
@@ -1326,7 +1308,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " PL_main_root = arg;\n"));
break;
}
- case INSN_MAIN_CV: /* 131 */
+ case INSN_MAIN_CV: /* 128 */
{
svindex arg;
BGET_svindex(arg);
@@ -1335,7 +1317,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&PL_main_cv = arg;\n"));
break;
}
- case INSN_CURPAD: /* 132 */
+ case INSN_CURPAD: /* 129 */
{
svindex arg;
BGET_svindex(arg);
@@ -1344,7 +1326,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_curpad(PL_curpad, arg)\n"));
break;
}
- case INSN_PUSH_BEGIN: /* 133 */
+ case INSN_PUSH_BEGIN: /* 130 */
{
svindex arg;
BGET_svindex(arg);
@@ -1353,7 +1335,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_push_begin(PL_beginav, arg)\n"));
break;
}
- case INSN_PUSH_INIT: /* 134 */
+ case INSN_PUSH_INIT: /* 131 */
{
svindex arg;
BGET_svindex(arg);
@@ -1362,7 +1344,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_push_init(PL_initav, arg)\n"));
break;
}
- case INSN_PUSH_END: /* 135 */
+ case INSN_PUSH_END: /* 132 */
{
svindex arg;
BGET_svindex(arg);
@@ -1371,7 +1353,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_push_end(PL_endav, arg)\n"));
break;
}
- case INSN_CURSTASH: /* 136 */
+ case INSN_CURSTASH: /* 133 */
{
svindex arg;
BGET_svindex(arg);
@@ -1380,7 +1362,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&PL_curstash = arg;\n"));
break;
}
- case INSN_DEFSTASH: /* 137 */
+ case INSN_DEFSTASH: /* 134 */
{
svindex arg;
BGET_svindex(arg);
@@ -1389,7 +1371,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&PL_defstash = arg;\n"));
break;
}
- case INSN_DATA: /* 138 */
+ case INSN_DATA: /* 135 */
{
U8 arg;
BGET_U8(arg);
@@ -1398,7 +1380,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_data(none, arg)\n"));
break;
}
- case INSN_INCAV: /* 139 */
+ case INSN_INCAV: /* 136 */
{
svindex arg;
BGET_svindex(arg);
@@ -1407,7 +1389,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&GvAV(PL_incgv) = arg;\n"));
break;
}
- case INSN_LOAD_GLOB: /* 140 */
+ case INSN_LOAD_GLOB: /* 137 */
{
svindex arg;
BGET_svindex(arg);
@@ -1417,17 +1399,8 @@ byterun(pTHX_ struct byteloader_state *bstate)
break;
}
#ifdef USE_ITHREADS
- case INSN_REGEX_PADAV: /* 141 */
- {
- svindex arg;
- BGET_svindex(arg);
- DEBUG_v(Perl_deb(aTHX_ "(insn %3d) regex_padav svindex:0x%x, ix:%d\n", insn, arg, ix));
- *(SV**)&PL_regex_padav = arg;
- DEBUG_v(Perl_deb(aTHX_ " *(SV**)&PL_regex_padav = arg;\n"));
- break;
- }
#endif
- case INSN_DOWARN: /* 142 */
+ case INSN_DOWARN: /* 138 */
{
U8 arg;
BGET_U8(arg);
@@ -1436,7 +1409,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " PL_dowarn = arg;\n"));
break;
}
- case INSN_COMPPAD_NAME: /* 143 */
+ case INSN_COMPPAD_NAME: /* 139 */
{
svindex arg;
BGET_svindex(arg);
@@ -1445,7 +1418,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&PL_comppad_name = arg;\n"));
break;
}
- case INSN_XGV_STASH: /* 144 */
+ case INSN_XGV_STASH: /* 140 */
{
svindex arg;
BGET_svindex(arg);
@@ -1454,7 +1427,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " *(SV**)&GvSTASH(bstate->bs_sv) = arg;\n"));
break;
}
- case INSN_SIGNAL: /* 145 */
+ case INSN_SIGNAL: /* 141 */
{
strconst arg;
BGET_strconst(arg, 0);
@@ -1463,7 +1436,7 @@ byterun(pTHX_ struct byteloader_state *bstate)
DEBUG_v(Perl_deb(aTHX_ " BSET_signal(bstate->bs_sv, arg)\n"));
break;
}
- case INSN_FORMFEED: /* 146 */
+ case INSN_FORMFEED: /* 142 */
{
svindex arg;
BGET_svindex(arg);
View
83 ByteLoader/byterun.h
@@ -11,23 +11,28 @@
* This file is autogenerated from bytecode.pl. Changes made here will be lost.
*/
#if PERL_VERSION < 10
-#define PL_RSFP PL_rsfp
+ #define PL_RSFP PL_rsfp
#else
-#define PL_RSFP PL_parser->rsfp
+ #define PL_RSFP PL_parser->rsfp
+#endif
+
+#if (PERL_VERSION <= 8) && (PERL_SUBVERSION < 8)
+ #define NEED_sv_2pv_flags
+ #include "ppport.h"
#endif
struct byteloader_fdata {
SV *datasv;
- int next_out;
- int idx;
+ int next_out;
+ int idx;
};
#if PERL_VERSION > 8
struct byteloader_xpv {
char *xpv_pv;
- int xpv_cur;
- int xpv_len;
+ int xpv_cur;
+ int xpv_len;
};
#endif
@@ -173,41 +178,37 @@ enum {
INSN_OP_PMREPLROOTGV, /* 110 */
INSN_PREGCOMP, /* 111 */
INSN_OP_PMFLAGS, /* 112 */
- INSN_OP_REFLAGS, /* 113 */
- INSN_OP_SV, /* 114 */
- INSN_OP_PADIX, /* 115 */
- INSN_OP_PV, /* 116 */
- INSN_OP_PV_TR, /* 117 */
- INSN_OP_REDOOP, /* 118 */
- INSN_OP_NEXTOP, /* 119 */
- INSN_OP_LASTOP, /* 120 */
- INSN_COP_LABEL, /* 121 */
- INSN_COP_STASHPV, /* 122 */
- INSN_COP_FILE, /* 123 */
- INSN_COP_STASH, /* 124 */
- INSN_COP_FILEGV, /* 125 */
- INSN_COP_SEQ, /* 126 */
- INSN_COP_LINE, /* 127 */
- INSN_COP_WARNINGS, /* 128 */
- INSN_MAIN_START, /* 129 */
- INSN_MAIN_ROOT, /* 130 */
- INSN_MAIN_CV, /* 131 */
- INSN_CURPAD, /* 132 */
- INSN_PUSH_BEGIN, /* 133 */
- INSN_PUSH_INIT, /* 134 */
- INSN_PUSH_END, /* 135 */
- INSN_CURSTASH, /* 136 */
- INSN_DEFSTASH, /* 137 */
- INSN_DATA, /* 138 */
- INSN_INCAV, /* 139 */
- INSN_LOAD_GLOB, /* 140 */
- INSN_REGEX_PADAV, /* 141 */
- INSN_DOWARN, /* 142 */
- INSN_COMPPAD_NAME, /* 143 */
- INSN_XGV_STASH, /* 144 */
- INSN_SIGNAL, /* 145 */
- INSN_FORMFEED, /* 146 */
- MAX_INSN = 146
+ INSN_OP_SV, /* 113 */
+ INSN_OP_PADIX, /* 114 */
+ INSN_OP_PV, /* 115 */
+ INSN_OP_PV_TR, /* 116 */
+ INSN_OP_REDOOP, /* 117 */
+ INSN_OP_NEXTOP, /* 118 */
+ INSN_OP_LASTOP, /* 119 */
+ INSN_COP_LABEL, /* 120 */
+ INSN_COP_STASH, /* 121 */
+ INSN_COP_FILEGV, /* 122 */
+ INSN_COP_SEQ, /* 123 */
+ INSN_COP_LINE, /* 124 */
+ INSN_COP_WARNINGS, /* 125 */
+ INSN_MAIN_START, /* 126 */
+ INSN_MAIN_ROOT, /* 127 */
+ INSN_MAIN_CV, /* 128 */
+ INSN_CURPAD, /* 129 */
+ INSN_PUSH_BEGIN, /* 130 */
+ INSN_PUSH_INIT, /* 131 */
+ INSN_PUSH_END, /* 132 */
+ INSN_CURSTASH, /* 133 */
+ INSN_DEFSTASH, /* 134 */
+ INSN_DATA, /* 135 */
+ INSN_INCAV, /* 136 */
+ INSN_LOAD_GLOB, /* 137 */
+ INSN_DOWARN, /* 138 */
+ INSN_COMPPAD_NAME, /* 139 */
+ INSN_XGV_STASH, /* 140 */
+ INSN_SIGNAL, /* 141 */
+ INSN_FORMFEED, /* 142 */
+ MAX_INSN = 142
};
enum {
View
29 Changes
@@ -2,14 +2,28 @@
Started on CPAN with B-C-1.04_12. The perl compiler was in CORE from alpha4
until Perl 5.9.4.
+1.04_18 2008-06-05 rurban
+ * Fixed t/assembler.t on 5.6.2
+ * Added ByteLoader::unimport (from 5.6.2)
+ * ByteLoader: Fixed bytecode crashes for 5.10+5.11 in 2-5, 7 by
+ removing PMf_COMPILETIME from op_pmflags. Reason: empty
+ check_substr in INTUIT. (6 still failing)
+ * ByteLoader: Fixes for 5.11 by using PM_SETRE (test 7 still failing)
+ * Bytecode: removed op_reflags. pregcomp with op_pmflags alone
+ is enough to reconstruct it.
+ * C,CC: enabled static_ext + DynaLoader boot section again. Fixed in cygperl.
+ * CC: fixed Bug#55302 PP_EVAL by adding PP_EVAL_thr for threaded perl.
+ cc_runtime.h was always wrong on this!
+
1.04_17 2008-04-20 rurban
- Added Fedora Core 1 as test system (5.6.2,5.8.3,5.11.0@33704, valgrind)
+ Added Fedora Core 1 as test system (5.6.2, 5.8.3, 5.11.0@33708 + valgrind)
* ByteLoader: Fixed broken BYTEORDER check (for 32int)
* ByteLoader: Remove allowing older versions until we have
an opcode table for older versions.
* ByteLoader: Fixed SIGSEGV with older gcc (3.3.2) at
bstate->bs_obj_list[0] = NULL
- * ByteLoader, C.xs: Newx() support and more for older perl's. Tested with 5.8.3
+ * ByteLoader, C.xs: Newx() support and more for older perl's.
+ Tested with 5.8.3
* bytecode.pl: Fixed <11 op_reflags (double definition)
* bytecode.pl: Support 8-10 version syntax (op_pmstash, cop_io)
* Makefile.PL: added MKPATH blib/bin
@@ -32,7 +46,8 @@ until Perl 5.9.4.
commented disassembler output. PVGV and new REGEX still broken.
Fixes for no ithreads.
- * Fixed verbose Bytecode for old B::Concise (5.8.8). t/testplc.sh failed before.
+ * Fixed verbose Bytecode for old B::Concise (5.8.8). t/testplc.sh
+ failed before.
* ByteLoader: Work on portability (different arch, version and sizes).
Added bl_header.
Changed macro BYTECODE_HEADER_CHECK to function bytecode_header_check().
@@ -42,8 +57,8 @@ until Perl 5.9.4.
use xpv_cur and not xpv_len for the rx length (len - 1) to strip off
the ending nul byte.
5.10: new minlen check aborts
- * ByteLoader security: added strconst maxsize flag to bytecode.pl for buffer
- overflow checks.
+ * ByteLoader security: added strconst maxsize flag to bytecode.pl
+ for buffer overflow checks.
* Bytecode -DA for devel assertions of absolute or probably wrong opindex
pointers (nyi)
* disassemble, B::Assembler: commented output, similar to -MO=Bytecode,-S
@@ -57,7 +72,8 @@ until Perl 5.9.4.
Added longsize to the bytecode header, just for xcv_depth.
* B::Debug 1.05_03: Fixes for no threads.
* Makefile.PL: Fixed script/perlcc.PL dependency
- make: *** No rule to make target `script/perlcc', needed by `blib/bin/perlcc'.
+ make: *** No rule to make target `script/perlcc', needed by
+ `blib/bin/perlcc'.
(Thanks to david@cantrell.org.uk for his cpantest for solaris)
* Added test TODO's, Added perloptreeguts.pod
@@ -193,6 +209,7 @@ until Perl 5.9.4.
===================================================================
B::C was 1.03 when exterminated.
+Oops, Module::Corelist says 1.05 for 5.9.4, Right so.
Nicholas Clark <nwc10+p5p4@colon.colondot.net> 2007-05-07 15:35:56
bytecode.pl: Exterminate!
View
23 META.yml
@@ -1,12 +1,15 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
-name: B-C
-version: 1.04_17
-version_from: lib/B/C.pm
-installdirs: site
-requires:
+--- #YAML:1.0
+name: B-C
+version: 1.04_18
+abstract: perl compiler
+license: ~
+author:
+ - Malcolm Beattie <mbeattie@sable.ox.ac.uk>
+generated_by: ExtUtils::MakeMaker version 6.42
+distribution_type: module
+requires:
B: 1.0901
B::Concise: 0.66
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
View
40 STATUS
@@ -9,17 +9,16 @@ REGEX pregcomp broken (in bc and c, see ccode2)
B:C Problems:
pregcomp()
SIGSEGV in Perl_fbm_instr() <= Perl_re_intuit_start() <= Perl_pp_subst()
- invalid pad in pad_sv, pad_new, save_clearsv - cause: setting PL_curpad at save_context, PL_comppad?
+ invalid pad in pad_sv, pad_new, save_clearsv - cause: setting PL_curpad at save_context
Modification of a read-only value attempted - save_context ?
5.6.2 i386-linux-thread-multi:
-t/assembler.t 255 65280 ?? ?? % ?? (PM_SETRE)
-t/b.t 0 11 57 106 185.96% 5-57
-t/bytecode.t 19 19 100.00% 1-19
-t/c.t 19 13 68.42% 1-7 11-13 17-19
-t/cc.t 19 10 52.63% 1-7 11 13 17
-t/o.t 9 1 11.11% 9
-t/stash.t 255 65280 ?? ?? % ??
+t/b.t 0 11 57 106 185.96% 5-57
+t/bytecode.t 19 19 100.00% 1-19
+t/c.t 19 13 68.42% 1-7 11-13 17-19
+t/cc.t 19 10 52.63% 1-7 11 13 17
+t/o.t 9 1 11.11% 9
+t/stash.t 255 65280 ?? ?? % ??
Can't declare another package's variables at t/stash.t line 91
5.8.3 i386-linux-thread-multi:
@@ -35,15 +34,15 @@ bytecode15S_.asm: There were 2 assembly errors
/usr/bin/perl -Mblib -MO=Debug bytecode7.pl -o bytecode7_.dbg
t/testplc.sh: line 66: 5975 Segmentation fault
-
5.8.8:
t/c.t (Wstat: 0 Tests: 19 Failed: 6)
FAILED tests 8-10, 14-16
Undefined subroutine &main::a called at ccode8.pl line 1.
Modification of a read-only value attempted at ccode10.pl line 2.
t/cc.t (Wstat: 0 Tests: 19 Failed: 13)
Failed tests: 8-10 12 14-16 18-19
- In function `pp_main': cccode12.c:276: error: too few arguments to function
+ In function `pp_main': cccode12.c:276: error: too few arguments to function
+ (Bug#55302, fixed with B-C-1.04_18)
5.8.8d:
TODO failed: 20 (bc op coverage)
@@ -58,8 +57,10 @@ t/bytecode (Wstat: 0 Tests: 19 Failed: 6)
FAILED tests 2-5, 7, 11, 15
t/c.t (Wstat: 0 Tests: 19 Failed: 6)
Failed tests: 8-10 14-16
+ 2008-04-27 17:44:52 URBANR: 2-7 11
t/cc.t (Wstat: 0 Tests: 19 Failed: 9)
Failed tests: 1-7 11 13 17 (was: 2-7 11, was: 8-10, 12, 14-16, 18-19)
+ 8-10 12 14-16 18-19
5.10.0d:
t/bytecode (Wstat: 0 Tests: 19 Failed: 6)
@@ -69,9 +70,9 @@ t/bytecode (Wstat: 0 Tests: 19 Failed: 6)
Assertion ((((shplep)->sv_flags & (0x00004000|0x00008000)) == 0x00008000) && (((svtype)((shplep)->sv_flags & 0xff)) == SVt_PVGV || ((svtype)((shplep)->sv_flags & 0xff)) == SVt_PVLV)) failed
t/c.t (Wstat: 0 Tests: 19 Failed: 6)
Assertion ((svtype)((_svi)->sv_flags & 0xff)) != SVt_PVCV failed
- Failed tests: 2-4 6 8-10 14-16 (was: 2-7 11 18)
+ Failed tests: 2-7, 11-12, 17-19 (was: 2-4 6 8-10 14-16; 2-7 11 18)
t/cc.t (Wstat: 0 Tests: 19 Failed: 9)
- Failed tests: 1-4 6 11-13 17-19 (was: 2-7 11, was: 8-10, 12, 14-16, 18-19)
+ Failed tests: 2-4, 6, 11-12, 17-19 (was: 8-10, 12, 14-16, 18-19)
5.10.0-nt (not threaded):
t/bytecode (Wstat: 0 Tests: 19 Failed: 9)
@@ -85,10 +86,10 @@ t/cc.t (Wstat: 0 Tests: 19 Failed: 8)
5.11 @33673 -D
-t/bytecode.t (Wstat: 0 Tests: 20 Failed: 11)
- Failed tests: 2-5, 7, 9-12, 15-16 (all segfaulting in REGEX)
-t/c.t (Wstat: 0 Tests: 19 Failed: 10)
- Failed tests: 2-4, 6, 8-10, 14-16
+t/bytecode.t (Wstat: 0 Tests: 20 Failed: 7)
+ Failed tests: 4, 9-12, 15-16 (all segfaulting in REGEX)
+t/c.t (Wstat: 0 Tests: 19 Failed: 6)
+ Failed tests: 8-10, 14-16
t/cc.t (Wstat: 0 Tests: 19 Failed: 11)
Failed tests: 1-4, 6, 11-13, 17-19
@@ -99,14 +100,12 @@ t/c.t (Wstat: 0 Tests: 19 Failed: 6)
Failed tests: 8-10, 14-16
t/cc.t (Wstat: 0 Tests: 19 Failed: 11)
Failed tests: 1-4, 6, 11-13, 17-19
-t/stash.t (Wstat: 0 Tests: 1 Failed: 1)
- Failed tests: 1
5.10, 5.11 status
-----------------
With DEBUGGING
- static op_free in Perl_destruct fixed
panic: illegal pad in pad_new: 0x18c4368[0x18cf6e8]
+ CvPADLIST: curpad<=>comppad
pvx: seems to be fixed now in bc, and c
With the move of the pvx field from xpv to the sv, we have to solve
that differently for the Bytecode and C backend.
@@ -116,6 +115,7 @@ hv: crash at invalid entry in hv_store in B::HV::save fixed
hek: new implementation
regexp: new and still broken for 5.11, regex_pad wrong and ignored on 5.11
bc: B::IO::SUBPROCESS missing
+bc 10: padv+sassign => Modification of a read-only value attempted at bytecode10.pl line 1.
5.8 status
----------
@@ -201,4 +201,4 @@ added Jit and Asm layout, with the idea of using either
lightning as jit backend (Jit), or creating our own assembler (Asm)
to be able to use a high-level language.
-2008-04-13 11:31:45 URBANR
+2008-04-20 21:08:36 URBANR
View
27 bytecode.pl
@@ -677,30 +677,23 @@ =head1 AUTHOR
0 op_first cUNOP->op_first opindex
0 op_last cBINOP->op_last opindex
0 op_other cLOGOP->op_other opindex
-<10 op_pmreplroot cPMOP->op_pmreplroot opindex
-<10 op_pmreplstart cPMOP->op_pmreplstart opindex
-<10 op_pmnext *(OP**)&cPMOP->op_pmnext opindex
-10 op_pmreplroot (cPMOP->op_pmreplrootu).op_pmreplroot opindex
-10 op_pmreplstart (cPMOP->op_pmstashstartu).op_pmreplstart opindex
+<10 op_pmreplroot cPMOP->op_pmreplroot opindex
+<10 op_pmreplstart cPMOP->op_pmreplstart opindex
+<10 op_pmnext *(OP**)&cPMOP->op_pmnext opindex
+10 op_pmreplroot (cPMOP->op_pmreplrootu).op_pmreplroot opindex
+10 op_pmreplstart (cPMOP->op_pmstashstartu).op_pmreplstart opindex
#ifdef USE_ITHREADS
8 op_pmstashpv cPMOP pvindex x
<10 op_pmreplrootpo cPMOP->op_pmreplroot OP*/PADOFFSET
10 op_pmreplrootpo (cPMOP->op_pmreplrootu).op_pmreplroot OP*/PADOFFSET
#else
8-10 op_pmstash *(SV**)&cPMOP->op_pmstash svindex
-10 op_pmstash *(SV**)&(cPMOP->op_pmstashstartu).op_pmreplstart svindex
-<10 op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex
-10 op_pmreplrootgv *(SV**)&(cPMOP->op_pmreplrootu).op_pmreplroot svindex
-#endif
-#<10 pregcomp PL_op pvcontents x
-0 pregcomp PL_op pvcontents x
-#10 pregcomp PL_op none x
-0 op_pmflags cPMOP->op_pmflags U16
-#if (PERL_VERSION >= 10)&&(PERL_VERSION < 11)
-<11 op_reflags PM_GETRE(cPMOP)->extflags U32
-#else
-11 op_reflags ((ORANGE*)SvANY(PM_GETRE(cPMOP)))->extflags U32
+10 op_pmstash *(SV**)&(cPMOP->op_pmstashstartu).op_pmreplstart svindex
+<10 op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex
+10 op_pmreplrootgv *(SV**)&(cPMOP->op_pmreplrootu).op_pmreplroot svindex
#endif
+0 pregcomp PL_op pvcontents x
+0 op_pmflags cPMOP->op_pmflags U16
<10 op_pmpermflags cPMOP->op_pmpermflags U16
<10 op_pmdynflags cPMOP->op_pmdynflags U8
0 op_sv cSVOP->op_sv svindex
View
64 lib/B/Asmdata.pm
@@ -137,40 +137,36 @@ $insn_data{op_pmstash} = [109, \&PUT_svindex, "GET_svindex"];
$insn_data{op_pmreplrootgv} = [110, \&PUT_svindex, "GET_svindex"];
$insn_data{pregcomp} = [111, \&PUT_pvcontents, "GET_pvcontents"];
$insn_data{op_pmflags} = [112, \&PUT_U16, "GET_U16"];
-$insn_data{op_reflags} = [113, \&PUT_U32, "GET_U32"];
-$insn_data{op_sv} = [114, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_padix} = [115, \&PUT_PADOFFSET, "GET_PADOFFSET"];
-$insn_data{op_pv} = [116, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pv_tr} = [117, \&PUT_op_tr_array, "GET_op_tr_array"];
-$insn_data{op_redoop} = [118, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_nextop} = [119, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_lastop} = [120, \&PUT_opindex, "GET_opindex"];
-$insn_data{cop_label} = [121, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_stashpv} = [122, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_file} = [123, \&PUT_pvindex, "GET_pvindex"];
-$insn_data{cop_stash} = [124, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_filegv} = [125, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_seq} = [126, \&PUT_U32, "GET_U32"];
-$insn_data{cop_line} = [127, \&PUT_U32, "GET_U32"];
-$insn_data{cop_warnings} = [128, \&PUT_svindex, "GET_svindex"];
-$insn_data{main_start} = [129, \&PUT_opindex, "GET_opindex"];
-$insn_data{main_root} = [130, \&PUT_opindex, "GET_opindex"];
-$insn_data{main_cv} = [131, \&PUT_svindex, "GET_svindex"];
-$insn_data{curpad} = [132, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_begin} = [133, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_init} = [134, \&PUT_svindex, "GET_svindex"];
-$insn_data{push_end} = [135, \&PUT_svindex, "GET_svindex"];
-$insn_data{curstash} = [136, \&PUT_svindex, "GET_svindex"];
-$insn_data{defstash} = [137, \&PUT_svindex, "GET_svindex"];
-$insn_data{data} = [138, \&PUT_U8, "GET_U8"];
-$insn_data{incav} = [139, \&PUT_svindex, "GET_svindex"];
-$insn_data{load_glob} = [140, \&PUT_svindex, "GET_svindex"];
-$insn_data{regex_padav} = [141, \&PUT_svindex, "GET_svindex"];
-$insn_data{dowarn} = [142, \&PUT_U8, "GET_U8"];
-$insn_data{comppad_name} = [143, \&PUT_svindex, "GET_svindex"];
-$insn_data{xgv_stash} = [144, \&PUT_svindex, "GET_svindex"];
-$insn_data{signal} = [145, \&PUT_strconst, "GET_strconst"];
-$insn_data{formfeed} = [146, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_sv} = [113, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_padix} = [114, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_pv} = [115, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [116, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [117, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_nextop} = [118, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_lastop} = [119, \&PUT_opindex, "GET_opindex"];
+$insn_data{cop_label} = [120, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_stash} = [121, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_filegv} = [122, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_seq} = [123, \&PUT_U32, "GET_U32"];
+$insn_data{cop_line} = [124, \&PUT_U32, "GET_U32"];
+$insn_data{cop_warnings} = [125, \&PUT_svindex, "GET_svindex"];
+$insn_data{main_start} = [126, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_root} = [127, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_cv} = [128, \&PUT_svindex, "GET_svindex"];
+$insn_data{curpad} = [129, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_begin} = [130, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_init} = [131, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_end} = [132, \&PUT_svindex, "GET_svindex"];
+$insn_data{curstash} = [133, \&PUT_svindex, "GET_svindex"];
+$insn_data{defstash} = [134, \&PUT_svindex, "GET_svindex"];
+$insn_data{data} = [135, \&PUT_U8, "GET_U8"];
+$insn_data{incav} = [136, \&PUT_svindex, "GET_svindex"];
+$insn_data{load_glob} = [137, \&PUT_svindex, "GET_svindex"];
+$insn_data{dowarn} = [138, \&PUT_U8, "GET_U8"];
+$insn_data{comppad_name} = [139, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_stash} = [140, \&PUT_svindex, "GET_svindex"];
+$insn_data{signal} = [141, \&PUT_strconst, "GET_strconst"];
+$insn_data{formfeed} = [142, \&PUT_svindex, "GET_svindex"];
my ($insn_name, $insn_data);
while (($insn_name, $insn_data) = each %insn_data) {
View
121 lib/B/Bytecode.pm
@@ -1,6 +1,7 @@
# B::Bytecode.pm
+# Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved.
# Copyright (c) 2003 Enache Adrian. All rights reserved.
-# Copyright (c) 2008 Reini Urban <rurban@cpan.org>.
+# Copyright (c) 2008 Reini Urban <rurban@cpan.org>. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
@@ -12,28 +13,33 @@ our $VERSION = '1.02_03';
use strict;
use Config;
+#require 5.008;
+#use B qw(class main_cv main_root main_start cstring comppadlist
+# defstash curstash begin_av init_av end_av inc_gv warnhook diehook
+# dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
+# OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
+# for 5.6.2: B exports no defstash curstash inc_gv warnhook diehook dowarn SVt_PVGV SVt_PVHV SVf_FAKE
use B qw(class main_cv main_root main_start cstring comppadlist
- defstash curstash begin_av init_av end_av inc_gv warnhook diehook
- dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
- OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
-our (@optype, @specialsv_name, $quiet);
-require B;
-if ($] < 5.009) {
- # <=5.008 had @specialsv_name exported from B::Asmdata
- require B::Asmdata;
- @optype = @{*B::Asmdata::optype{ARRAY}};
- @specialsv_name = @{*B::Asmdata::specialsv_name{ARRAY}};
- # import B::Asmdata qw(@optype @specialsv_name);
-} else {
- @optype = @{*B::optype{ARRAY}};
- @specialsv_name = @{*B::specialsv_name{ARRAY}};
- # import B qw(@optype @specialsv_name);
-}
+ begin_av init_av end_av
+ OPf_SPECIAL OPf_STACKED OPf_MOD OPpLVAL_INTRO SVf_READONLY
+ SVt_PVGV SVt_PVHV SVf_FAKE
+ );
use B::Assembler qw(asm newasm endasm);
+BEGIN {
+ if ($] > 5.006) {
+ B->import(qw(defstash curstash inc_gv warnhook diehook dowarn SVt_PVGV SVt_PVHV SVf_FAKE));
+ }
+ if ($] < 5.009) {
+ B::Asmdata->import(qw(@specialsv_name));
+ } else {
+ B->import(qw(@specialsv_name));
+ }
+}
use B::Concise;
#################################################
+our ($quiet);
my ($varix, $opix, $savebegins, %walked, %files, @cloop, %debug);
my %strtab = (0,0);
my %svtab = (0,0);
@@ -43,8 +49,8 @@ my $tix = 1;
my %ops = (0,0);
# sub asm ($;$$) { }
sub nice ($) { }
-my $perl510 = ($] >= 5.009005);
-my $perl511 = ($] >= 5.011);
+my $PERL510 = ($] >= 5.009005);
+my $PERL511 = ($] >= 5.011);
BEGIN {
my $ithreads = $Config{'useithreads'} eq 'define';
@@ -146,12 +152,22 @@ sub B::GV::ix {
my ($gv,$desired) = @_;
my $ix = $svtab{$$gv};
defined($ix) ? $ix : do {
- if ($gv->GP) { # FIXME gv with gp # if (!$perl510 and ...)
+ if ($debug{G}) {
+ eval "require B::Debug;";
+ $gv->B::GV::debug;
+ }
+ if ($gv->GP) { # FIXME gv with gp # if (!$PERL510 and ...)
my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
nice "[GV]";
# 510 without debugging misses B::SPECIAL::NAME
- my $name = $gv->STASH->NAME . "::"
- . (class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME);
+ my $name;
+ if ($PERL510 and ($gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL'))) {
+ $name = '_';
+ return 0;
+ } else {
+ $name = $gv->STASH->NAME . "::"
+ . (class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME);
+ }
asm "gv_fetchpvx", cstring $name;
$svtab{$$gv} = $varix = $ix = $tix++;
asm "sv_flags", $gv->FLAGS;
@@ -292,7 +308,7 @@ sub B::PVIV::bsave {
$sv->ROK ?
$sv->B::RV::bsave($ix):
$sv->B::NULL::bsave($ix);
- if ($perl510) { # was VERSION >= 5.009
+ if ($PERL510) { # was VERSION >= 5.009
# See note below in B::PVNV::bsave
return if $sv->isa('B::AV');
return if $sv->isa('B::HV');
@@ -307,7 +323,7 @@ sub B::PVIV::bsave {
sub B::PVNV::bsave {
my ($sv,$ix) = @_;
$sv->B::PVIV::bsave($ix);
- if ($perl510) { # VERSION >= 5.009
+ if ($PERL510) { # VERSION >= 5.009
# Magical AVs end up here, but AVs now don't have an NV slot actually
# allocated. Hence don't write out assembly to store the NV slot if
# we're actually an array.
@@ -440,7 +456,7 @@ sub B::AV::bsave {
# asm "av_pushx", $_->ix, sv_flags($_) for @array;
asm "av_pushx", $_ for @array;
asm "sv_refcnt", $av->REFCNT;
- if (!$perl510) { # VERSION < 5.009
+ if (!$PERL510) { # VERSION < 5.009
asm "xav_flags", $av->AvFLAGS;
}
asm "xmg_stash", $stashix;
@@ -449,6 +465,10 @@ sub B::AV::bsave {
sub B::GV::desired {
my $gv = shift;
my ($cv, $form);
+ if ($debug{G}) {
+ eval "require B::Debug;";
+ $gv->B::GV::debug;
+ }
$files{$gv->FILE} && $gv->LINE
|| ${$cv = $gv->CV} && $files{$cv->FILE}
|| ${$form = $gv->FORM} && $files{$form->FILE}
@@ -459,7 +479,7 @@ sub B::HV::bwalk {
return if $walked{$$hv}++;
my %stash = $hv->ARRAY;
while (my($k,$v) = each %stash) {
- if ($v->SvTYPE == SVt_PVGV) {
+ if ($] > 5.006 and $v->SvTYPE == SVt_PVGV) {
my $hash = $v->HV;
if ($$hash && $hash->NAME) {
$hash->bwalk;
@@ -537,7 +557,7 @@ sub B::BINOP::bsave {
# not needed if no pseudohashes
-*B::BINOP::bsave = *B::OP::bsave if $perl510; #VERSION >= 5.009;
+*B::BINOP::bsave = *B::OP::bsave if $PERL510; #VERSION >= 5.009;
# deal with sort / formline
@@ -597,7 +617,7 @@ sub B::BINOP::bsave_fat {
my ($op,$ix) = @_;
my $last = $op->last;
my $lastix = $op->last->ix;
- if (!$perl510 && $op->name eq 'aassign' && $last->name eq 'null') {
+ if (!$PERL510 && $op->name eq 'aassign' && $last->name eq 'null') {
asm "ldop", $lastix unless $lastix == $opix;
asm "op_targ", $last->targ;
}
@@ -633,15 +653,15 @@ sub B::PMOP::bsave {
}
$op->B::BINOP::bsave($ix);
if ($op->pmstashpv) { # avoid empty stash? if (table) pre-compiled else re-compile
- if (!$perl510) {
+ if (!$PERL510) {
asm "op_pmstashpv", pvix $op->pmstashpv;
} else {
# crash in 5.10, 5.11
bwarn("op_pmstashpv ignored") if $debug{M};
}
} else {
bwarn("op_pmstashpv main") if $debug{M};
- asm "op_pmstashpv", pvix "main" unless $perl510;
+ asm "op_pmstashpv", pvix "main" unless $PERL510;
}
} else {
$rrop = "op_pmreplrootgv";
@@ -655,32 +675,16 @@ sub B::PMOP::bsave {
asm $rrop, $rrarg if $rrop;
asm "op_pmreplstart", $rstart if $rstart;
- if ( !$perl510 ) {
+ if ( !$PERL510 ) {
bwarn("PMOP op_pmflags: ",$op->pmflags) if $debug{M};
asm "op_pmflags", $op->pmflags;
asm "op_pmpermflags", $op->pmpermflags;
asm "op_pmdynflags", $op->pmdynflags;
- # asm "op_pmnext", $pmnextix; # XXX
+ # asm "op_pmnext", $pmnextix; # XXX broken
asm "newpv", pvstring $op->precomp; # Special sequence: This is the arg for the next pregcomp
asm "pregcomp";
- } elsif ( $perl511 ) { # full REGEXP type
- #bwarn("PMOP full REGEXP type not yet supported");
- #my $re;
- if (ITHREADS and $op->pmoffset) { # regex_pad is regenerated within pregcomp !?!
- #bwarn("PMOP existing regex_pad not yet supported");
- asm "op_pmflags", $op->pmflags | 2;
- } else {
- asm "op_pmflags", $op->pmflags;
- }
- asm "newpv", pvstring $op->precomp;
- asm "pregcomp";
- asm "op_reflags", $op->reflags; # pregcomp does not set the extflags, just the pmflags
- } elsif ( $perl510 ) {
- # asm "newsvx", $sv->FLAGS;
- # asm "newsv", pvstring $op->precomp;
- #bwarn("PMOP not yet supported");
- if (ITHREADS and $op->pmoffset) { # regex_pad is regenerated within pregcomp?
- # bwarn("PMOP existing regex_pad not yet supported");
+ } elsif ( $PERL510 ) {
+ if (ITHREADS and $op->pmoffset) {
asm "op_pmflags", $op->pmflags | 2;
bwarn("PMOP pmstashpv: ",$op->pmstashpv, ", pmflags: ",$op->pmflags | 2) if $debug{M};
} else {
@@ -689,7 +693,8 @@ sub B::PMOP::bsave {
}
asm "newpv", pvstring $op->precomp;
asm "pregcomp";
- asm "op_reflags", $op->reflags; # pregcomp does not set the extflags, just the pmflags
+ #asm "op_reflags", $op->reflags; # pregcomp does not set the extflags, just the pmflags
+ #asm "op_reflags", $op->reflags; # overwrite the extflags from pregcomp?
}
}
@@ -706,7 +711,7 @@ sub B::PADOP::bsave {
$op->B::OP::bsave($ix);
# crashed in 5.11
- #if ($perl511) {
+ #if ($PERL511) {
asm "op_padix", $op->padix;
#}
}
@@ -752,10 +757,10 @@ sub B::COP::bsave {
}
asm "cop_label", pvix $cop->label, $cop->label if $cop->label; # XXX AD
asm "cop_seq", $cop->cop_seq;
- asm "cop_arybase", $cop->arybase unless $perl510;
+ asm "cop_arybase", $cop->arybase unless $PERL510;
asm "cop_line", $cop->line;
asm "cop_warnings", $warnix;
- if (!$perl510) {
+ if (!$PERL510) {
asm "cop_io", $cop->io->ix;
}
}
@@ -993,6 +998,10 @@ debugger at the early CHECK step, where the compilation happens.
B<M> for Magic and Matches.
+=item B<-D>I<G>
+
+Debug GV's
+
=item B<-D>I<A>
Set developer B<A>ssertions, to help find possible obj-indices out of range.
@@ -1023,6 +1032,10 @@ Scripts that use source filters will fail miserably.
5.10 PMOP and REGEXP ops do not yet work. Various 5.10 and 5.11 crashes.
+B::IO::SUBPROCESS is missing.
+
+Special GV's fail.
+
=back
=head1 NOTICE
View
72 lib/B/C.pm
@@ -9,7 +9,7 @@
package B::C;
-our $VERSION = '1.04_17';
+our $VERSION = '1.04_18';
package B::C::Section;
@@ -282,7 +282,7 @@ sub savere {
my $pv = $re;
my $len = length $pv;
my $pvmax = length(pack "a*",$pv) + 1;
- if ($PERL511) {
+ if (0 and $PERL511) {
# Fill in at least the engine pointer? Or let CALLREGCOMP do that?
$orangesect->add(sprintf("0,%u,%u, 0,0,NULL, NULL,NULL,".
"0,0,0,0,NULL,0,0,NULL,0,0, NULL,NULL,NULL,0,0,0", $len, $pvmax));
@@ -438,20 +438,19 @@ sub B::OP::save {
if ($PERL510 and !$type and $OP_COP{$op->targ}) {
warn sprintf("Null COP: %d\n", $op->targ) if $verbose or $debug_cops;
if ($PERL511) {
- $copsect->comment("$opsect_common, line, seq, warn_sv");
- $copsect->add(sprintf("%s, %u, %s, ".
- "NULL, NULL, 0, ".
- "%u, %s, NULL",
- $op->_save_common, 0, 0, 'NULL' ));
+ $copsect->comment("$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
+ $copsect->add(sprintf("%s, 0, NULL, ".
+ "NULL, 0, 0, ".
+ "%u, NULL",
+ $op->_save_common, 0, 'NULL' ));
} elsif ($PERL510) {
- $copsect->comment("$opsect_common, line, label, seq, warn_sv");
+ $copsect->comment("$opsect_common, line, label, seq, warnings, hints_hash");
$copsect->add(sprintf("%s, %u, NULL, ".
"NULL, NULL, 0, ".
"%u, %s, NULL",
- $op->_save_common, 0,
- 0, 'NULL' ));
+ $op->_save_common, 0, 0, 'NULL' ));
} else {
- $copsect->comment("$opsect_common, label, seq, arybase, line, warn_sv");
+ $copsect->comment("$opsect_common, label, seq, arybase, line, warnings, hints_hash");
$copsect->add(sprintf("%s, NULL, NULL, NULL, 0, 0, 0, NULL", $op->_save_common));
}
my $ix = $copsect->index;
@@ -646,12 +645,11 @@ sub B::COP::save {
if ($PERL511) {
# cop_label now in hints_hash (Change #33656)
- $copsect->comment("$opsect_common, line, seq, warn_sv");
- $copsect->add(sprintf("%s, %u, %s, ".
- "NULL, NULL, 0, ".
- "%u, %s, NULL",
- $op->_save_common, $op->line,
- $op->cop_seq, ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
+ $copsect->comment("$opsect_common, line, stash, file, hints, seq, warn_sv, hints_hash");
+ $copsect->add(sprintf("%s, %u, NULL, ".
+ "NULL, 0, %u, ".
+ "NULL, NULL",
+ $op->_save_common, $op->line, $op->cop_seq, ( $optimize_warn_sv ? $warn_sv : 'NULL' ) ));
if ($op->label) {
$init->add(sprintf("CopLABEL_alloc(&cop_list[%d], %s);", $copsect->index, cstring($op->label)));
}
@@ -731,7 +729,7 @@ sub B::PMOP::save {
if (defined($re)) {
my( $resym, $relen ) = savere( $re, 0 );
if ($PERL510) {
- $init->add(sprintf("PM_SETRE(&$pm, CALLREGCOMP($resym, %u));", $op->reflags));
+ $init->add(sprintf("PM_SETRE(&$pm, CALLREGCOMP(aTHX_ $resym, %u));", $op->pmflags));
} else {
$init->add(sprintf("PM_SETRE(&$pm, pregcomp($resym, $resym + %u, &$pm));", $relen));
}
@@ -1629,9 +1627,9 @@ sub output_all {
my $section;
my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
$listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
- $loopsect, $copsect, $svsect, $xpvsect, $resect,
+ $loopsect, $copsect, $svsect, $xpvsect, $orangesect, $resect,
$xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
- $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect, $orangesect);
+ $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
$symsect->output(\*STDOUT, "#define %s\n");
print "\n";
output_declarations();
@@ -1894,8 +1892,11 @@ EOT
dl_init(aTHX);
exitstatus = perl_run( my_perl );
-
- perl_destruct( my_perl );
+EOT
+ if ($] >= 5.007003) {
+ print " perl_destruct( my_perl );"
+ }
+ print <<'EOT';
perl_free( my_perl );
PERL_SYS_TERM();
@@ -1908,29 +1909,31 @@ static void
xs_init(pTHX)
{
char *file = __FILE__;
+ /* dXSUB_SYS; */
dTARG;
dSP;
EOT
- if ($^O eq 'cygwin') { #FIXME!
- print "\n#undef USE_DYNAMIC_LOADING /* temp. HACK! */"; # REMOVEME! boot_ symbols not linked!
- }
+ #if ($^O eq 'cygwin') { #FIXME!
+ # print "\n#undef USE_DYNAMIC_LOADING /* temp. HACK! */";
+ #}
print "\n#ifdef USE_DYNAMIC_LOADING";
print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
print "\n#endif\n" ;
# delete $xsub{'DynaLoader'};
delete $xsub{'UNIVERSAL'};
print("/* bootstrapping code*/\n\tSAVETMPS;\n");
print("\ttarg=sv_newmortal();\n");
- print "#ifdef USE_DYNAMIC_LOADING\n"; # REMOVEME! boot_ symbols not linked!
+ print "#ifdef USE_DYNAMIC_LOADING\n";
foreach my $stashname (keys %static_ext) {
my $stashxsub = $stashname;
$stashxsub =~ s/::/__/g;
+ # cygwin has Win32CORE
print "\tnewXS(\"${stashname}::bootstrap\", boot_$stashxsub, file);\n";
}
- print "#endif\n"; # REMOVEME! boot_ symbols not linked!
+ print "#endif\n";
print "#ifdef USE_DYNAMIC_LOADING\n";
print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
+ print qq/\tXPUSHp("DynaLoader", strlen("DynaLoader"));\n/;
print qq/\tPUTBACK;\n/;
print "\tboot_DynaLoader(aTHX_ NULL);\n";
print qq/\tSPAGAIN;\n/;
@@ -2145,16 +2148,15 @@ sub save_context
my $curpad_sym = (comppadlist->ARRAY)[1]->save;
my $inc_hv = svref_2object(\%INC)->save;
my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
+ my $amagic_generate = amagic_generation;
# causes PL_curpad assertions
$init->add("/* save context */",
"GvHV(PL_incgv) = $inc_hv;",
"GvAV(PL_incgv) = $inc_av;",
- "#if (PERL_VERSION > 1)",
+ # panic: illegal pad
"PL_curpad = AvARRAY($curpad_sym);",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "#endif",
+ "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));",
"PL_amagic_generation = $amagic_generate;" );
}
@@ -2247,13 +2249,13 @@ sub init_sections {
listop => \$listopsect, logop => \$logopsect,
loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
- sv => \$svsect, re => \$resect,
+ sv => \$svsect, orange => \$orangesect, re => \$resect,
xpv => \$xpvsect, xpvav => \$xpvavsect,
xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
xrv => \$xrvsect, xpvbm => \$xpvbmsect,
- xpvio => \$xpviosect, orange => \$orangesect);
+ xpvio => \$xpviosect);
my ($name, $sectref);
while (($name, $sectref) = splice(@sections, 0, 2)) {
$$sectref = new B::C::Section $name, \%symtable, 0;
View
54 lib/B/CC.pm
@@ -51,14 +51,15 @@ my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
my $know_op = 0; # Set when C variable op already holds the right op
# (from an immediately preceding DOOP(ppname)).
my $errors = 0; # Number of errors encountered
-my %skip_stack; # Hash of PP names which don't need write_back_stack
+my %skip_stack; # Hash of PP names which don't need write_back_stack
my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
my %ignore_op; # Hash of ops which do nothing except returning op_next
my %need_curcop; # Hash of ops which need PL_curcop
my %lexstate; #state of padsvs at the start of a bblock
my $verbose = 0;
+my $THREADS = $Config{useithreads} eq 'define' or $Config{usethreads} eq 'define';
BEGIN {
foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
@@ -79,7 +80,7 @@ my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
omit_taint => \$omit_taint);
# perl patchlevel to generate code for (defaults to current patchlevel)
my $patchlevel = int(0.5 + 1000 * ($] - 5));
-my $perl510 = ($] >= 5.009005);
+my $PERL510 = ($] >= 5.009005);
# Could rewrite push_runtime() and output_runtime() to use a
# temporary file if memory is at a premium.
@@ -102,8 +103,8 @@ sub init_hash { map { $_ => 1 } @_ }
%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
- pp_entertry pp_enterloop pp_enteriter pp_entersub
- pp_enter pp_method);
+ pp_entertry pp_enterloop pp_enteriter pp_entersub
+ pp_enter pp_method);
sub debug {
if ($debug_runtime) {
@@ -131,6 +132,36 @@ sub save_runtime {
sub output_runtime {
my $ppdata;
print qq(#include "cc_runtime.h"\n);
+ if ($THREADS) {
+ # Threads error Bug#55302: too few arguments to function
+ # CALLRUNOPS()=>CALLRUNOPS(aTHX)
+ print '
+#define PP_EVAL_thr(ppaddr, nxt) do { \
+ dJMPENV; \
+ int ret; \
+ PUTBACK; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 0: \
+ PL_op = ppaddr(ARGS); \
+';
+ print 'PL_retstack[PL_retstack_ix - 1] = Nullop; \
+' if $] < 5.009005;
+ print ' if (PL_op != nxt) CALLRUNOPS(aTHX); \
+ JMPENV_POP; \
+ break; \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: \
+ JMPENV_POP; \
+ if (PL_restartop != nxt) \
+ JMPENV_JUMP(3); \
+ } \
+ PL_op = nxt; \
+ SPAGAIN; \
+ } while (0)
+';
+ }
foreach $ppdata (@pp_list) {
my ($name, $runtime, $declare) = @$ppdata;
print "\nstatic\nCCPP($name)\n{\n";
@@ -1174,7 +1205,6 @@ sub doeval {
write_back_stack();
my $sym = loadop($op);
my $ppaddr = $op->ppaddr;
- #runtime(qq/printf("$ppaddr type eval\n");/);
runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
$know_op = 1;
invalidate_lexicals(REGISTER|TEMPORARY);
@@ -1480,7 +1510,7 @@ sub pp_subst {
save_or_restore_lexical_state($$replroot);
runtime sprintf("if (PL_op == ((PMOP*)(%s))%s) goto %s;",
$sym,
- $perl510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot",
+ $PERL510 ? "->op_pmreplrootu.op_pmreplroot" : "->op_pmreplroot",
label($replroot));
$op->pmreplstart->save;
push(@bblock_todo, $replroot);
@@ -1503,7 +1533,7 @@ sub pp_substcont {
save_or_restore_lexical_state(${$pmop->pmreplstart});
runtime sprintf("if (PL_op == ((PMOP*)(%s))%s) goto %s;",
$pmopsym,
- $perl510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart",
+ $PERL510 ? "->op_pmstashstartu.op_pmreplstart" : "->op_pmreplstart",
label($pmop->pmreplstart));
invalidate_lexicals();
return $pmop->next;
@@ -1653,15 +1683,15 @@ sub cc_main {
if (!defined($module)) {
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
"PL_main_start = $start;",
- "#if (PERL_VERSION < 8)",
+ "/* save context */",
+ # panic: illegal pad
"PL_curpad = AvARRAY($curpad_sym);",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "#endif",
+ "av_store(CvPADLIST(PL_main_cv), 0, SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv), 1, SvREFCNT_inc($curpad_sym));",
"PL_initav = (AV *) $init_av;",
"GvHV(PL_incgv) = $inc_hv;",
"GvAV(PL_incgv) = $inc_av;",
- "PL_amagic_generation= $amagic_generate;",
+ "PL_amagic_generation = $amagic_generate;",
);
}
View
2 lib/B/Disassembler.pm
@@ -222,7 +222,7 @@ sub print_insn {
my ($insn, $arg, $comment) = @_;
undef $comment unless $comment;
if (defined($arg)) {
- if ($insn eq 'newopx') {
+ if ($insn eq 'newopx' or $insn eq 'ldop') { # threaded or unthreaded
my $type = $arg >> 7;
my $size = $arg - ($type << 7);
$arg .= sprintf(" \t# size:%d, type:%d %s", $size, $type) if $comment;
View
76 script/perlcc.PL
@@ -1,44 +1,44 @@
#! perl
-
+
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
use Cwd;
-
+
# List explicitly here the variables you want Configure to
# generate. Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries. Thus you write
# $startperl
# to ensure Configure will look for $Config{startperl}.
# Wanted: $archlibexp
-
+
# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
-
+
open OUT,">$file" or die "Can't create $file: $!";
-
+
print "Extracting $file (with variable substitutions)\n";
-
+
# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.
-
+
print OUT <<"!GROK!THIS!";
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
--\$running_under_some_shell;
!GROK!THIS!
-
+
# In the following, perl variables are not expanded during extraction.
-
+
print OUT <<'!NO!SUBS!';
-# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000
+# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000
# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
@@ -103,7 +103,7 @@ sub choose_backend {
}
-sub generate_code {
+sub generate_code {
vprint 0, "Compiling $Input";
@@ -137,7 +137,7 @@ sub vprint {
} else {
# well, they forgot to use a number; means >0
$level = 0;
- }
+ }
my $msg = "@_";
$msg .= "\n" unless substr($msg, -1) eq "\n";
if (opt(v) > $level)
@@ -149,7 +149,7 @@ sub vprint {
sub parse_argv {
- use Getopt::Long;
+ use Getopt::Long;
# disallows using long arguments
# Getopt::Long::Configure("bundling");
@@ -218,9 +218,9 @@ sub parse_argv {
sub opt(*) {
my $opt = shift;
return exists($Options->{$opt}) && ($Options->{$opt} || 0);
-}
+}
-sub compile_module {
+sub compile_module {
die "$0: Compiling to shared libraries is currently disabled\n";
}
@@ -283,7 +283,7 @@ sub compile_cstyle {
} else {
# Don't need to keep it, be safe with a tempfile.
$lose = 1;
- ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
+ ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
close $cfh; # See comment just below
}
vprint 1, "Writing C on $cfile";
@@ -313,7 +313,7 @@ sub compile_cstyle {
if ($lose) {
vprint 2, "unlinking $cfile";
- unlink $cfile or _die("can't unlink $cfile: $!");
+ unlink $cfile or _die("can't unlink $cfile: $!");
}
}
@@ -361,7 +361,7 @@ sub yclept {
}
}
}
-
+
$command .= "-I$_ " for @INC;
return $command;
}
@@ -413,8 +413,8 @@ sub checkopts_byte {
delete $Options->{shared};
}
- for my $o ( qw[c S] ) {
- if (opt($o)) {
+ for my $o ( qw[c S] ) {
+ if (opt($o)) {
warn "$0: Compiling to bytecode is a one-pass process--",
"-$o ignored\n";
delete $Options->{$o};
@@ -437,7 +437,7 @@ sub sanity_check {
}
}
-sub check_read {
+sub check_read {
my $file = shift;
unless (-r $file) {
_die("$0: Input file $file is a directory, not a file\n") if -d _;
@@ -450,7 +450,7 @@ sub check_read {
unless (-f _) {
# XXX: die? don't try this on /dev/tty
warn "$0: WARNING: input $file is not a plain file\n";
- }
+ }
}
sub check_write {
@@ -460,8 +460,8 @@ sub check_write {
}
if (-e _) {
_die("$0: Cannot write on $file: $!\n") unless -w _;
- }
- unless (-w cwd()) {
+ }
+ unless (-w cwd()) {
_die("$0: Cannot write in this directory: $!\n");
}
}
@@ -471,25 +471,25 @@ sub check_perl {
unless (-T $file) {
warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
print "Checking file type... ";
- system("file", $file);
+ system("file", $file);
_die("Please try a perlier file!\n");
- }
+ }
open(my $handle, "<", $file) or _die("XXX: can't open $file: $!");
local $_ = <$handle>;
if (/^#!/ && !/perl/) {
_die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
- }
+ }
-}
+}
# File spawning and error collecting
sub spawnit {
my ($command) = shift;
my (@error,@output);
my $errname;
(undef, $errname) = tempfile("pccXXXXX");
- {
+ {
open (S_OUT, "$command 2>$errname |")
or _die("$0: Couldn't spawn the compiler.\n");
@output = <S_OUT>;
@@ -547,16 +547,16 @@ sub interruptrun
local(*FD);
my $pid = open(FD, "$command |");
my $text;
-
+
local($SIG{HUP}) = sub { kill 9, $pid; exit };
local($SIG{INT}) = sub { kill 9, $pid; exit };
- my $needalarm =
- ($ENV{PERLCC_TIMEOUT} &&
- $Config{'osname'} ne 'MSWin32' &&
+ my $needalarm =
+ ($ENV{PERLCC_TIMEOUT} &&
+ $Config{'osname'} ne 'MSWin32' &&
$command =~ m"(^|\s)perlcc\s");
- eval
+ eval
{
local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);
@@ -608,16 +608,16 @@ perlcc - generate executables from Perl programs
$ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'.
$ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'.
- # with arguments 'a b c'
+ # with arguments 'a b c'
$ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile
- # log into 'c'.
+ # log into 'c'.
=head1 DESCRIPTION
F<perlcc> creates standalone executables from Perl programs, using the
code generators provided by the L<B> module. At present, you may
-either create executable Perl bytecode, using the C<-B> option, or
+either create executable Perl bytecode, using the C<-B> option, or
generate and compile C files using the standard and 'optimised' C
backends.
@@ -670,7 +670,7 @@ compile in finite time and memory, or indeed, at all.
Increase verbosity of output; can be repeated for more verbose output.
-=item -r
+=item -r
Run the resulting compiled script after compiling it.
View
48 t/TESTS
@@ -1,84 +1,84 @@
print 'hi'
>>>>
hi
-######################### 1 ################################
+############################################################
for (1,2,3) { print if /\d/ }
>>>>
123
-######################### 2 ################################
-$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/ge; print $_
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
>>>>
zzz2y2y2
-######################### 3 ################################
-$_ = "xyxyx"; %j=(1,2); s/x/$j{print("z")}/g; print $_
+############################################################
+$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
>>>>
z2y2y2
-######################### 4 ################################
+############################################################
split /a/,"bananarama"; print @_
>>>>
bnnrm
-######################### 5 ################################
+############################################################
{ package P; sub x { print 'ya' } x }
>>>>
ya
-######################### 6 ################################
+############################################################
@z = split /:/,"b:r:n:f:g"; print @z
>>>>
brnfg
-######################### 7 ################################
+############################################################
sub AUTOLOAD { print 1 } &{"a"}()
>>>>
1
-######################### 8 ################################
+############################################################
my $l = 3; $x = sub { print $l }; &$x
>>>>
3
-######################### 9 ################################
+############################################################
my $i = 1;
my $foo = sub {$i = shift if @_};
-print $i;
-print &$foo(3),$i;
+&$foo(3);
+print 'ok';
>>>>
-133
-######################### 10 ################################
+ok
+############################################################
$x="Cannot use"; print index $x, "Can"
>>>>
0
-######################### 11 ################################
+############################################################
my $i=6; eval "print \$i\n"
>>>>
6
-######################### 12 ################################
+############################################################
BEGIN { %h=(1=>2,3=>4) } print $h{3}
>>>>
4
-######################### 13 ################################
+############################################################
open our $T,"a";
print 'ok';
>>>>
ok
-######################### 14 ################################
+############################################################
print <DATA>
__DATA__
a