From: Simon Cozens Date: Sat, 25 Aug 2001 17:45:09 +0000 (+0100) Subject: Custom Ops X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=53e06cf030da5eb71c0b61c0690494f3c70e0555;p=p5sagit%2Fp5-mst-13.2.git Custom Ops Message-ID: <20010825174509.A5752@netthink.co.uk> I also added a fix to Opcode.pm to quite test cases. p4raw-id: //depot/perl@11756 --- diff --git a/dump.c b/dump.c index 6729db8..5fef711 100644 --- a/dump.c +++ b/dump.c @@ -381,7 +381,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) PerlIO_printf(file, " "); PerlIO_printf(file, "%*sTYPE = %s ===> ", - (int)(PL_dumpindent*level-4), "", PL_op_name[o->op_type]); + (int)(PL_dumpindent*level-4), "", OP_NAME(o)); if (o->op_next) { if (o->op_seq) PerlIO_printf(file, "%d\n", o->op_next->op_seq); diff --git a/embed.pl b/embed.pl index 84ff77b..54550b4 100755 --- a/embed.pl +++ b/embed.pl @@ -2248,6 +2248,18 @@ Ap |void |ptr_table_free|PTR_TBL_t *tbl Ap |void |sys_intern_clear Ap |void |sys_intern_init #endif +#if defined(PERL_CUSTOM_OPS) +Ap |char * |custom_op_name|OP* op +Ap |char * |custom_op_desc|OP* op +#endif +#if defined(PERL_CUSTOM_OPS) +Ap |char * |custom_op_name|OP* op +Ap |char * |custom_op_desc|OP* op +#endif +#if defined(PERL_CUSTOM_OPS) +Ap |char * |custom_op_name|OP* op +Ap |char * |custom_op_desc|OP* op +#endif #if defined(PERL_OBJECT) protected: diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index e979851..8c7d254 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -415,6 +415,8 @@ These are a hotchpotch of opcodes still waiting to be considered entertry leavetry -- can be used to 'hide' fatal errors + custom -- where should this go + =item :base_math These ops are not included in :base_core because of the risk of them being diff --git a/intrpvar.h b/intrpvar.h index 4fa7374..8a92d7d 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -487,6 +487,10 @@ PERLVAR(Ireentrant_buffer, REBUF*) /* here we store the _r buffers */ PERLVAR(Isavebegin, bool) /* save BEGINs for compiler */ +#ifdef PERL_CUSTOM_OPS +PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */ +PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */ +#endif /* New variables must be added to the very end for binary compatibility. * XSUB.h provides wrapper functions via perlapi.h that make this * irrelevant, but not all code may be expected to #include XSUB.h. */ diff --git a/op.c b/op.c index 030fabe..c5af7b2 100644 --- a/op.c +++ b/op.c @@ -72,7 +72,7 @@ STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", - PL_op_desc[o->op_type])); + OP_DESC(o))); return o; } @@ -94,7 +94,7 @@ STATIC void S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid) { yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, PL_op_desc[kid->op_type])); + (int)n, name, t, OP_DESC(kid))); } STATIC void @@ -1141,7 +1141,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GETLOGIN: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) - useless = PL_op_desc[o->op_type]; + useless = OP_DESC(o); break; case OP_RV2GV: @@ -1510,7 +1510,7 @@ Perl_mod(pTHX_ OP *o, I32 type) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" - : PL_op_desc[o->op_type])), + : OP_DESC(o))), type ? PL_op_desc[type] : "local")); return o; @@ -1972,7 +1972,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type != OP_PUSHMARK) { yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - PL_op_desc[o->op_type], + OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); return o; } @@ -5431,7 +5431,7 @@ Perl_ck_delete(pTHX_ OP *o) break; default: Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", - PL_op_desc[o->op_type]); + OP_DESC(o)); } op_null(kid); } @@ -5536,14 +5536,14 @@ Perl_ck_exists(pTHX_ OP *o) (void) ref(kid, o->op_type); if (kid->op_type != OP_RV2CV && !PL_error_count) Perl_croak(aTHX_ "%s argument is not a subroutine name", - PL_op_desc[o->op_type]); + OP_DESC(o)); o->op_private |= OPpEXISTS_SUB; } else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", - PL_op_desc[o->op_type]); + OP_DESC(o)); op_null(kid); } return o; @@ -5821,7 +5821,7 @@ Perl_ck_fun(pTHX_ OP *o) } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ - bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid); + bad_type(numargs, "HANDLE", OP_DESC(o), kid); } else { I32 flags = OPf_SPECIAL; @@ -5889,7 +5889,7 @@ Perl_ck_fun(pTHX_ OP *o) } o->op_private |= numargs; if (kid) - return too_many_arguments(o,PL_op_desc[o->op_type]); + return too_many_arguments(o,OP_DESC(o)); listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { @@ -5901,7 +5901,7 @@ Perl_ck_fun(pTHX_ OP *o) while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(o,PL_op_desc[o->op_type]); + return too_few_arguments(o,OP_DESC(o)); } return o; } @@ -6000,7 +6000,7 @@ Perl_ck_grep(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(o,PL_op_desc[o->op_type]); + return too_few_arguments(o,OP_DESC(o)); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); @@ -6505,7 +6505,7 @@ Perl_ck_split(pTHX_ OP *o) scalar(kid); if (kid->op_sibling) - return too_many_arguments(o,PL_op_desc[o->op_type]); + return too_many_arguments(o,OP_DESC(o)); return o; } @@ -7098,6 +7098,44 @@ Perl_peep(pTHX_ register OP *o) LEAVE; } +#ifdef PERL_CUSTOM_OPS +char* custom_op_name(pTHX_ OP* o) +{ + IV index = PTR2IV(o->op_ppaddr); + SV* keysv; + HE* he; + + if (!PL_custom_op_names) /* This probably shouldn't happen */ + return PL_op_name[OP_CUSTOM]; + + keysv = sv_2mortal(newSViv(index)); + + he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); + if (!he) + return PL_op_name[OP_CUSTOM]; /* Don't know who you are */ + + return SvPV_nolen(HeVAL(he)); +} + +char* custom_op_desc(pTHX_ OP* o) +{ + IV index = PTR2IV(o->op_ppaddr); + SV* keysv; + HE* he; + + if (!PL_custom_op_descs) + return PL_op_desc[OP_CUSTOM]; + + keysv = sv_2mortal(newSViv(index)); + + he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); + if (!he) + return PL_op_desc[OP_CUSTOM]; + + return SvPV_nolen(HeVAL(he)); +} +#endif + #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ diff --git a/op.h b/op.h index dbfaced..75a3294 100644 --- a/op.h +++ b/op.h @@ -461,6 +461,7 @@ struct loop { #define PERL_LOADMOD_IMPORT_OPS 0x4 #ifdef USE_REENTRANT_API +er typedef struct { struct tm* tmbuff; } REBUF; diff --git a/opcode.pl b/opcode.pl index 4053671..2e08641 100755 --- a/opcode.pl +++ b/opcode.pl @@ -65,6 +65,16 @@ print <op_type == OP_CUSTOM ? custom_op_name(o) : \\ + PL_op_name[o->op_type]) +#define OP_DESC(o) (o->op_type == OP_CUSTOM ? custom_op_desc(o) : \\ + PL_op_desc[o->op_type]) +#else +#define OP_NAME(o) PL_op_name[o->op_type] +#define OP_DESC(o) PL_op_desc[o->op_type] +#endif + #ifndef DOINIT EXT char *PL_op_name[]; #else @@ -130,7 +140,7 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = { END for (@ops) { - print "\tMEMBER_TO_FPTR(Perl_pp_$_),\n"; + print "\tMEMBER_TO_FPTR(Perl_pp_$_),\n" unless $_ eq "custom"; } print < is one of those. =back +=head1 Custom Operators + +Custom operator support is a new experimental feature that allows you do +define your own ops. This is primarily to allow the building of +interpreters for other languages in the Perl core, but it also allows +optimizations through the creation of "macro-ops" (ops which perform the +functions of multiple ops which are usually executed together, such as +C.) Currently, this feature must be enabled with the C +flag C<-DPERL_CUSTOM_OPS>. + +Enabling the feature will create a new op type, C. The Perl +core does not "know" anything special about this op type, and so it will +not be involved in any optimizations. This also means that you can +define your custom ops to be any op structure - unary, binary, list and +so on - you like. + +It's important to know what custom operators won't do for you. They +won't let you add new syntax to Perl, directly. They won't even let you +add new keywords, directly. In fact, they won't change the way Perl +compiles a program at all. You have to do those changes yourself, after +Perl has compiled the program. You do this either by manipulating the op +tree using a C block and the C module, or by adding +a custom peephole optimizer with the C module. + +When you do this, you replace ordinary Perl ops with custom ops by +creating ops with the type C and the C of your own +PP function. This should be defined in XS code, and should look like +the PP ops in C. You are responsible for ensuring that your op +takes the appropriate number of values from the stack, and you are +responsible for adding stack marks if necessary. + +You should also "register" your op with the Perl interpreter so that it +can produce sensible error and warning messages. Since it is possible to +have multiple custom ops within the one "logical" op type C, +Perl uses the value of C<< o->op_ppaddr >> as a key into the +C and C hashes. This means you +need to enter a name and description for your op at the appropriate +place in the C and C hashes. + +Forthcoming versions of C (version 1.0 and above) should +directly support the creation of custom ops by name; C +will provide functions which make it trivial to "register" custom ops to +the Perl interpreter. + =head1 AUTHORS Until May 1997, this document was maintained by Jeff Okamoto diff --git a/pp_ctl.c b/pp_ctl.c index e79d45d..d9decd7 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1195,27 +1195,27 @@ S_dopoptolabel(pTHX_ char *label) case CXt_SUBST: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); return -1; case CXt_LOOP: if (!cx->blk_loop.label || @@ -1330,27 +1330,27 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_SUBST: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); return -1; case CXt_LOOP: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); diff --git a/pp_sys.c b/pp_sys.c index cdcbc93..bf32b3c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2150,7 +2150,7 @@ PP(pp_ioctl) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", - PL_op_name[optype]); + OP_NAME(PL_op)); s[SvCUR(argsv)] = 0; /* put our null back */ SvSETMAGIC(argsv); /* Assume it has changed */ } diff --git a/run.c b/run.c index 533beac..34dfc9b 100644 --- a/run.c +++ b/run.c @@ -67,7 +67,7 @@ Perl_debop(pTHX_ OP *o) CV *cv; SV *sv; STRLEN n_a; - Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]); + Perl_deb(aTHX_ "%s", OP_NAME(o)); switch (o->op_type) { case OP_CONST: PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); diff --git a/sv.c b/sv.c index e0a242e..3655151 100644 --- a/sv.c +++ b/sv.c @@ -540,7 +540,7 @@ Perl_report_uninit(pTHX) { if (PL_op) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, - " in ", PL_op_desc[PL_op->op_type]); + " in ", OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); } @@ -1616,7 +1616,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1727,7 +1727,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1807,7 +1807,7 @@ S_not_a_number(pTHX_ SV *sv) if (PL_op) Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); @@ -3355,7 +3355,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (first && ch > 255) { if (PL_op) Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op); else Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); first = 0; @@ -3370,7 +3370,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_croak(aTHX_ "Wide character"); } @@ -3597,7 +3597,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIO: if (PL_op) Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); else Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -6760,7 +6760,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); } else s = sv_2pv_flags(sv, lp, flags); diff --git a/utf8.c b/utf8.c index 1c1a5d4..5a5f56c 100644 --- a/utf8.c +++ b/utf8.c @@ -428,7 +428,7 @@ malformed: if (PL_op) Perl_warner(aTHX_ WARN_UTF8, - "%s in %s", s, PL_op_desc[PL_op->op_type]); + "%s in %s", s, OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_UTF8, "%s", s); }