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

13 files changed, 150 insertions, 37 deletions

diff --git a/dump.c b/dump.c
index 6729db8156..5fef71123d 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 84ff77b49b..54550b4322 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 e979851897..8c7d254f3b 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 4fa7374f10..8a92d7dc39 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 030fabe955..c5af7b240f 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(<FH>), close(<FH>) 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 dbfaced5fb..75a3294569 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 4053671733..2e086417dc 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -65,6 +65,16 @@ print <<END;
 
 START_EXTERN_C
 
+#ifdef PERL_CUSTOM_OPS
+#define OP_NAME(o) (o->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 <<END;
@@ -209,7 +219,6 @@ for (@ops) {
     $argsum |= 32 if $flags =~ /I/;		# has corresponding int op
     $argsum |= 64 if $flags =~ /d/;		# danger, unknown side effects
     $argsum |= 128 if $flags =~ /u/;		# defaults to $_
-
     $flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator];
     $argsum |= $opclass{$1} << 9;
     $mul = 0x2000;				# 2 ^ OASHIFT
@@ -291,6 +300,7 @@ print PP "\n\n";
 
 for (@ops) {
     next if /^i_(pre|post)(inc|dec)$/;
+    next if /^custom$/;
     print PP "PERL_PPDEF(Perl_pp_$_)\n";
     print PPSYM "Perl_pp_$_\n";
 }
@@ -887,3 +897,5 @@ threadsv	per-thread value	ck_null		ds0
 # Control (contd.)
 setstate	set statement info	ck_null		s;
 method_named	method with known name	ck_null		d$
+
+custom		unknown custom operator		ck_null		0
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 6478efde97..f89d0a4658 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -2357,6 +2357,50 @@ high character - C<HALF_UPGRADE> 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<gvsv, gvsv, add>.) Currently, this feature must be enabled with the C
+flag C<-DPERL_CUSTOM_OPS>.
+
+Enabling the feature will create a new op type, C<OP_CUSTOM>. 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<CHECK> block and the C<B::Generate> module, or by adding
+a custom peephole optimizer with the C<optimize> module.
+
+When you do this, you replace ordinary Perl ops with custom ops by
+creating ops with the type C<OP_CUSTOM> and the C<pp_addr> of your own
+PP function. This should be defined in XS code, and should look like
+the PP ops in C<pp_*.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<OP_CUSTOM>,
+Perl uses the value of C<< o->op_ppaddr >> as a key into the
+C<PL_custom_op_descs> and C<PL_custom_op_names> hashes. This means you
+need to enter a name and description for your op at the appropriate
+place in the C<PL_custom_op_names> and C<PL_custom_op_descs> hashes.
+
+Forthcoming versions of C<B::Generate> (version 1.0 and above) should
+directly support the creation of custom ops by name; C<Opcodes::Custom> 
+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 e79d45d5e5..d9decd7ae0 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 cdcbc9311e..bf32b3cdcd 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 533beace28..34dfc9b370 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 e0a242e6c2..36551512a8 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 1c1a5d4f70..5a5f56c422 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);
 	}